diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index fc1975a5..76cba2c0 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -24,12 +24,13 @@ jobs: uses: ocaml/setup-ocaml@v3 with: ocaml-compiler: ${{ matrix.ocaml-compiler }} - + dune-cache: true + - name: Install dependencies run: opam install . --deps-only --with-doc --with-test - + - name: Build run: opam exec -- dune build @install @JS @main - + - name: Test run: opam exec -- dune runtest diff --git a/.github/workflows/format.yml b/.github/workflows/format.yml index 54d805f1..e74f7710 100644 --- a/.github/workflows/format.yml +++ b/.github/workflows/format.yml @@ -16,10 +16,11 @@ jobs: uses: ocaml/setup-ocaml@v3 with: ocaml-compiler: 4.14.x + dune-cache: true - name: Install formatter run: opam install ocamlformat.0.26.2 dune - + - name: Check formatting run: | mapfile -t files < <(git diff --name-only --diff-filter=ACMRT \ diff --git a/.gitignore b/.gitignore index a87f82e6..eaa3c569 100644 --- a/.gitignore +++ b/.gitignore @@ -13,3 +13,4 @@ _tags examples/syntax.html js/package/index.js examples/logseq_large.md +_opam/ diff --git a/lib/parsers.ml b/lib/parsers.ml index 8f59aa44..bebe73ac 100644 --- a/lib/parsers.ml +++ b/lib/parsers.ml @@ -2,9 +2,7 @@ open Angstrom open Prelude let whitespace_chars = [ ' '; '\t'; '\n'; '\r'; '\012' ] - let is_whitespace c = c = ' ' || c = '\t' || c = '\n' || c = '\r' || c = '\012' - let space_chars = [ ' '; '\t'; '\026'; '\012' ] module CharSet = Set.Make (Char) @@ -13,7 +11,6 @@ let md_escape_chars = "!\"#$%&'()*+,-./:;<=>?@[]^_`{|}~\\" |> explode |> CharSet.of_list let is_md_escape_char c = CharSet.mem c md_escape_chars - let is_space c = List.mem c space_chars let is_tab = function @@ -21,19 +18,12 @@ let is_tab = function | _ -> false let is_tab_or_space = is_space - let non_tab_or_space = not << is_tab_or_space - let non_space = not << is_space - let eol_chars = [ '\r'; '\n' ] - let is_eol c = List.mem c eol_chars - let non_eol = not << is_eol - let non_space_eol c = non_space c && non_eol c - let is_space_eol c = is_space c || is_eol c let is_hex = function @@ -44,41 +34,23 @@ let is_hex = function | _ -> false let digits = take_while1 is_digit - let eol = string "\n" <|> string "\r\n" - let eols = take_while1 is_eol - let two_eols result = eol *> eol *> return result - let ws = take_while1 is_space - let tabs = take_while1 is_tab - let tabs_or_ws = take_while1 is_tab_or_space - let spaces = skip_while is_space - let spaces_or_eols = skip_while (fun c -> is_eol c || is_space c) - let non_spaces = take_while1 non_space_eol - let letters = take_while1 is_letter - let count_spaces = take_while is_space - let lex p = p <* spaces - let optional p = option None (lift (fun x -> Some x) p) - let optional_list p = option [] p - let lift5 f a b c d e = lift4 f a b c d <*> e - let between_char c1 c2 p = char c1 *> p <* char c2 - let between_string begin' end' p = string begin' *> p <* string end' - let between_string_ci begin' end' p = string_ci begin' *> p <* string end' let chainl1 e op = @@ -171,17 +143,11 @@ let between_string_strict_wrapper ?(ci = false) begin' end' = *> end_string end' ~ci (fun s -> String.concat "" [ begin'; s; end' ]) let peek_line = take_till (fun c -> c = '\r' || c = '\n') |> unsafe_lookahead - let peek_spaces = ws |> unsafe_lookahead - let peek_spaces_or_tabs = tabs_or_ws |> unsafe_lookahead - let take_till1 f = take_while1 (fun c -> not (f c)) - let line = take_till1 is_eol - let optional_line = take_till is_eol - let line_without_spaces = take_till1 (fun c -> c = '\r' || c = '\n' || c = ' ') let clear_parser_resource p r error = @@ -226,11 +192,8 @@ let lines_while p = many1 line let lines_starts_with p = lines_while ((spaces *> p <* spaces) *> optional_line) - let lines_till p = many_till (line <* optional eol) p - let one_of cl = satisfy (fun c -> List.mem c cl) - let not_one_of cl = satisfy (fun c -> not (List.mem c cl)) let take_while1_include_backslash chars_can_escape f = @@ -290,43 +253,108 @@ let block_ref, block_ref_ignore_bracket = let any_char_string = String.make 1 <$> any_char +(** Peek (without consuming) if input starts with one of the given strings. *) +let peek_string_one_of strings = + choice + (List.map + (fun s -> + let n = String.length s in + available >>= fun len -> + if len < n then + fail "peek_string_one_of" + else + peek_string n >>= fun got -> + if got = s then + return s + else + fail "peek_string_one_of") + strings) + +(** Like [take_while1], but also stops (without consuming) before any of + [stop_strings]. Used so multi-byte UTF-8 punctuation can terminate URLs. *) +let take_while1_until_strings stop_strings pred = + if stop_strings = [] then + take_while1 pred + else + fix (fun m -> + peek_string_one_of stop_strings *> return "" + <|> (satisfy pred >>= fun c -> lift (fun r -> String.make 1 c ^ r) m) + <|> return "") + >>= fun s -> + if s = "" then + fail "take_while1_until_strings" + else + return s + let string_contains_balanced_brackets ?(escape_chars = []) - ?(excluded_ending_chars = []) bracket_pair other_delims = + ?(excluded_ending_chars = []) ?(excluded_ending_strings = []) bracket_pair + other_delims = let left, right = unzip bracket_pair in + let body_pred c = + (not @@ List.mem c other_delims) + && (not @@ List.mem c excluded_ending_chars) + && (not (List.mem c left)) + && not (List.mem c right) + in + let take_body = + if excluded_ending_strings = [] && escape_chars = [] then + take_while1 body_pred + else if excluded_ending_strings = [] then + take_while1_include_backslash escape_chars body_pred + else if escape_chars = [] then + take_while1_until_strings excluded_ending_strings body_pred + else + (* escape + multi-byte stoppers: check stopper before each char *) + fix (fun m -> + peek_string_one_of excluded_ending_strings *> return "" + <|> (peek_char >>= function + | Some '\\' -> + any_char *> peek_char >>= fun c_opt -> + (match c_opt with + | Some c when List.mem c escape_chars -> any_char_string + | Some c when body_pred c -> any_char_string + | Some _ -> return "\\" + | None -> return "\\") + >>= fun s -> lift (fun r -> s ^ r) m + | Some c when body_pred c -> + any_char *> lift (fun r -> String.make 1 c ^ r) m + | _ -> return "") + <|> return "") + >>= fun s -> + if s = "" then + fail "take_body" + else + return s + in fix (fun (m : string list list t) -> choice - [ (fun s l -> [ List.cons s (List.flatten l) ]) - <$> take_while1_include_backslash escape_chars (fun c -> - (not @@ List.mem c other_delims) - && (not @@ List.mem c excluded_ending_chars) - && (not (List.mem c left)) - && not (List.mem c right)) - <*> m - ; ( peek_char >>= fun c -> - match c with - | None -> fail "finish" - | Some c when List.mem c left -> - (fun left l right -> [ [ left ]; List.flatten l; right ]) - <$> any_char_string <*> m - <*> (char (List.assoc c bracket_pair) - >>= (fun c -> - (fun right l -> List.cons right (List.flatten l)) - <$> return (String.make 1 c) - <*> m) - <|> return []) - | Some c when List.mem c excluded_ending_chars -> - available >>= fun len -> - if len < 2 then - fail "finish" - else - peek_string 2 >>= fun s -> - let s1 = s.[1] in - if List.mem s1 other_delims then - fail "finish" - else - (fun c l -> [ [ c ]; List.flatten l ]) + [ (fun s l -> [ List.cons s (List.flatten l) ]) <$> take_body <*> m + ; peek_string_one_of excluded_ending_strings *> fail "finish" + <|> ( peek_char >>= fun c -> + match c with + | None -> fail "finish" + | Some c when List.mem c left -> + (fun left l right -> [ [ left ]; List.flatten l; right ]) <$> any_char_string <*> m - | Some _ -> fail "delims" ) + <*> (char (List.assoc c bracket_pair) + >>= (fun c -> + (fun right l -> List.cons right (List.flatten l)) + <$> return (String.make 1 c) + <*> m) + <|> return []) + | Some c when List.mem c excluded_ending_chars -> + available >>= fun len -> + if len < 2 then + fail "finish" + else + peek_string 2 >>= fun s -> + let s1 = s.[1] in + if List.mem s1 other_delims then + fail "finish" + else + (fun c l -> [ [ c ]; List.flatten l ]) + <$> any_char_string <*> m + | Some _ -> fail "delims" ) ; return [ [] ] ]) >>| (String.concat "" << List.flatten) diff --git a/lib/syntax/inline.ml b/lib/syntax/inline.ml index 2dc9cba7..c57d6e7a 100644 --- a/lib/syntax/inline.ml +++ b/lib/syntax/inline.ml @@ -600,19 +600,46 @@ let metadata = >>= (fun s -> return ("{" ^ s ^ "}")) <|> string "{}" <|> return "" +(* ASCII punctuation stripped from bare-URL ends when followed by a delimiter. + CJK punctuation never belongs in a bare URL and always terminates it. *) +let url_ascii_end_punct = [ ','; ';'; '.'; '!'; '?' ] +let url_cjk_end_punct = [ "，"; "。"; "；"; "！"; "？"; "、"; "：" ] + let link_inline = (* Fail fast on ordinary words: require letter+:// without consuming. *) let protocol_part = take_while1 is_letter_or_digit <* string "://" in + let before_path_delim c = + is_space_eol c + || List.mem c inline_link_delims + || c = '/' || c = '?' || c = '#' + in + let before_path_normal c = + non_space c + && (not (before_path_delim c)) + && not (List.mem c url_ascii_end_punct) + in + (* Host/authority: allow mid-host '.' etc., but drop trailing ASCII punct and + always stop before CJK punctuation (multi-byte, so not in char lists). *) let before_path_part = - take_while1 (fun c -> - non_space c && c <> '/' && c <> '?' && c <> '#' - && not (List.mem c inline_link_delims)) + let atom = + take_while1_until_strings url_cjk_end_punct before_path_normal + <|> ( take_while1 (fun c -> List.mem c url_ascii_end_punct) >>= fun ps -> + peek_string_one_of url_cjk_end_punct *> fail "url trail" + <|> (peek_char >>= function + | None -> fail "url trail" + | Some c when before_path_delim c -> fail "url trail" + | Some _ -> return ps) ) + in + fix (fun m -> + List.cons <$> atom <*> m <|> (List.cons <$> atom <*> return [])) + >>| String.concat "" in let remaining_part = (fun c remain -> String.make 1 c ^ remain) <$> choice [ char '/'; char '?'; char '#' ] <*> string_contains_balanced_brackets - ~excluded_ending_chars:[ ','; ';'; '.'; '!'; '?' ] + ~excluded_ending_chars:url_ascii_end_punct + ~excluded_ending_strings:url_cjk_end_punct [ ('(', ')'); ('[', ']') ] (space_chars @ eol_chars) <|> return "" diff --git a/test/test_markdown.ml b/test/test_markdown.ml index d815a315..fbfe099b 100644 --- a/test/test_markdown.ml +++ b/test/test_markdown.ml @@ -158,6 +158,107 @@ let inline = } ; I.Plain ". " ]) ) + ; ( "host endwith '.'" + , `Quick + , check_aux "http://example.com." + (paragraph + [ I.Link + { url = + I.Complex { protocol = "http"; link = "example.com" } + ; label = [ Plain "http://example.com" ] + ; title = None + ; full_text = "http://example.com" + ; metadata = "" + } + ; I.Plain "." + ]) ) + ; ( "host endwith ','" + , `Quick + , check_aux "http://example.com," + (paragraph + [ I.Link + { url = + I.Complex { protocol = "http"; link = "example.com" } + ; label = [ Plain "http://example.com" ] + ; title = None + ; full_text = "http://example.com" + ; metadata = "" + } + ; I.Plain "," + ]) ) + ; ( "path endwith ','" + , `Quick + , check_aux "http://example.com/path," + (paragraph + [ I.Link + { url = + I.Complex + { protocol = "http"; link = "example.com/path" } + ; label = [ Plain "http://example.com/path" ] + ; title = None + ; full_text = "http://example.com/path" + ; metadata = "" + } + ; I.Plain "," + ]) ) + ; ( "host endwith chinese period" + , `Quick + , check_aux "http://example.com。" + (paragraph + [ I.Link + { url = + I.Complex { protocol = "http"; link = "example.com" } + ; label = [ Plain "http://example.com" ] + ; title = None + ; full_text = "http://example.com" + ; metadata = "" + } + ; I.Plain "。" + ]) ) + ; ( "host endwith chinese comma" + , `Quick + , check_aux "http://example.com，" + (paragraph + [ I.Link + { url = + I.Complex { protocol = "http"; link = "example.com" } + ; label = [ Plain "http://example.com" ] + ; title = None + ; full_text = "http://example.com" + ; metadata = "" + } + ; I.Plain "，" + ]) ) + ; ( "path endwith chinese period" + , `Quick + , check_aux "http://example.com/path。更多" + (paragraph + [ I.Link + { url = + I.Complex + { protocol = "http"; link = "example.com/path" } + ; label = [ Plain "http://example.com/path" ] + ; title = None + ; full_text = "http://example.com/path" + ; metadata = "" + } + ; I.Plain "。更多" + ]) ) + ; ( "path endwith chinese comma" + , `Quick + , check_aux "http://example.com/path，更多" + (paragraph + [ I.Link + { url = + I.Complex + { protocol = "http"; link = "example.com/path" } + ; label = [ Plain "http://example.com/path" ] + ; title = None + ; full_text = "http://example.com/path" + ; metadata = "" + } + ; I.Plain "，更多" + ]) ) ; ( "include brackets" , `Quick , check_aux "http://test/(foo)bar"