fix: strip trailing CJK/ASCII punctuation from bare URLs

.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

.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 \

.gitignore

@@ -13,3 +13,4 @@ _tags
 examples/syntax.html
 js/package/index.js
 examples/logseq_large.md
+_opam/

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,27 +11,19 @@ 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
   | '\t' -> true
   | _ -> 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)

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 ""