diff --git a/CHANGELOG.md b/CHANGELOG.md index 1aa8041e..9e5f6c93 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -6,6 +6,7 @@ - Add a visual indicator for the state of the previewer (disconnected, refreshing, ...) (#220, #222) +- Allow frontmatter in included files (#228) ### Fixed diff --git a/docs/doc-repl/main.ml b/docs/doc-repl/main.ml index a4ee9d18..f8eb3714 100644 --- a/docs/doc-repl/main.ml +++ b/docs/doc-repl/main.ml @@ -11,21 +11,7 @@ let view ~dimension ~preview_el ~errors_el ~editor_el starting = let markdown_extension = Jv.apply (Jv.get Jv.global "__CM__markdown") [||] |> Extension.of_jv in - let frontmatter = - (Resolved - { - external_ids = []; - toplevel_attributes = None; - math_link = None; - theme = None; - css_links = []; - js_links = []; - dimension; - highlightjs_theme = None; - math_mode = None; - } - : _ Slipshow.Frontmatter.t) - in + let options = { Slipshow.Frontmatter.Global.empty with dimension } in let config = State.Config.create ~doc:(Jstr.v starting) ~extensions: @@ -33,8 +19,7 @@ let view ~dimension ~preview_el ~errors_el ~editor_el starting = basic_setup; markdown_extension; dark_mode; - Slipshow_communication.slipshow_plugin ~frontmatter ~errors_el - preview_el; + Slipshow_communication.slipshow_plugin ~options ~errors_el preview_el; |] () in @@ -61,7 +46,7 @@ let handle_elem = El.at !!"dimension" el |> Option.map Jstr.to_string |> fun x -> Option.bind x (fun s -> match - Slipshow.Frontmatter.Dimension.of_string (s, Cmarkit.Textloc.none) + Slipshow.Frontmatter.Dimension.of_string' (s, Cmarkit.Textloc.none) with | Ok x -> Some x | Error _ -> None) diff --git a/docs/frontmatter.rst b/docs/frontmatter.rst index d458866d..4260a893 100644 --- a/docs/frontmatter.rst +++ b/docs/frontmatter.rst @@ -45,3 +45,11 @@ The current options for the frontmatter are: present even if they do not seem to be present in the document. Accepts a list of space-separated ids. This is just in order to silence some warnings. This is useful when including svgs or math where some IDs are given. + +Multifile presentations +======================= + +When you split your presentation in multiple files, you can define a frontmatter +in the included files. All options can be duplicated, and will be combined when +applicable. When not applicable, a warning will be raised. +``toplevel-attributes`` refers to the included file. diff --git a/src/cli/main.ml b/src/cli/main.ml index 4cb48f1b..5ce045cc 100644 --- a/src/cli/main.ml +++ b/src/cli/main.ml @@ -16,32 +16,6 @@ let setup_log = 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.Toplevel_attributes.of_string - (s, Cmarkit.Textloc.none) - |> Result.map @@ fun s -> Some s - in - let printer fmt attrs = - let attrs = - Option.value ~default:Slipshow.Frontmatter.Toplevel_attributes.default - attrs - in - let doc = - Cmarkit.Doc.make - (Cmarkit.Block.Ext_standalone_attributes (attrs, Cmarkit.Meta.none)) - in - let s = - let renderer = - Cmarkit_commonmark.renderer ~include_attributes:true () - in - Cmarkit_renderer.doc_to_string renderer doc - in - let s = String.trim s in - Format.fprintf fmt "%s" s - in - Arg.conv (parser, printer) - let io std = let parser_ s = match s with "-" -> Ok std | s -> Ok (`File (Fpath.v s)) @@ -54,109 +28,9 @@ module Custom_conv = struct let input = io `Stdin let output = io `Stdout - - let theme = - let parser_ s = - Result.map Option.some - (Slipshow.Frontmatter.Theme.of_string (s, Cmarkit.Textloc.none)) - 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.Theme.default) - in - Arg.conv (parser_, printer) - - let math_mode = - let parser_ s = - Result.map (fun x -> Some x) - @@ Slipshow.Frontmatter.Math_mode.of_string (s, Cmarkit.Textloc.none) - in - let rec printer fmt = function - | Some `Mathjax -> Format.fprintf fmt "mathjax" - | Some `Katex -> Format.fprintf fmt "katex" - | None -> printer fmt (Some Slipshow.Frontmatter.Math_mode.default) - in - Arg.conv (parser_, printer) - - let dimension = - let int_printer = Cmdliner.Arg.(conv_printer int) in - let parser_ s = - Result.map (fun x -> Some x) - @@ Slipshow.Frontmatter.Dimension.of_string (s, Cmarkit.Textloc.none) - 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.Dimension.default) - in - Cmdliner.Arg.conv ~docv:"WIDTHxHEIGHT" (parser_, printer) end module Compile_args = struct - let css_links = - let doc = - "CSS files to add to the presentation. Can be a local file or a remote \ - URL" - in - Arg.(value & opt_all string [] & info ~docv:"URL" ~doc [ "css" ]) - - let js_links = - let doc = - "JS files to add to the presentation. Can be a local file or a remote URL" - in - Arg.(value & opt_all string [] & info ~docv:"URL" ~doc [ "js" ]) - - let theme = - let doc = - "Slipshow theme to use in the presentation. Can be \"default\" for the \ - default theme, \"none\" for no theme, a local file or a remote URL." - in - Arg.(value & opt Custom_conv.theme None & info ~docv:"URL" ~doc [ "theme" ]) - - let highlightjs_theme = - let doc = "Highlightjs theme to use when highlighting code blocks." in - Arg.( - value - & opt (some string) None - & info ~docv:"THEME_NAME" ~doc [ "highlightjs-theme" ]) - - let math_link = - let doc = - "Where to find the javascript file for rendering math. Optional. When \ - absent, uses mathjax.3.2.2 or katex.0.16.28, depending on the value of \ - math-mode. If URL is an absolute URL, links to it, otherwise the \ - content is embedded in the html file." - in - Arg.( - value - & opt (some string) None - & info ~docv:"URL" ~doc [ "m"; "math-script" ]) - - let dim = - let doc = - "The fixed dimension (in pixels) for your presentation. Can be either \ - WIDTHxHEIGHT where both are integers, or 4:3 (which corresponds to \ - 1440x1080), or 16:9 (which corresponds to 1920x1080)." - in - Arg.( - value - & opt Custom_conv.dimension None - & info ~docv:"WIDTHxHEIGHT" ~doc [ "d"; "dimension"; "dim" ]) - - let toplevel_attributes = - let doc = - "The attributes given to the toplevel element containing all the \ - presentation. Can be enclosed in '{ ... }' or not. Same syntax as \ - attributes in the source file. For experts!" - in - Arg.( - value - & opt Custom_conv.toplevel_attributes None - & info ~docv:"ATTRIBUTES" ~doc [ "toplevel-attributes" ]) - let output = let doc = "Output file path. When absent, generate a filename based on the input \ @@ -174,51 +48,15 @@ module Compile_args = struct in Arg.(value & pos 0 Custom_conv.input `Stdin & info [] ~doc ~docv:"FILE.md") - let math_mode = - let doc = - "Whether to use KaTeX or MathJax to render mathematics. Can be \ - $(b,mathjax) or $(b,katex)." - in - Arg.( - value - & opt Custom_conv.math_mode None - & info [ "math-mode" ] ~doc ~docv:"MODE") - type compile_args = { - cli_frontmatter : Slipshow.Frontmatter.unresolved Slipshow.Frontmatter.t; input : [ `File of Fpath.t | `Stdin ]; output : [ `File of Fpath.t | `Stdout ] option; } let term = let open Term.Syntax in - let+ math_link = math_link - and+ math_mode = math_mode - and+ theme = theme - and+ highlightjs_theme = highlightjs_theme - and+ css_links = css_links - and+ js_links = js_links - and+ input = input - and+ output = output - and+ dimension = dim - and+ toplevel_attributes = toplevel_attributes in - { - cli_frontmatter = - Slipshow.Frontmatter.Unresolved - { - math_link; - theme; - css_links; - dimension; - toplevel_attributes; - js_links; - highlightjs_theme; - math_mode; - external_ids = []; - }; - input; - output; - } + let+ input = input and+ output = output in + { input; output } end module Utils = struct @@ -249,15 +87,12 @@ module Compile = struct | `File o -> Ok (input, o) | `Stdout -> Error "Standard output cannot be used in serve nor watch mode" - let compile ~watch - ~compile_args:{ Compile_args.input; output; cli_frontmatter } = + let compile ~watch ~compile_args:{ Compile_args.input; output } = let output = Utils.output_of_input ~ext:"html" output input in if watch then let* input, output = force_file_io input output in - Run.watch ~cli_frontmatter ~input ~output |> handle_error - else - Run.compile ~input ~output ~cli_frontmatter - |> Result.map ignore |> handle_error + Run.watch ~input ~output |> handle_error + else Run.compile ~input ~output |> Result.map ignore |> handle_error let term = let open Term.Syntax in @@ -278,11 +113,10 @@ end module Serve = struct let ( let* ) = Result.bind - let serve ~port ~compile_args:{ Compile_args.input; output; cli_frontmatter } - = + let serve ~port ~compile_args:{ Compile_args.input; output } = let output = Utils.output_of_input ~ext:"html" output input in let* input, output = Compile.force_file_io input output in - Run.serve ~input ~output ~cli_frontmatter ~port |> handle_error + Run.serve ~input ~output ~port |> handle_error let port = let doc = "Which port to use." in diff --git a/src/cli/run.ml b/src/cli/run.ml index 07ad2013..74f7ae86 100644 --- a/src/cli/run.ml +++ b/src/cli/run.ml @@ -23,39 +23,31 @@ module Io = struct with exn -> Error (`Msg (Printexc.to_string exn)) end -let read_file parent () = +let with_read_file parent f = let l = ref Fpath.Set.empty in - ( l, - fun s -> - let ( // ) = Fpath.( // ) in - let fp = Fpath.normalize @@ (parent // s) in - let normalized = Fpath.normalize @@ (Fpath.v (Sys.getcwd ()) // fp) in - l := Fpath.Set.add normalized !l; - let+ res = Io.read (`File fp) in - Some res ) - -let compile ~input ~output ~cli_frontmatter = - let asset_files, to_asset = - let used_files, read_file = read_file (Fpath.v "./") () in - (used_files, Slipshow.Asset.of_string ~read_file) - in - let cli_frontmatter, warnings = - Diagnosis.with_ @@ fun () -> - Slipshow.Frontmatter.resolve cli_frontmatter ~to_asset + let read_file = + fun s -> + let ( // ) = Fpath.( // ) in + let fp = Fpath.normalize @@ (parent // s) in + let normalized = Fpath.normalize @@ (Fpath.v (Sys.getcwd ()) // fp) in + l := Fpath.Set.add normalized !l; + let+ res = Io.read (`File fp) in + Some res in - List.iter (Format.printf "%a" Diagnosis.report_no_src) warnings; + let res = f read_file in + (res, !l) + +let compile ~input ~output = 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, warnings = + let (html, warnings), used_files = + let parent = + match input with `Stdin -> Fpath.v "./" | `File f -> Fpath.parent f + in 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 + with_read_file parent @@ fun read_file -> + Slipshow.convert ~has_speaker_view:true ?file ~read_file content in let () = List.iter @@ -64,47 +56,37 @@ let compile ~input ~output ~cli_frontmatter = ~code_to_string:Diagnosis.to_code)) warnings in - let all_used_files = Fpath.Set.union !asset_files !used_files in match output with | `Stdout -> print_string html; - Ok all_used_files + Ok used_files | `File output -> ( let+ () = Io.write output html in match input with - | `Stdin -> !used_files + | `Stdin -> used_files | `File f -> Fpath.Set.add (Fpath.normalize (Fpath.( // ) (Fpath.v (Sys.getcwd ())) f)) - all_used_files) + used_files) -let watch ~input ~output ~cli_frontmatter = +let watch ~input ~output = let input_fpath = input in let input = `File input and output = `File output in let compile () = Logs.app (fun m -> m "Compiling..."); - compile ~input ~output ~cli_frontmatter + compile ~input ~output in let () = Slipshow_server.do_watch input_fpath compile in (* [do_watch] never ends! *) Ok () -let serve ~input ~output ~cli_frontmatter ~port = +let serve ~input ~output ~port = let compile () = - let asset_files, to_asset = - let used_files, read_file = read_file (Fpath.v "./") () in - (used_files, Slipshow.Asset.of_string ~read_file) - in - 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, warnings = + let (result, warnings), used_files = let file = Fpath.to_string input in - Slipshow.delayed ~has_speaker_view:true ~frontmatter:cli_frontmatter - ~read_file ~file content + with_read_file (Fpath.parent input) @@ fun read_file -> + Slipshow.delayed ~has_speaker_view:true ~read_file ~file content in let warnings = List.map @@ -114,19 +96,13 @@ let serve ~input ~output ~cli_frontmatter ~port = 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 warnings = warnings |> String.concat "" in let html = Slipshow.add_starting_state result None in let+ () = Io.write output html in ( (result, warnings), Fpath.Set.add (Fpath.normalize (Fpath.( // ) (Fpath.v (Sys.getcwd ())) input)) - all_used_files ) + used_files ) in let () = Slipshow_server.do_serve ~port input compile in (* [do_serve] never ends! *) @@ -134,12 +110,11 @@ let serve ~input ~output ~cli_frontmatter ~port = let markdown_compile ~input ~output = let* content = Io.read input in - let _used_files, read_file = - read_file + let md, _used_files = + with_read_file (match input with `Stdin -> Fpath.v "./" | `File f -> Fpath.parent f) - () + @@ fun read_file -> Slipshow.convert_to_md ~read_file content in - let md = Slipshow.convert_to_md ~read_file content in match output with | `Stdout -> print_string md; diff --git a/src/cli/run.mli b/src/cli/run.mli index b0caf596..daf9b19e 100644 --- a/src/cli/run.mli +++ b/src/cli/run.mli @@ -1,19 +1,13 @@ val compile : input:[ `File of Fpath.t | `Stdin ] -> output:[ `File of Fpath.t | `Stdout ] -> - cli_frontmatter:Slipshow.Frontmatter.unresolved Slipshow.Frontmatter.t -> (Fpath.Set.t, [ `Msg of string ]) result -val watch : - input:Fpath.t -> - output:Fpath.t -> - cli_frontmatter:Slipshow.Frontmatter.unresolved Slipshow.Frontmatter.t -> - (unit, [ `Msg of string ]) result +val watch : input:Fpath.t -> output:Fpath.t -> (unit, [ `Msg of string ]) result val serve : input:Fpath.t -> output:Fpath.t -> - cli_frontmatter:Slipshow.Frontmatter.unresolved Slipshow.Frontmatter.t -> port:int -> (unit, [ `Msg of string ]) result diff --git a/src/cm_plugin/slipshow_communication.ml b/src/cm_plugin/slipshow_communication.ml index b997ca44..f48ab4f2 100644 --- a/src/cm_plugin/slipshow_communication.ml +++ b/src/cm_plugin/slipshow_communication.ml @@ -1,6 +1,6 @@ open Code_mirror -let preview ?slipshow_js ?frontmatter ?read_file () = +let preview ?slipshow_js ?options ?read_file () = let id = ref 0 in let open Fut.Syntax in fun ~ms state content -> @@ -8,10 +8,10 @@ let preview ?slipshow_js ?frontmatter ?read_file () = let my_id = !id in let+ () = Fut.tick ~ms in if my_id = !id then - Previewer.preview ?slipshow_js ?frontmatter ?read_file state content + Previewer.preview ?slipshow_js ?options ?read_file state content -let update_slipshow ?slipshow_js ?frontmatter ?read_file () = - let preview = preview ?slipshow_js ?frontmatter ?read_file () in +let update_slipshow ?slipshow_js ?options ?read_file () = + let preview = preview ?slipshow_js ?options ?read_file () in fun state view -> let open Editor in let content = @@ -24,12 +24,10 @@ let update_slipshow ?slipshow_js ?frontmatter ?read_file () = in preview state content -let slipshow_plugin ?slipshow_js ?frontmatter ?read_file ~errors_el - preview_element = +let slipshow_plugin ?slipshow_js ?options ?read_file ~errors_el preview_element + = let open Editor in - let update_slipshow = - update_slipshow ?slipshow_js ?frontmatter ?read_file () - in + let update_slipshow = update_slipshow ?slipshow_js ?options ?read_file () in View.ViewPlugin.define (fun view -> let state = Previewer.create_previewer ~include_speaker_view:false ~errors_el diff --git a/src/cm_plugin/slipshow_communication.mli b/src/cm_plugin/slipshow_communication.mli index fd49b1ba..37dcd68b 100644 --- a/src/cm_plugin/slipshow_communication.mli +++ b/src/cm_plugin/slipshow_communication.mli @@ -3,7 +3,7 @@ val slipshow_plugin : ?slipshow_js:Slipshow.Asset.t -> - ?frontmatter:Slipshow.Frontmatter.resolved Slipshow.Frontmatter.t -> + ?options:Slipshow.Frontmatter.Global.t -> ?read_file:Slipshow.file_reader -> errors_el:Brr.El.t -> Brr.El.t -> diff --git a/src/compiler/ast.ml b/src/compiler/ast.ml index ec0bbb4d..469a09bb 100644 --- a/src/compiler/ast.ml +++ b/src/compiler/ast.ml @@ -59,7 +59,8 @@ module Files = struct type map = t Fpath.Map.t end -type t = { doc : Cmarkit.Doc.t; files : Files.map } +type options = Frontmatter.Global.t +type t = { doc : Doc.t; files : Files.map; options : options } module Folder = struct let block_ext_default f acc = function @@ -254,6 +255,117 @@ module Mapper = struct let make = Mapper.make ~block_ext_default ~inline_ext_default end +module Fold_mapper = struct + let ( $ ) f (x, meta) = + let acc, res = f x in + (acc, (res, meta)) + + let map_origin (m : 'a Fold_mapper.t) acc ((l, attrs), meta) = + let acc, attrs = m.attrs acc $ attrs in + let acc, text = m.inline m acc (Cmarkit.Inline.Link.text l) in + let text = Option.value ~default:Cmarkit.Inline.empty text in + let reference = Cmarkit.Inline.Link.reference l in + let l = Cmarkit.Inline.Link.make text reference in + (acc, ((l, attrs), meta)) + + let map_media m acc { origin; uri; id } = + let acc, origin = map_origin m acc origin in + (acc, { origin; uri; id }) + + let block (m : 'a Fold_mapper.t) acc = function + | S_block b -> + let acc, b = + match b with + | Included ((block, attrs), meta) -> + let acc, attrs = m.attrs acc $ attrs in + let acc, block = m.block m acc block in + let res = + Option.map (fun block -> Included ((block, attrs), meta)) block + in + (acc, res) + | Div ((block, attrs), meta) -> + let acc, attrs = m.attrs acc $ attrs in + let acc, block = m.block m acc block in + let res = + Option.map (fun block -> Div ((block, attrs), meta)) block + in + (acc, res) + | Slide (({ content; title }, attrs), meta) -> + let acc, attrs = m.attrs acc $ attrs in + let acc, content = m.block m acc content in + let acc, title = + match title with + | None -> (acc, None) + | Some (title, t_attrs) -> + let acc, t_attrs = m.attrs acc $ t_attrs in + let acc, title = m.inline m acc title in + let title = + Option.map (fun title -> (title, t_attrs)) title + in + (acc, title) + in + let res = + Option.map + (fun content -> Slide (({ content; title }, attrs), meta)) + content + in + (acc, res) + | Slip ((block, attrs), meta) -> + let acc, attrs = m.attrs acc $ attrs in + let acc, block = m.block m acc block in + let res = + Option.map (fun block -> Slip ((block, attrs), meta)) block + in + (acc, res) + | SlipScript ((s, attrs), meta) -> + let acc, attrs = m.attrs acc $ attrs in + (acc, Some (SlipScript ((s, attrs), meta))) + | MermaidJS ((s, attrs), meta) -> + let acc, attrs = m.attrs acc $ attrs in + (acc, Some (MermaidJS ((s, attrs), meta))) + | Carousel ((bs, attrs), meta) -> ( + let acc, attrs = m.attrs acc $ attrs in + let acc, bs = List.fold_left_map (m.block m) acc bs in + match List.filter_map Fun.id bs with + | [] -> (acc, None) + | bs -> (acc, Some (Carousel ((bs, attrs), meta)))) + in + let res = Option.map (fun b -> S_block b) b in + (acc, res) + | normal -> Fold_mapper.default.block m acc normal + + let inline (m : 'a Fold_mapper.t) acc = function + | S_inline i -> + let acc, i = + match i with + | Image media -> + let acc, media = map_media m acc media in + (acc, Image media) + | Svg media -> + let acc, media = map_media m acc media in + (acc, Svg media) + | Video media -> + let acc, media = map_media m acc media in + (acc, Video media) + | Audio media -> + let acc, media = map_media m acc media in + (acc, Audio media) + | Pdf media -> + let acc, media = map_media m acc media in + (acc, Pdf media) + | Hand_drawn media -> + let acc, media = map_media m acc media in + (acc, Hand_drawn media) + in + (acc, Some (S_inline i)) + | normal -> Fold_mapper.default.inline m acc normal + + let default = { Fold_mapper.default with block; inline } + + let make ?(block = block) ?(inline = inline) ?attrs () = + Fold_mapper.make ~block ~inline ?attrs () +end + module Utils = struct module Block = struct (** Get the attributes of a cmarkit node, returns them and the element diff --git a/src/compiler/cmarkit_proxy.ml b/src/compiler/cmarkit_proxy.ml index d5aba96d..f817a84e 100644 --- a/src/compiler/cmarkit_proxy.ml +++ b/src/compiler/cmarkit_proxy.ml @@ -2,3 +2,18 @@ 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 + +let of_string ~read_file ~file s = + let frontmatter, s, loc_offset = + match Frontmatter.extract s with + | None -> (Frontmatter.empty, s, (0, 0)) + | Some { frontmatter = txt_fm; rest; rest_offset; fm_offset } -> + let file = Option.value ~default:"-" file in + let to_asset = Asset.of_string ~read_file in + let frontmatter = + Frontmatter.of_string ~to_asset file fm_offset txt_fm + in + (frontmatter, rest, rest_offset) + in + let doc = of_string ~loc_offset ~file s in + (doc, frontmatter) diff --git a/src/compiler/compile.ml b/src/compiler/compile.ml index 7a217c7e..7e51e323 100644 --- a/src/compiler/compile.ml +++ b/src/compiler/compile.ml @@ -97,28 +97,31 @@ let resolve_file ps s = | Path p -> Path (Path_entering.relativize ps p) module Stage1 = struct - let turn_block_quotes_into_divs m ((bq, (attrs, meta2)), meta) = + let turn_block_quotes_into_divs m fm ((bq, (attrs, meta2)), meta) = let b = Block.Block_quote.block bq in - let b = - match Mapper.map_block m b with None -> Block.empty | Some b -> b + let fm, b = + match m.Fold_mapper.block m fm b with + | fm, None -> (fm, Block.empty) + | fm, Some b -> (fm, b) in - let attrs = Mapper.map_attrs m attrs in - Mapper.ret (Ast.div ((b, (attrs, meta2)), meta)) + let fm, attrs = m.attrs fm attrs in + (fm, Some (Ast.div ((b, (attrs, meta2)), meta))) - let handle_slip_scripts_creation m ((cb, (attrs, meta)), meta2) = + let handle_slip_scripts_creation m fm ((cb, (attrs, meta)), meta2) = + let fm, attrs = m.Fold_mapper.attrs fm attrs in + let attrs = (attrs, meta) in match Block.Code_block.info_string cb with - | None -> Mapper.default + | None -> (fm, Some (Block.Code_block ((cb, attrs), meta2))) | Some (info, _) -> ( match Block.Code_block.language_of_info_string info with | Some ("slip-script", _) -> - Mapper.ret - (Ast.slipscript ((cb, (Mapper.map_attrs m attrs, meta)), meta2)) + (fm, Some (Ast.slipscript ((cb, attrs), meta2))) | Some ("=mermaid", _) -> - Mapper.ret - (Ast.mermaid_js ((cb, (Mapper.map_attrs m attrs, meta)), meta2)) - | _ -> Mapper.default) + (fm, Some (Ast.mermaid_js ((cb, attrs), meta2))) + | _ -> (fm, Some (Block.Code_block ((cb, attrs), meta2)))) - let handle_includes ~htbl_include read_file current_path m (attrs, meta) = + let handle_includes ~htbl_include fm read_file current_path + (m : 'a Fold_mapper.t) (attrs, meta) = match ( Attributes.find Special_attrs.include_ attrs, Attributes.find Special_attrs.src attrs ) @@ -137,23 +140,40 @@ module Stage1 = struct error_msg = err; locs; }); - Mapper.default - | Ok None -> Mapper.default + `Default + | Ok None -> `Default | Ok (Some contents) -> ( Hashtbl.add htbl_include (Fpath.to_string relativized_path) contents; - let md = + let md, { Frontmatter.global; local = { toplevel_attributes } } = let file = Some (Fpath.to_string relativized_path) in - Cmarkit_proxy.of_string ~file contents + Cmarkit_proxy.of_string ~file ~read_file contents + in + let fm = + { + fm with + Frontmatter.global = + Frontmatter.Global.combine fm.Frontmatter.global global; + } in Path_entering.in_path current_path (Fpath.parent (Fpath.v src)) @@ fun () -> - match Mapper.map_block m (Doc.block md) with - | None -> Mapper.default - | Some mapped_blocks -> - let attrs = Mapper.map_attrs m attrs in - Mapper.ret - (Ast.included ((mapped_blocks, (attrs, meta)), Meta.none)))) - | _ -> Mapper.default + match m.block m fm (Doc.block md) with + | _, None -> `Default + | fm, Some mapped_blocks -> + let attrs = + match toplevel_attributes with + | None -> attrs + | Some (toplevel_attributes, _) -> + Attributes.merge ~base:toplevel_attributes + ~new_attrs:attrs + in + let fm, attrs = m.attrs fm attrs in + `Return + ( fm, + Some + (Ast.included ((mapped_blocks, (attrs, meta)), Meta.none)) + ))) + | _ -> `Default let get_link_definition (defs : Cmarkit.Label.defs) l = match Inline.Link.reference_definition defs l with @@ -184,10 +204,10 @@ module Stage1 = struct ( (uri, meta), Link_definition.make ~layout ~defined_label ?label ~dest ?title () ) - let handle_image_inlining m defs current_path ((l, (attrs, meta2)), meta) = + let handle_image_inlining m fm defs current_path ((l, (attrs, meta2)), meta) = let text = Inline.Link.text l in - let ( let* ) x f = match x with None -> Mapper.default | Some x -> f x in - let* kind, ld, uri = + let ( let* ) x f = match x with None -> `Default | Some x -> f x in + let* fm, kind, ld, uri = match get_link_definition defs l with | None -> None | Some ((ld, (attrs_ld, meta2)), meta) -> @@ -195,33 +215,39 @@ module Stage1 = struct Cmarkit.Attributes.merge ~base:attrs ~new_attrs:attrs_ld in let kind = classify_link_definition ld attrs in - let attrs_ld = Mapper.map_attrs m attrs_ld in + let fm, attrs_ld = m.Fold_mapper.attrs fm attrs_ld in let dest, ld = update_link_definition current_path (ld, meta) in - Some (kind, ((ld, (attrs_ld, meta2)), meta), dest) + Some (fm, kind, ((ld, (attrs_ld, meta2)), meta), dest) in let reference = `Inline ld in let l = Inline.Link.make text reference in - let attrs = Mapper.map_attrs m attrs in + let fm, attrs = m.attrs fm attrs in let origin = ((l, (attrs, meta2)), meta) in - match kind with - | `Image -> Mapper.ret @@ Ast.image { uri; origin; id = Id.gen () } - | `Svg -> Mapper.ret @@ Ast.svg { uri; origin; id = Id.gen () } - | `Video -> Mapper.ret @@ Ast.video { uri; origin; id = Id.gen () } - | `Audio -> Mapper.ret @@ Ast.audio { uri; origin; id = Id.gen () } - | `Draw -> Mapper.ret @@ Ast.hand_drawn { uri; origin; id = Id.gen () } - | `Pdf -> Mapper.ret @@ Ast.pdf { uri; origin; id = Id.gen () } - - let handle_dash_separated_blocks m (blocks, meta) = - let div ((attrs, am), blocks) = - let attrs = Mapper.map_attrs m attrs in - let blocks = + let res = + match kind with + | `Image -> Ast.image { uri; origin; id = Id.gen () } + | `Svg -> Ast.svg { uri; origin; id = Id.gen () } + | `Video -> Ast.video { uri; origin; id = Id.gen () } + | `Audio -> Ast.audio { uri; origin; id = Id.gen () } + | `Draw -> Ast.hand_drawn { uri; origin; id = Id.gen () } + | `Pdf -> Ast.pdf { uri; origin; id = Id.gen () } + in + `Return (fm, res) + + let handle_dash_separated_blocks (m : 'a Fold_mapper.t) fm (blocks, meta) = + let div fm ((attrs, am), blocks) = + let fm, attrs = m.Fold_mapper.attrs fm attrs in + let fm, blocks = match blocks with - | [ b ] -> Mapper.map_block m b - | blocks -> Mapper.map_block m @@ Block.Blocks (blocks, Meta.none) + | [ b ] -> m.block m fm b + | blocks -> m.block m fm @@ Block.Blocks (blocks, Meta.none) in - match blocks with - | None -> None - | Some blocks -> Some (Ast.div ((blocks, (attrs, am)), Meta.none)) + let res = + match blocks with + | None -> None + | Some blocks -> Some (Ast.div ((blocks, (attrs, am)), Meta.none)) + in + (fm, res) in let find_biggest blocks = let find_biggest biggest block = @@ -253,30 +279,46 @@ module Stage1 = struct | [] -> List.rev ((acc_attrs, List.rev acc1) :: global_acc) in match find_biggest blocks with - | None -> Mapper.default - | Some n -> + | None -> Ast.Fold_mapper.default.block m fm (Block.Blocks (blocks, meta)) + | Some n -> ( let separator = String.make n '-' in let res = collect_until_dash ~first:true ~separator ((Attributes.empty, Meta.none), []) [] blocks in - let res = List.filter_map div res in - Mapper.ret @@ Block.Blocks (res, meta) + let fm, res = + List.fold_left + (fun (fm, acc) b -> + let fm, res = div fm b in + (fm, match res with None -> acc | Some b -> b :: acc)) + (fm, []) res + in + ( fm, + match res with + | [] -> None + | res -> Some (Block.Blocks (List.rev res, meta)) )) 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 ~htbl_include read_file current_path m sa - | _ -> Mapper.default + let block m fm = function + | Block.Blocks bs -> handle_dash_separated_blocks m fm bs + | Block.Block_quote bq -> turn_block_quotes_into_divs m fm bq + | Block.Code_block cb -> handle_slip_scripts_creation m fm cb + | Block.Ext_standalone_attributes sa as b -> ( + match + handle_includes ~htbl_include fm read_file current_path m sa + with + | `Default -> Ast.Fold_mapper.default.block m fm b + | `Return x -> x) + | b -> Ast.Fold_mapper.default.block m fm b in - let inline i = function - | Inline.Image img -> handle_image_inlining i defs current_path img - | _ -> Mapper.default + let inline i fm = function + | Inline.Image img as inl -> ( + match handle_image_inlining i fm defs current_path img with + | `Default -> Ast.Fold_mapper.default.inline i fm inl + | `Return (fm, i) -> (fm, Some i)) + | inl -> Ast.Fold_mapper.default.inline i fm inl in let attrs = function | `Kv (("up", m), v) -> Some (`Kv (("up-at-unpause", m), v)) @@ -324,14 +366,17 @@ module Stage1 = struct Some (`Kv (("children:unstatic-at-unpause", m), v)) | x -> Some x in - Ast.Mapper.make ~block ~inline ~attrs () + let attrs fm x = (fm, Attributes.map attrs x) in + Ast.Fold_mapper.make ~block ~inline ~attrs () - let execute defs read_file md = + let execute ~fm defs read_file md = let htbl_include = Hashtbl.create 3 in - let res = - Cmarkit.Mapper.map_doc (execute ~htbl_include defs read_file) md + let fm, res = + Cmarkit.Fold_mapper.fold_map_doc + (execute ~htbl_include defs read_file) + fm md in - (res, htbl_include) + (fm, res, htbl_include) end module Stage2 = struct @@ -514,10 +559,9 @@ module Stage4 = struct in Ast.Folder.make ~block ~inline () - let execute ~(fm : Frontmatter.resolved Frontmatter.t) ~read_file md = - let (Frontmatter.Resolved fm) = fm in + let execute ~(fm : Frontmatter.t) ~read_file md = let external_ids = - fm.external_ids + fm.global.external_ids |> List.map (fun x -> ((x, Meta.none), `External, Meta.none)) in let asset_map, id_list = @@ -569,7 +613,7 @@ module Stage4 = struct None) asset_map in - ({ Ast.doc = md; files }, id_map) + ({ Ast.doc = md; files; options = fm.global }, id_map) end module Stage5 = struct @@ -602,24 +646,30 @@ module Stage5 = struct ast end -let of_cmarkit ~read_file ~(fm : Frontmatter.resolved Frontmatter.t) md = +let of_cmarkit ~read_file ~(fm : Frontmatter.t) md = let defs = Cmarkit.Doc.defs md in - let md1, htbl_include = Stage1.execute defs read_file md in + let fm, md1, htbl_include = Stage1.execute ~fm defs read_file md in let md2 = Stage2.execute md1 in let md3 = Stage3.execute md2 in let md4, id_map = Stage4.execute ~read_file ~fm md3 in (Stage5.execute ~id_map md4, htbl_include) -let compile ?file ?loc_offset ~attrs ~fm ?(read_file = fun _ -> Ok None) s = +let compile ?file ?(read_file = fun _ -> Ok None) s = Diagnosis.with_ @@ fun () -> let open Cmarkit in + let doc, frontmatter = Cmarkit_proxy.of_string ~read_file ~file s in let md = - 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 + let block = + let toplevel_attributes = + frontmatter.local.toplevel_attributes + |> Option.value ~default:Frontmatter.Toplevel_attributes.default + in + Block.Block_quote ((bq, toplevel_attributes), Meta.none) + in Doc.make block in - of_cmarkit ~read_file ~fm md + of_cmarkit ~read_file md ~fm:frontmatter 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 6ecb58a7..02e94ac5 100644 --- a/src/compiler/compile.mli +++ b/src/compiler/compile.mli @@ -2,7 +2,7 @@ type file_reader = Fpath.t -> (string option, [ `Msg of string ]) result val of_cmarkit : read_file:file_reader -> - fm:Frontmatter.resolved Frontmatter.t -> + fm:Frontmatter.t -> Cmarkit.Doc.t -> Ast.t * (string, string) Hashtbl.t @@ -10,9 +10,6 @@ val to_cmarkit : Ast.t -> Cmarkit.Doc.t val compile : ?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/frontmatter.ml b/src/compiler/frontmatter.ml index ce9c4f36..21ecb921 100644 --- a/src/compiler/frontmatter.ml +++ b/src/compiler/frontmatter.ml @@ -1,36 +1,96 @@ -type resolved = [ `Resolved ] -type unresolved = [ `Unresolved ] - -type 'a fm = { - toplevel_attributes : Cmarkit.Attributes.t option; - math_link : 'a option; - theme : [ `Builtin of Themes.t | `External of string ] option; - css_links : 'a list; - js_links : 'a list; - 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 loced = 'a * Cmarkit.Textloc.t + +let combine_opt option_name x y = + match (x, y) with + | Some (alpha, loc1), Some (beta, loc2) when alpha <> beta -> + Diagnosis.add @@ InconsistentOption { option_name; loc1; loc2 }; + x + | Some _, _ -> x + | None, _ -> y + +module Local = struct + type t = { toplevel_attributes : Cmarkit.Attributes.t Cmarkit.node option } + type 'a with_ = { x : 'a; fm : t } + + let empty = { toplevel_attributes = None } + let with_empty x = { x; fm = empty } +end + +let math_link_key = "math-link" +let theme_key = "theme" +let dimension_key = "dimension" +let highlightjs_theme_key = "highlightjs-theme" +let math_mode_key = "math-mode" +let css_links_key = "css" +let js_links_key = "js" +let external_ids_key = "external-ids" + +module Global = struct + type t = { + math_link : Asset.t loced option; + theme : [ `Builtin of Themes.t | `External of string ] loced option; + dimension : (int * int) loced option; + highlightjs_theme : string loced option; + math_mode : [ `Mathjax | `Katex ] loced option; + css_links : Asset.t list; + js_links : Asset.t list; + 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 with_ = { x : 'a; fm : t } + + let empty = + { + math_link = None; + theme = None; + dimension = None; + highlightjs_theme = None; + math_mode = None; + css_links = []; + js_links = []; + external_ids = []; + } + + let with_empty x = { x; fm = empty } + + let combine x y = + { + math_link = combine_opt math_link_key x.math_link y.math_link; + theme = combine_opt theme_key x.theme y.theme; + dimension = combine_opt dimension_key x.dimension y.dimension; + highlightjs_theme = + combine_opt highlightjs_theme_key x.highlightjs_theme + y.highlightjs_theme; + math_mode = combine_opt math_mode_key x.math_mode y.math_mode; + css_links = x.css_links @ y.css_links; + js_links = x.js_links @ y.js_links; + external_ids = x.external_ids @ y.external_ids; + } +end + +type t = { local : Local.t; global : Global.t } +type fm = t module Toplevel_attributes = struct - type t = Cmarkit.Attributes.t + type t = Cmarkit.Attributes.t Cmarkit.node let key = "toplevel-attributes" let default = - Cmarkit.Attributes.make - ~kv_attributes: - [ - (("slip", Cmarkit.Meta.none), None); - ( ("enter", Cmarkit.Meta.none), - Some ({ v = "~duration:0"; delimiter = None }, Cmarkit.Meta.none) ); - ] - () - - let of_string (s, loc) = + ( Cmarkit.Attributes.make + ~kv_attributes: + [ + (("slip", Cmarkit.Meta.none), None); + ( ("enter", Cmarkit.Meta.none), + Some ({ v = "~duration:0"; delimiter = None }, Cmarkit.Meta.none) + ); + ] + (), + Cmarkit.Meta.none ) + + let of_string ~to_asset:_ (s, loc) = let s = String.trim s in let s = if String.length s > 0 && s.[0] = '{' then @@ -47,69 +107,80 @@ module Toplevel_attributes = struct in let cmarkit = Cmarkit.Doc.block cmarkit in match cmarkit with - | Cmarkit.Block.Ext_standalone_attributes (attrs, _) -> Ok attrs + | Cmarkit.Block.Ext_standalone_attributes attrs -> Ok attrs | _ -> Error (`Msg "Failed to parse the attributes") - let update_frontmatter (fm : _ fm) v = - { fm with toplevel_attributes = Some v } + let update_frontmatter (fm : fm) (v, meta1) = + let v = + match fm.local.toplevel_attributes with + | None -> v + | Some (a, _meta2) -> Cmarkit.Attributes.merge ~base:a ~new_attrs:v + in + { fm with local = { toplevel_attributes = Some (v, meta1) } } end module Math_link = struct - type t = string + type t = Asset.t loced + + let key = math_link_key + let of_string ~to_asset (s, loc) = Ok (to_asset s, loc) - let key = "math-link" - let of_string (s, _) = Ok s - let update_frontmatter (fm : _ fm) v = { fm with math_link = Some v } + let update_frontmatter (fm : fm) v = + let math_link = combine_opt key (Some v) fm.global.math_link in + { fm with global = { fm.global with math_link } } end module Theme = struct - type t = [ `Builtin of Themes.t | `External of string ] + type t = [ `Builtin of Themes.t | `External of string ] loced - let key = "theme" - let default = `Builtin Themes.Default + let key = theme_key + let default = (`Builtin Themes.Default, Cmarkit.Textloc.none) - let of_string (s, _) = + let of_string ~to_asset:_ (s, loc) = match Themes.of_string s with - | Some theme -> Ok (`Builtin theme) - | None -> Ok (`External s) + | Some theme -> Ok (`Builtin theme, loc) + | None -> Ok (`External s, loc) - let update_frontmatter (fm : _ fm) v = { fm with theme = Some v } + let update_frontmatter (fm : fm) v = + let theme = combine_opt key (Some v) fm.global.theme in + { fm with global = { fm.global with theme } } end module Css_links = struct - type t = string list + type t = Asset.t list - let key = "css" + let key = css_links_key - let of_string (s, _) = + let of_string ~to_asset (s, _) = s |> String.split_on_char ' ' - |> List.filter (fun x -> not (String.equal "" x)) + |> List.filter_map (function "" -> None | x -> Some (to_asset x)) |> Result.ok - let update_frontmatter (fm : _ fm) v = - { fm with css_links = v @ fm.css_links } + let update_frontmatter (fm : fm) v = + { fm with global = { fm.global with css_links = v @ fm.global.css_links } } end module Js_links = struct - type t = string list + type t = Asset.t list - let key = "js" + let key = js_links_key - let of_string (s, _) = + let of_string ~to_asset (s, _) = s |> String.split_on_char ' ' - |> List.filter (fun x -> not (String.equal "" x)) + |> List.filter_map (function "" -> None | x -> Some (to_asset x)) |> Result.ok - let update_frontmatter (fm : _ fm) v = { fm with js_links = v @ fm.js_links } + let update_frontmatter (fm : fm) v = + { fm with global = { fm.global with js_links = v @ fm.global.js_links } } end module Dimension = struct - type t = int * int + type t = (int * int) loced - let key = "dimension" - let default = (1440, 1080) + let key = dimension_key + let default = ((1440, 1080), Cmarkit.Textloc.none) - let of_string (s, _) = + let of_string ~to_asset:_ (s, loc) = let ( let* ) = Result.bind in let error = Error @@ -118,61 +189,84 @@ module Dimension = struct let int_parser i = match int_of_string_opt i with Some i -> Ok i | None -> error in - match String.split_on_char 'x' s with - | [ "4:3" ] -> Ok (1440, 1080) - | [ "16:9" ] -> Ok (1920, 1080) - | [ width; height ] -> - let* width = int_parser width in - let* height = int_parser height in - Ok (width, height) - | _ -> error - - let update_frontmatter (fm : _ fm) v = { fm with dimension = Some v } + let res = + match String.split_on_char 'x' s with + | [ "4:3" ] -> Ok (1440, 1080) + | [ "16:9" ] -> Ok (1920, 1080) + | [ width; height ] -> + let* width = int_parser width in + let* height = int_parser height in + Ok (width, height) + | _ -> error + in + Result.map (fun x -> (x, loc)) res + + let of_string' = of_string ~to_asset:() + + let update_frontmatter (fm : fm) v = + let dimension = combine_opt key (Some v) fm.global.dimension in + { fm with global = { fm.global with dimension } } end module Hljs_theme = struct - type t = string + type t = string loced + + let key = highlightjs_theme_key + let of_string ~to_asset:_ = fun (x, loc) -> Ok (x, loc) + let default = ("default", Cmarkit.Textloc.none) - 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 } + let update_frontmatter (fm : fm) v = + let highlightjs_theme = + combine_opt key (Some v) fm.global.highlightjs_theme + in + { fm with global = { fm.global with highlightjs_theme } } end module Math_mode = struct - type t = [ `Mathjax | `Katex ] + type t = [ `Mathjax | `Katex ] loced - let key = "math-mode" + let key = math_mode_key - let of_string = function - | "mathjax", _ -> Ok `Mathjax - | "katex", _ -> Ok `Katex + let of_string ~to_asset:_ = function + | "mathjax", loc -> Ok (`Mathjax, loc) + | "katex", loc -> Ok (`Katex, loc) | _ -> Error (`Msg "Expected \"mathjax\" or \"katex\"") - let default = `Mathjax - let update_frontmatter (fm : _ fm) v = { fm with math_mode = Some v } + let default = (`Mathjax, Cmarkit.Textloc.none) + + let update_frontmatter (fm : fm) v = + let math_mode = combine_opt key (Some v) fm.global.math_mode in + { fm with global = { fm.global with math_mode } } end module type Field = sig type t val key : string - val of_string : string * Cmarkit.Textloc.t -> (t, [ `Msg of string ]) result - val update_frontmatter : string fm -> t -> string fm + + val of_string : + to_asset:(string -> Asset.t) -> + string * Cmarkit.Textloc.t -> + (t, [ `Msg of string ]) result + + val update_frontmatter : fm -> t -> fm end module External_ids = struct type t = string list - let key = "external-ids" + let key = external_ids_key - let of_string (s, _) = + let of_string ~to_asset:_ (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 } + let update_frontmatter (fm : fm) v = + { + fm with + global = { fm.global with external_ids = v @ fm.global.external_ids }; + } end let all_fields = @@ -201,38 +295,7 @@ let fields_map = |> 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 empty = { local = Local.empty; global = Global.empty } let string_sub s idx idx' = (String.sub s idx idx', (idx, idx + idx' - 1)) let split_in_lines s = @@ -285,7 +348,7 @@ let send_general_error ~key ~msg ~vloc = code = "Frontmatter"; }) -let of_string file offset s = +let of_string ~to_asset file offset s = let raise_warning line = let loc = let i, _, (byte_start, byte_end) = line in @@ -318,14 +381,13 @@ let of_string file offset s = send_unrecognized_field ~key ~kloc; fm | Some (module F) -> ( - match F.of_string value with + match F.of_string ~to_asset 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 + List.fold_left handle_line empty assoc let ( let* ) x f = Option.bind x f let ( let+ ) x f = Option.map f x @@ -378,33 +440,3 @@ let extract s = (after, n_lines 0 (after - 1)) in { frontmatter; rest; rest_offset = offset; fm_offset = start } - -let combine (Resolved cli_frontmatter) (Resolved frontmatter) = - let combine_opt cli f = match cli with Some _ as x -> x | None -> f in - (* TODO: warn on cli erasing frontmatter *) - let toplevel_attributes = - combine_opt cli_frontmatter.toplevel_attributes - frontmatter.toplevel_attributes - in - let math_link = combine_opt cli_frontmatter.math_link frontmatter.math_link in - let math_mode = combine_opt cli_frontmatter.math_mode frontmatter.math_mode in - let theme = combine_opt cli_frontmatter.theme frontmatter.theme in - let dimension = combine_opt cli_frontmatter.dimension frontmatter.dimension in - let css_links = cli_frontmatter.css_links @ frontmatter.css_links in - let js_links = cli_frontmatter.js_links @ frontmatter.js_links in - 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; - math_link; - theme; - css_links; - dimension; - js_links; - highlightjs_theme; - math_mode; - external_ids; - } diff --git a/src/compiler/frontmatter.mli b/src/compiler/frontmatter.mli index 7668f492..5f6ef35d 100644 --- a/src/compiler/frontmatter.mli +++ b/src/compiler/frontmatter.mli @@ -1,31 +1,49 @@ -type resolved = [ `Resolved ] -type unresolved = [ `Unresolved ] - -type 'a fm = { - toplevel_attributes : Cmarkit.Attributes.t option; - math_link : 'a option; - theme : [ `Builtin of Themes.t | `External of string ] option; - css_links : 'a list; - js_links : 'a list; - dimension : (int * int) option; - highlightjs_theme : string option; - math_mode : [ `Mathjax | `Katex ] option; - external_ids : string list; -} +type 'a loced := 'a * Cmarkit.Textloc.t + +module Local : sig + type t = { toplevel_attributes : Cmarkit.Attributes.t Cmarkit.node option } + type 'a with_ = { x : 'a; fm : t } + + val empty : t + val with_empty : 'a -> 'a with_ +end + +module Global : sig + type t = { + math_link : Asset.t loced option; + theme : [ `Builtin of Themes.t | `External of string ] loced option; + dimension : (int * int) loced option; + highlightjs_theme : string loced option; + math_mode : [ `Mathjax | `Katex ] loced option; + css_links : Asset.t list; + js_links : Asset.t list; + external_ids : string list; + } + + type 'a with_ = { x : 'a; fm : t } + + val empty : t + val with_empty : 'a -> 'a with_ + val combine : t -> t -> t +end + +type t = { local : Local.t; global : Global.t } -(** We use this trick to only allow [string fm] and [Asset.t fm], but it is - completely unnecessary and a flagrant example of useless over-engineering. -*) -type 'a t = - | Unresolved : string fm -> unresolved t - | Resolved : Asset.t fm -> resolved t +val empty : t -module type Field = sig +type fm := t + +module type Field := sig type t val key : string - val of_string : string * Cmarkit.Textloc.t -> (t, [ `Msg of string ]) result - val update_frontmatter : string fm -> t -> string fm + + val of_string : + to_asset:(string -> Asset.t) -> + string * Cmarkit.Textloc.t -> + (t, [ `Msg of string ]) result + + val update_frontmatter : fm -> t -> fm end module type Field_with_default := sig @@ -35,21 +53,27 @@ module type Field_with_default := sig end module Toplevel_attributes : - Field_with_default with type t = Cmarkit.Attributes.t + Field_with_default with type t = Cmarkit.Attributes.t Cmarkit.node -module Math_link : Field with type t = string +module Math_link : Field with type t = Asset.t loced module Theme : - Field_with_default with type t = [ `Builtin of Themes.t | `External of string ] + Field_with_default + with type t = [ `Builtin of Themes.t | `External of string ] loced + +module Css_links : Field with type t = Asset.t list +module Js_links : Field with type t = Asset.t list -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 ] +module Dimension : sig + include Field_with_default with type t = (int * int) loced -val empty : resolved t -val of_string : string -> int -> string -> unresolved t + val of_string' : string * Cmarkit.Textloc.t -> (t, [ `Msg of string ]) result +end + +module Hljs_theme : Field_with_default with type t = string loced +module Math_mode : Field_with_default with type t = [ `Mathjax | `Katex ] loced + +val of_string : to_asset:(string -> Asset.t) -> string -> int -> string -> t type extraction = { frontmatter : string; @@ -61,6 +85,3 @@ type extraction = { val extract : string -> extraction option (** Split the frontmatter and the rest of the input string, still computing offsets *) - -val combine : resolved t -> resolved t -> resolved t -val resolve : unresolved t -> to_asset:(string -> Asset.t) -> resolved t diff --git a/src/compiler/slipshow.ml b/src/compiler/slipshow.ml index 2ca0db25..ac2a48e0 100644 --- a/src/compiler/slipshow.ml +++ b/src/compiler/slipshow.ml @@ -241,22 +241,7 @@ let string_to_delayed s = Option.bind s @@ fun s -> try Some (Marshal.from_string s 0) with _ -> None 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 { frontmatter; rest; rest_offset; fm_offset } -> - let file = "-" in - let frontmatter = Frontmatter.of_string file fm_offset frontmatter in - let to_asset = Asset.of_string ~read_file in - let frontmatter = Frontmatter.resolve frontmatter ~to_asset in - (frontmatter, rest, rest_offset) - in - let md = - Cmarkit.Doc.of_string ~loc_offset ~heading_auto_ids:false ~strict:false - content - in - let sd, _htbl_include = Compile.of_cmarkit ~read_file ~fm md in + let (sd, _htbl_include), _ = Compile.compile ~read_file content in let sd = Compile.to_cmarkit sd in Cmarkit_commonmark.of_doc ~include_attributes:false sd @@ -272,32 +257,21 @@ let to_grace file whole_content htbl_include er = Grace.Source.(`String { name = file; content = whole_content })) er -let delayed ?slipshow_js ?(frontmatter = Frontmatter.empty) ?file +let delayed ?(options = Frontmatter.Global.empty) ?slipshow_js ?file ?(read_file = fun _ -> Ok None) ~has_speaker_view s = let whole_content = s in - let (Frontmatter.Resolved frontmatter, s, loc_offset), warnings = - Diagnosis.with_ @@ fun () -> - match Frontmatter.extract s with - | None -> (frontmatter, s, (0, 0)) - | Some { frontmatter = txt_fm; rest; rest_offset; fm_offset } -> - let file = Option.value ~default:"-" file in - let txt_fm = Frontmatter.of_string file fm_offset txt_fm in - let to_asset = Asset.of_string ~read_file in - let txt_frontmatter = Frontmatter.resolve txt_fm ~to_asset in - let frontmatter = Frontmatter.combine txt_frontmatter frontmatter in - (frontmatter, rest, rest_offset) - in - let toplevel_attributes = - frontmatter.toplevel_attributes - |> Option.value ~default:Frontmatter.Toplevel_attributes.default - in + let (ast, htbl_include), errors = Compile.compile ?file ~read_file s in + let options = Frontmatter.Global.combine options ast.Ast.options in + let ast = { ast with options } in let dimension = - frontmatter.dimension |> Option.value ~default:Frontmatter.Dimension.default + options.dimension + |> Option.value ~default:Frontmatter.Dimension.default + |> fst in - let css_links = frontmatter.css_links in - let js_links = frontmatter.js_links in + let css_links = options.css_links in + let js_links = options.js_links in let math_mode = - Option.value ~default:Frontmatter.Math_mode.default frontmatter.math_mode + Option.value ~default:Frontmatter.Math_mode.default options.math_mode |> fst in let resolve_theme = function | `Builtin _ as x -> x @@ -306,26 +280,21 @@ let delayed ?slipshow_js ?(frontmatter = Frontmatter.empty) ?file `External asset in let theme = - match frontmatter.theme with - | None -> resolve_theme Frontmatter.Theme.default - | Some t -> resolve_theme t + match options.theme with + | None -> resolve_theme (fst Frontmatter.Theme.default) + | Some t -> resolve_theme (fst t) in let highlightjs_theme = Option.value ~default:Frontmatter.Hljs_theme.default - frontmatter.highlightjs_theme - in - let math_link = frontmatter.math_link in - let (md, htbl_include), errors = - Compile.compile ~loc_offset ?file ~attrs:toplevel_attributes - ~fm:(Frontmatter.Resolved frontmatter) ~read_file s + options.highlightjs_theme + |> fst in + let math_link = options.math_link |> Option.map fst in let warnings = - List.filter_map - (to_grace file whole_content htbl_include) - (warnings @ errors) + List.filter_map (to_grace file whole_content htbl_include) errors in - let content = Renderers.to_html_string md in - let has = Has.find_out md in + let content = Renderers.to_html_string ast in + let has = Has.find_out ast in let res = embed_in_page ~has_speaker_view ~slipshow_js ~dimension ~has ~math_link ~theme ~css_links ~js_links content ~highlightjs_theme ~math_mode @@ -392,10 +361,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 ?file +let convert ?options ~has_speaker_view ?autofocus ?slipshow_js ?file ?starting_state ?read_file s = let delayed, w = - delayed ~has_speaker_view ?slipshow_js ?frontmatter ?file ?read_file s + delayed ?options ~has_speaker_view ?slipshow_js ?file ?read_file s in 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 98931cc4..a4089bab 100644 --- a/src/compiler/slipshow.mli +++ b/src/compiler/slipshow.mli @@ -21,8 +21,8 @@ type file_reader = Fpath.t -> (string option, [ `Msg of string ]) result [Ok None]). *) val delayed : + ?options:Frontmatter.Global.t -> ?slipshow_js:Asset.t -> - ?frontmatter:Frontmatter.resolved Frontmatter.t -> ?file:string -> ?read_file:file_reader -> has_speaker_view:bool -> @@ -36,10 +36,10 @@ val add_starting_state : ?autofocus:bool -> delayed -> starting_state option -> string val convert : + ?options:Frontmatter.Global.t -> has_speaker_view:bool -> ?autofocus:bool -> ?slipshow_js:Asset.t -> - ?frontmatter:Frontmatter.resolved Frontmatter.t -> ?file:string -> ?starting_state:starting_state -> ?read_file:file_reader -> diff --git a/src/diagnosis/diagnosis.ml b/src/diagnosis/diagnosis.ml index 9caf0827..7336a657 100644 --- a/src/diagnosis/diagnosis.ml +++ b/src/diagnosis/diagnosis.ml @@ -15,6 +15,7 @@ type t = | 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 } + | InconsistentOption of { option_name : string; loc1 : loc; loc2 : loc } | MissingID of { id : string; loc : loc } | UnknownAttribute of { attr : string; loc : loc } | General of { @@ -56,6 +57,8 @@ let pp ppf = function "Attribute '%s' is neither a standard HTML attribute nor a slipshow \ specific one" attr + | InconsistentOption { option_name; _ } -> + Format.fprintf ppf "option '%s' is provided multiple times" option_name let with_range source_map loc f = let open Grace in @@ -180,6 +183,18 @@ let to_grace source_map error = in Some (Diagnostic.createf ~labels Warning "Non standard attribute: '%s'" attr) + | InconsistentOption { option_name; loc1; loc2 } -> + let labels = + List.filter_map Fun.id + [ + with_range loc1 @@ Diagnostic.Label.primaryf ""; + with_range loc2 @@ Diagnostic.Label.primaryf ""; + ] + in + Some + (Diagnostic.createf ~labels Warning + "Option '%s' is assigned multiple times in incompatible ways" + option_name) let errors_acc = ref [] let add x = errors_acc := x :: !errors_acc @@ -208,6 +223,7 @@ let to_code = function | MissingID _ -> "IDNotFound" | UnknownAttribute _ -> "UnknownAttribute" | General { code; _ } -> code + | InconsistentOption _ -> "InconsistentOption" let report_no_src fmt x = let msg = Format.asprintf "%a" pp x in diff --git a/src/diagnosis/diagnosis.mli b/src/diagnosis/diagnosis.mli index 3800e7e3..0b54a78a 100644 --- a/src/diagnosis/diagnosis.mli +++ b/src/diagnosis/diagnosis.mli @@ -8,6 +8,7 @@ type t = | 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 } + | InconsistentOption of { option_name : string; loc1 : loc; loc2 : loc } | MissingID of { id : string; loc : loc } | UnknownAttribute of { attr : string; loc : loc } | General of { diff --git a/src/engine/previewer/previewer.ml b/src/engine/previewer/previewer.ml index b86b5a24..3011ca82 100644 --- a/src/engine/previewer/previewer.ml +++ b/src/engine/previewer/previewer.ml @@ -177,12 +177,12 @@ let set_srcdoc { index; panels; errors_el; preview_status; _ } El.set_class preview_status_class true preview_status; Console.(log [ "exception"; Printexc.to_string exn ]) -let preview ?slipshow_js ?frontmatter ?read_file previewer source = +let preview ?options ?slipshow_js ?read_file previewer source = let () = El.set_class preview_status_class false previewer.preview_status in let starting_state = !(previewer.stage) in let has_speaker_view = previewer.include_speaker_view in let slipshow, warnings = - Slipshow.convert ~file:"-" ~has_speaker_view ?slipshow_js ?frontmatter + Slipshow.convert ~file:"-" ~has_speaker_view ?slipshow_js ?options ?read_file ~autofocus:false ~starting_state source in let warnings = diff --git a/src/engine/previewer/previewer.mli b/src/engine/previewer/previewer.mli index 87b1e8ef..a07803bd 100644 --- a/src/engine/previewer/previewer.mli +++ b/src/engine/previewer/previewer.mli @@ -19,8 +19,8 @@ val create_previewer : previewer val preview : + ?options:Slipshow.Frontmatter.Global.t -> ?slipshow_js:Slipshow.Asset.t -> - ?frontmatter:Slipshow.Frontmatter.resolved Slipshow.Frontmatter.t -> ?read_file:Slipshow.file_reader -> previewer -> string -> diff --git a/test/compiler/dimension.t/run.t b/test/compiler/dimension.t/run.t index abc223f6..c658d8ee 100644 --- a/test/compiler/dimension.t/run.t +++ b/test/compiler/dimension.t/run.t @@ -1,32 +1,58 @@ -Let's start with an empty file +We can provide the dimension with dimension - $ touch file.md + $ cat > file.md << EOF + > --- + > dimension: qfdesfesf + > --- + > EOF + $ slipshow compile file.md + warning: Error while parsing frontmatter field 'dimension' + ┌─ file.md:2:11 + 2 │ dimension: qfdesfesf + │ ^^^^^^^^^^ Expected "4:3", "16:9", or two integers separated by a 'x' + -We can provide the dimension with --dimension + $ cat > file.md << EOF + > --- + > dimension: wrongxefzefezf + > --- + > EOF + $ slipshow compile file.md + warning: Error while parsing frontmatter field 'dimension' + ┌─ file.md:2:11 + 2 │ dimension: wrongxefzefezf + │ ^^^^^^^^^^^^^^^ Expected "4:3", "16:9", or two integers separated by a 'x' + - $ slipshow compile --dimension qfdesfesf file.md - slipshow: option '--dimension': Expected "4:3", "16:9", or two integers - separated by a 'x' - Usage: slipshow compile [OPTION]… [FILE.md] - Try 'slipshow compile --help' or 'slipshow --help' for more information. - [124] - $ slipshow compile --dimension wrongxefzefezf file.md - slipshow: option '--dimension': Expected "4:3", "16:9", or two integers - separated by a 'x' - Usage: slipshow compile [OPTION]… [FILE.md] - Try 'slipshow compile --help' or 'slipshow --help' for more information. - [124] - $ slipshow compile --dimension 1920xwrong file.md - slipshow: option '--dimension': Expected "4:3", "16:9", or two integers - separated by a 'x' - Usage: slipshow compile [OPTION]… [FILE.md] - Try 'slipshow compile --help' or 'slipshow --help' for more information. - [124] - $ slipshow compile --dimension 16:9 file.md - $ slipshow compile --dimension 4:3 file.md - $ slipshow compile --dimension 1920x1080 file.md + $ cat > file.md << EOF + > --- + > dimension: 1920xwrong + > --- + > EOF + $ slipshow compile file.md + warning: Error while parsing frontmatter field 'dimension' + ┌─ file.md:2:11 + 2 │ dimension: 1920xwrong + │ ^^^^^^^^^^^ Expected "4:3", "16:9", or two integers separated by a 'x' + --d and --dim work too + $ cat > file.md << EOF + > --- + > dimension: 16:9 + > --- + > EOF + $ slipshow compile file.md - $ slipshow compile --dim 16:9 file.md - $ slipshow compile -d 16:9 file.md + $ cat > file.md << EOF + > --- + > dimension: 4:3 + > --- + > EOF + $ slipshow compile file.md + + $ cat > file.md << EOF + > --- + > dimension: 1920x1080 + > --- + > EOF + $ slipshow compile file.md diff --git a/test/compiler/multi-frontmatter.t/chapter1.md b/test/compiler/multi-frontmatter.t/chapter1.md new file mode 100644 index 00000000..b6070dc5 --- /dev/null +++ b/test/compiler/multi-frontmatter.t/chapter1.md @@ -0,0 +1,8 @@ +--- +dimension: 16:9 +css: file2.css +math-mode: katex +--- + + +Hello! How are you? diff --git a/test/compiler/multi-frontmatter.t/chapter2/chapter2.md b/test/compiler/multi-frontmatter.t/chapter2/chapter2.md new file mode 100644 index 00000000..a0a09843 --- /dev/null +++ b/test/compiler/multi-frontmatter.t/chapter2/chapter2.md @@ -0,0 +1,7 @@ +I am the chapter 2 {pause} and I consist of two parts: + +### Part 1 +{include src="parts/part1.md"} + +### Part 2 +{include src="parts/part2.md"} diff --git a/test/compiler/multi-frontmatter.t/chapter2/image_of_chapter_2.png b/test/compiler/multi-frontmatter.t/chapter2/image_of_chapter_2.png new file mode 100644 index 00000000..bfae69d5 Binary files /dev/null and b/test/compiler/multi-frontmatter.t/chapter2/image_of_chapter_2.png differ diff --git a/test/compiler/multi-frontmatter.t/chapter2/parts/part1.md b/test/compiler/multi-frontmatter.t/chapter2/parts/part1.md new file mode 100644 index 00000000..38a97814 --- /dev/null +++ b/test/compiler/multi-frontmatter.t/chapter2/parts/part1.md @@ -0,0 +1 @@ +This is Part 1 diff --git a/test/compiler/multi-frontmatter.t/chapter2/parts/part2.md b/test/compiler/multi-frontmatter.t/chapter2/parts/part2.md new file mode 100644 index 00000000..7f76330b --- /dev/null +++ b/test/compiler/multi-frontmatter.t/chapter2/parts/part2.md @@ -0,0 +1,3 @@ +This is Part 2 and it includes an image: + +![](../image_of_chapter_2.png) diff --git a/test/compiler/multi-frontmatter.t/main.md b/test/compiler/multi-frontmatter.t/main.md new file mode 100644 index 00000000..a99bceda --- /dev/null +++ b/test/compiler/multi-frontmatter.t/main.md @@ -0,0 +1,16 @@ +--- +dimension: 16:9 +css: file.css +math-mode: mathjax +--- + +# A title + +## Chapter 1 + +{include src=chapter1.md} + +{pause} +## Chapter 2 + +{include src="chapter2/chapter2.md" pause} diff --git a/test/compiler/multi-frontmatter.t/run.t b/test/compiler/multi-frontmatter.t/run.t new file mode 100644 index 00000000..6e1261f8 --- /dev/null +++ b/test/compiler/multi-frontmatter.t/run.t @@ -0,0 +1,39 @@ +Compatible multiple options are not reported (dimension, css files). +Incompatible options are reported (math-mode) + + $ slipshow compile main.md + warning: Option 'math-mode' is assigned multiple times in incompatible ways + ┌─ chapter1.md:4:11 + 4 │ math-mode: katex + │ ^^^^^^ + ┌─ main.md:4:11 + 4 │ math-mode: mathjax + │ ^^^^^^^^ + + warning: file 'file2.css' could not be read: file2.css: No such file or directory + + warning: file 'file.css' could not be read: file.css: No such file or directory + + +Css files are well combined + + $ show_source main.html | grep "rel=\"stylesheet\"" + + +Warnings are also raised in case of duplicated fields in the same file + + $ slipshow compile single-file.md + warning: Option 'math-mode' is assigned multiple times in incompatible ways + ┌─ single-file.md:6:11 + 5 │ math-mode: katex + │ ^^^^^^ + 6 │ math-mode: mathjax + │ ^^^^^^^^ + + warning: Option 'dimension' is assigned multiple times in incompatible ways + ┌─ single-file.md:4:11 + 3 │ dimension: 16:9 + │ ^^^^^ + 4 │ dimension: 4:3 + │ ^^^^ + diff --git a/test/compiler/multi-frontmatter.t/single-file.md b/test/compiler/multi-frontmatter.t/single-file.md new file mode 100644 index 00000000..3cf7b89a --- /dev/null +++ b/test/compiler/multi-frontmatter.t/single-file.md @@ -0,0 +1,7 @@ +--- +dimension: 16:9 +dimension: 16:9 +dimension: 4:3 +math-mode: katex +math-mode: mathjax +--- diff --git a/test/compiler/simple.t/run.t b/test/compiler/simple.t/run.t index 4621a59e..e9f4757e 100644 --- a/test/compiler/simple.t/run.t +++ b/test/compiler/simple.t/run.t @@ -68,41 +68,3 @@ If we do not pass an input file, it gets its value from stdin $ ls stdout.html stdout.html - -If we pass a mathjax value, with a remote url: - - $ echo "#title \$1+1=0\$" > with_inline_math.md - $ cat > with_block_math.md << EOF - > \`\`\`math - > 1 + 1 = 0 - > \`\`\` - > EOF - $ echo "#title 1+1=0" > without_math.md - - $ slipshow compile -o m1.html --math-script https://cdn.jsdelivr.net/npm/mathjax@3/es5/tex-mml-chtml.js with_inline_math.md - $ slipshow compile -o m2.html --math-script https://cdn.jsdelivr.net/npm/mathjax@3/es5/tex-mml-chtml.js with_block_math.md - $ slipshow compile -o m3.html --math-script https://cdn.jsdelivr.net/npm/mathjax@3/es5/tex-mml-chtml.js without_math.md - - $ show_source m1.html | grep mathjax -