├── lib ├── syntax │ ├── emoji.ml │ ├── markdown_hr.ml │ ├── pos.ml │ ├── helper.ml │ ├── markdown_level.ml │ ├── range.ml │ ├── markdown_line_breaks.ml │ ├── extended │ │ ├── block_reference.ml │ │ ├── hash_tag.ml │ │ ├── hiccup.ml │ │ └── nested_link.ml │ ├── comment.ml │ ├── type_parser.ml │ ├── markdown_footnote.ml │ ├── hr.ml │ ├── directive.ml │ ├── markdown_comment.ml │ ├── markdown_property.ml │ ├── markdown_front_matter.ml │ ├── property.ml │ ├── email_address.ml │ ├── markdown_code_block.ml │ ├── tree_type.mli │ ├── outline_inline.ml │ ├── markdown_definition.ml │ ├── latex_env.ml │ ├── paragraph.ml │ ├── footnote.ml │ ├── drawer.ml │ ├── timestamp.ml │ ├── raw_html.ml │ ├── type.ml │ ├── table.ml │ ├── type_op.ml │ ├── heading0.ml │ ├── lists0.ml │ └── block0.ml ├── util.ml ├── dune ├── transform │ ├── transformer.ml │ └── markdown_transformer.ml ├── mldoc.ml ├── extList.ml ├── export │ ├── reference.ml │ ├── exporter.ml │ ├── conf.ml │ ├── opml.ml │ └── xml.ml ├── .ocamlinit ├── mldoc_parser.ml ├── opml_parser.ml ├── option.ml ├── document.ml ├── parsers.ml └── zip.ml ├── dune-project ├── js ├── package │ ├── .gitignore │ ├── package-lock.json │ ├── package.json │ ├── bin │ │ ├── messenger.js │ │ ├── cli.js │ │ └── convert.cmd.js │ └── yarn.lock ├── dune └── lib.ml ├── deploy-npm-package ├── bench ├── dune └── bench.ml ├── bin ├── dune └── main.ml ├── .gitignore ├── .ocamlformat ├── makefile ├── mlorg ├── todo.org ├── .github └── workflows │ ├── format.yml │ └── ci.yml ├── test ├── dune ├── test_zip.ml ├── test_export_opml.ml ├── gen_md_files.ml ├── test_export_markdown.ml └── test_org.ml ├── mldoc.opam ├── readme.org └── examples └── syntax.md /lib/syntax/emoji.ml: -------------------------------------------------------------------------------- 1 | (* TODO: *) 2 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 3.5) 2 | (name mldoc) 3 | -------------------------------------------------------------------------------- /js/package/.gitignore: -------------------------------------------------------------------------------- 1 | /node_modules/ 2 | index.js 3 | -------------------------------------------------------------------------------- /lib/util.ml: -------------------------------------------------------------------------------- 1 | let priority_to_string priority = "[#" ^ String.make 1 priority ^ "]" 2 | -------------------------------------------------------------------------------- /js/package/package-lock.json: -------------------------------------------------------------------------------- 1 | { 2 | "name": "mldoc", 3 | "version": "0.0.1", 4 | "lockfileVersion": 1 5 | } 6 | -------------------------------------------------------------------------------- /lib/syntax/markdown_hr.ml: -------------------------------------------------------------------------------- 1 | open Angstrom 2 | 3 | let hr_char = choice [ char '-'; char '*'; char '_' ] 4 | 5 | let parse = many1 hr_char 6 | -------------------------------------------------------------------------------- /deploy-npm-package: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | make 4 | 5 | mv _build/default/js/lib.bc.js ./js/package/index.js 6 | cd ./js/package && yarn publish 7 | -------------------------------------------------------------------------------- /bench/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name bench) 3 | (libraries angstrom mldoc core core_bench core_unix.command_unix)) 4 | 5 | (alias 6 | (name bench) 7 | (deps bench.exe)) 8 | -------------------------------------------------------------------------------- /bin/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name main) 3 | (public_name mldoc) 4 | (libraries angstrom mldoc cmdliner lwt.unix)) 5 | 6 | (alias 7 | (name main) 8 | (deps main.exe)) 9 | -------------------------------------------------------------------------------- /lib/syntax/pos.ml: -------------------------------------------------------------------------------- 1 | type pos_meta = 2 | { start_pos : int 3 | ; end_pos : int 4 | } 5 | [@@deriving yojson] 6 | 7 | let dummy_pos = { start_pos = 0; end_pos = 0 } 8 | -------------------------------------------------------------------------------- /lib/syntax/helper.ml: -------------------------------------------------------------------------------- 1 | open! Prelude 2 | open Angstrom 3 | open Pos 4 | 5 | let with_pos_meta p = 6 | lift3 (fun start_pos t end_pos -> (t, { start_pos; end_pos })) pos p pos 7 | -------------------------------------------------------------------------------- /lib/syntax/markdown_level.ml: -------------------------------------------------------------------------------- 1 | open Angstrom 2 | open Parsers 3 | 4 | let parse = optional tabs_or_ws >>= fun indents -> 5 | take_while1 (fun c -> c = '#') >>| fun level_str -> 6 | (indents, level_str) 7 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | _build/ 2 | setup.data 3 | setup.log 4 | setup.bin 5 | *.native 6 | *.byte 7 | TAGS 8 | tmp 9 | _tags 10 | *.merlin 11 | *.install 12 | /dune-workspace 13 | examples/syntax.html 14 | js/package/index.js 15 | -------------------------------------------------------------------------------- /lib/syntax/range.ml: -------------------------------------------------------------------------------- 1 | type t = 2 | { start : Timestamp.t 3 | ; stop : Timestamp.t 4 | } 5 | [@@deriving yojson] 6 | 7 | let to_string { start; stop } = 8 | Printf.sprintf "%s--%s" (Timestamp.to_string start) (Timestamp.to_string stop) 9 | -------------------------------------------------------------------------------- /js/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name lib) 3 | (modes js) 4 | (preprocess 5 | (pps js_of_ocaml-ppx)) 6 | (js_of_ocaml (flags --target-env browser)) 7 | (libraries angstrom js_of_ocaml mldoc)) 8 | 9 | (alias 10 | (name JS) 11 | (deps lib.bc.js)) 12 | -------------------------------------------------------------------------------- /lib/syntax/markdown_line_breaks.ml: -------------------------------------------------------------------------------- 1 | open Angstrom 2 | open Parsers 3 | 4 | (* End a line with two or more spaces*) 5 | let parse = 6 | ws <* end_of_line >>= fun s -> 7 | if String.length s >= 2 then 8 | return s 9 | else 10 | fail "At least two spaces" 11 | -------------------------------------------------------------------------------- /lib/syntax/extended/block_reference.ml: -------------------------------------------------------------------------------- 1 | (* Inspired by https://roamresearch.com *) 2 | 3 | (* ((block reference)) *) 4 | 5 | open Angstrom 6 | open Parsers 7 | 8 | let parse = 9 | between_string "((" "))" 10 | (take_while1 (function 11 | | ')' -> false 12 | | _ -> true)) 13 | -------------------------------------------------------------------------------- /lib/syntax/comment.ml: -------------------------------------------------------------------------------- 1 | open Angstrom 2 | open Parsers 3 | open Type 4 | open Conf 5 | 6 | let org_parse = 7 | let p = 8 | (char '#' <* ws) *> line >>= function 9 | | s -> return @@ Comment s 10 | in 11 | between_eols p 12 | 13 | let parse config = 14 | match config.format with 15 | | Org -> org_parse 16 | | Markdown -> Markdown_comment.parse 17 | -------------------------------------------------------------------------------- /lib/dune: -------------------------------------------------------------------------------- 1 | (include_subdirs unqualified) 2 | 3 | (env 4 | (dev 5 | (flags 6 | (:standard -warn-error -A)))) 7 | 8 | (library 9 | (name mldoc) 10 | (public_name mldoc) 11 | (preprocess 12 | (pps ppx_deriving_yojson)) 13 | (libraries 14 | angstrom 15 | bigstringaf 16 | yojson 17 | ppx_deriving_yojson.runtime 18 | uri 19 | str 20 | xmlm) 21 | (wrapped false)) 22 | -------------------------------------------------------------------------------- /lib/transform/transformer.ml: -------------------------------------------------------------------------------- 1 | open! Prelude 2 | 3 | module Property : sig 4 | val remove_properties_on_type : Type.t list -> Type.t list 5 | 6 | val remove_properties_on_tree_type : Type.t Tree_type.t -> Type.t Tree_type.t 7 | end = struct 8 | let remove_properties_on_type = Type_op.remove_properties 9 | 10 | let remove_properties_on_tree_type = Tree_type.remove_properties 11 | end 12 | -------------------------------------------------------------------------------- /.ocamlformat: -------------------------------------------------------------------------------- 1 | version=0.26.2 2 | break-separators=before 3 | dock-collection-brackets=false 4 | break-sequences=true 5 | doc-comments=before 6 | field-space=loose 7 | let-and=sparse 8 | sequence-style=terminator 9 | type-decl=sparse 10 | wrap-comments=false 11 | if-then-else=k-r 12 | let-and=sparse 13 | space-around-records 14 | space-around-lists 15 | space-around-arrays 16 | cases-exp-indent=2 17 | break-cases=all 18 | indicate-nested-or-patterns=unsafe-no 19 | -------------------------------------------------------------------------------- /lib/mldoc.ml: -------------------------------------------------------------------------------- 1 | (** Entry point of the org library *) 2 | 3 | module Document = Document 4 | module Block = Type_parser.Block 5 | module Inline = Inline 6 | module Exporters = Exporter.Exporters 7 | module Conf = Conf 8 | module Exporter = Exporter 9 | module Timestamp = Timestamp 10 | module Parser = Mldoc_parser 11 | module Type = Type 12 | module Property = Property 13 | 14 | module Backends = struct 15 | module Html = Html 16 | end 17 | 18 | module Xml = Xml 19 | -------------------------------------------------------------------------------- /makefile: -------------------------------------------------------------------------------- 1 | DUNE ?= dune 2 | 3 | all: 4 | opam install --deps-only . 5 | $(DUNE) build --profile=release @install @JS @main @bench 6 | 7 | check: tests 8 | 9 | test: 10 | opam install --deps-only -t . 11 | $(DUNE) runtest 12 | 13 | clean: 14 | dune clean 15 | run: 16 | $(DUNE) exec ./bin/main.exe 17 | 18 | bench: 19 | $(DUNE) exec ./bench/bench.exe 20 | 21 | fmt: 22 | dune build @fmt --auto-promote 23 | 24 | .PHONY: pin test all clean check bench fmt 25 | -------------------------------------------------------------------------------- /lib/extList.ml: -------------------------------------------------------------------------------- 1 | module type ExtList = sig 2 | type elt 3 | 4 | val push : elt -> unit 5 | 6 | val get : unit -> elt list 7 | 8 | val update : (elt list -> elt list) -> unit 9 | end 10 | 11 | module Make (S : sig 12 | type t 13 | 14 | val base : t list 15 | end) : ExtList with type elt = S.t = struct 16 | type elt = S.t 17 | 18 | let r = ref S.base 19 | 20 | let push x = r := x :: !r 21 | 22 | let get () = !r 23 | 24 | let update f = r := f !r 25 | end 26 | -------------------------------------------------------------------------------- /lib/syntax/type_parser.ml: -------------------------------------------------------------------------------- 1 | open! Prelude 2 | 3 | module rec Lists : sig 4 | val parse : 5 | Conf.t -> (Type.t * Pos.pos_meta) list Angstrom.t -> Type.t Angstrom.t 6 | end = 7 | Lists0.MakeLists (Heading) 8 | 9 | and Heading : sig 10 | val parse : Conf.t -> Type.t Angstrom.t 11 | 12 | val anchor_link : string -> string 13 | end = 14 | Heading0.MakeHeading (Block) 15 | 16 | and Block : sig 17 | val parse : Conf.t -> Type.t Angstrom.t 18 | 19 | val results : Type.t Angstrom.t 20 | end = 21 | Block0.MakeBlock (Lists) 22 | -------------------------------------------------------------------------------- /lib/syntax/markdown_footnote.ml: -------------------------------------------------------------------------------- 1 | open Angstrom 2 | open Parsers 3 | 4 | (* 5 | Here's a simple footnote,[^1] and here's a longer one.[^bignote] 6 | 7 | [^1]: This is the first footnote. 8 | 9 | [^bignote]: Here's one with multiple paragraphs and code. 10 | 11 | Indent paragraphs to include them in the footnote. 12 | 13 | `{ my code }` 14 | 15 | Add as many paragraphs as you like. 16 | 17 | 18 | *) 19 | 20 | (* To create a footnote reference, add a caret and an identifier inside brackets ([^1]). 21 | Identifiers can be numbers or words, but they can’t contain spaces or tabs *) 22 | let reference = 23 | string "[^" *> take_while1 (fun c -> c <> ']' && non_space_eol c) <* char ']' 24 | -------------------------------------------------------------------------------- /lib/export/reference.ml: -------------------------------------------------------------------------------- 1 | type t = 2 | { (* (block-uuid, (content-include-children, content)) list *) 3 | embed_blocks : (string * (string * string)) list 4 | ; (* (page-name, content) list 5 | all page-names is lowercase *) 6 | embed_pages : (string * string) list 7 | } 8 | [@@deriving yojson] 9 | 10 | type parsed_t = 11 | { (** (block-uuid, (content-include-children, content)) list *) 12 | parsed_embed_blocks : (string * (Type.t list * Type.t list)) list 13 | ; (** (page-name, content) list 14 | all page-names is lowercase *) 15 | parsed_embed_pages : (string * Type.t list) list 16 | } 17 | 18 | let empty_parsed_t = { parsed_embed_blocks = []; parsed_embed_pages = [] } 19 | -------------------------------------------------------------------------------- /lib/syntax/hr.ml: -------------------------------------------------------------------------------- 1 | open Angstrom 2 | open Parsers 3 | open Type 4 | open Prelude 5 | open Conf 6 | 7 | let org = count 5 (char '-') 8 | 9 | (* markdown, excuse me... 10 | *** 11 | --- 12 | _________________ 13 | *) 14 | 15 | let parse config = 16 | let p = 17 | let parser = 18 | match config.format with 19 | | Org -> org 20 | | Markdown -> Markdown_hr.parse 21 | in 22 | parser >>= fun s -> 23 | if List.length s >= 3 && List.length (remove_dups s) == 1 then 24 | return Horizontal_Rule 25 | else 26 | fail "At least 3 chars" >>= fun _ -> return Horizontal_Rule 27 | in 28 | optional eols *> optional spaces *> p 29 | <* optional spaces 30 | <* choice [ end_of_line; end_of_input ] 31 | -------------------------------------------------------------------------------- /lib/.ocamlinit: -------------------------------------------------------------------------------- 1 | #use "topfind";; 2 | #require "str";; 3 | #require "ppx_deriving_yojson";; 4 | #directory "_build";; 5 | open Angstrom;; 6 | open Prelude;; 7 | open Parsers;; 8 | open Inline;; 9 | open Mldoc_parser;; 10 | open Conf;; 11 | let _ = Printexc.record_backtrace true;; 12 | let config = { toc = true; parse_outline_only = false; heading_number = true 13 | ; keep_line_break = false 14 | ; format = Conf.Markdown 15 | ; heading_to_list = true 16 | ; exporting_keep_properties = true 17 | ; inline_type_with_pos = false; 18 | export_md_indent_style = Conf.Dashes; 19 | export_md_remove_options = []; 20 | hiccup_in_block = true; 21 | inline_skip_macro = false; 22 | enable_drawers = true; 23 | parse_marker = true; 24 | parse_priority = true; 25 | };; 26 | -------------------------------------------------------------------------------- /lib/syntax/directive.ml: -------------------------------------------------------------------------------- 1 | (* 2 | #+TITLE: Test 3 | #+AUTHOR: Testman 4 | #+MACRO: macro-name Contents which can refer to argument using $1, ..., $k 5 | 6 | Example: 7 | : #+MACRO: test Some /$1/ *$2* 8 | : {{{test(Macro, invocation)}}} 9 | gives 10 | #+MACRO: test Some /$1/ *$2* 11 | *) 12 | 13 | open Angstrom 14 | open Parsers 15 | open Type 16 | open Prelude 17 | 18 | let name = 19 | between_string "#+" ":" (take_while1 (fun c -> c <> ':' && non_eol c)) 20 | >>= fun s -> 21 | if starts_with s "BEGIN_" || starts_with s "begin_" then 22 | fail "Directive might be a block" 23 | else 24 | return s 25 | 26 | let parse = 27 | let p = 28 | lift2 29 | (fun name value -> Directive (name, value)) 30 | name (spaces *> optional_line) 31 | in 32 | between_eols p 33 | -------------------------------------------------------------------------------- /lib/syntax/markdown_comment.ml: -------------------------------------------------------------------------------- 1 | open Angstrom 2 | open Parsers 3 | open Type 4 | 5 | (* 9 | * 10 | * *) 13 | (* We don't support inline comment like for now. *) 14 | let html_comment = 15 | choice [ string "" in 20 | String.equal (String.trim line) prefix) 21 | "markdown_comment" 22 | >>= fun lines -> 23 | let content = String.concat "" lines in 24 | return @@ Comment content 25 | 26 | (* [//]: # *) 27 | let comment = 28 | let prefix = optional spaces *> string "[//]: #" <* optional spaces in 29 | lift2 (fun _ s -> Comment s) prefix line 30 | 31 | let parse = choice [ html_comment; comment ] 32 | -------------------------------------------------------------------------------- /js/package/package.json: -------------------------------------------------------------------------------- 1 | { 2 | "name": "mldoc", 3 | "version": "1.5.9", 4 | "description": "Another Emacs Org-mode parser.", 5 | "main": "index.js", 6 | "scripts": { 7 | "test": "echo \"Error: no test specified\" && exit 1" 8 | }, 9 | "repository": { 10 | "type": "git", 11 | "url": "git+https://github.com/mldoc/mldoc.git" 12 | }, 13 | "keywords": [ 14 | "Org", 15 | "mode", 16 | "parser", 17 | "OCaml", 18 | "Js_of_ocaml" 19 | ], 20 | "author": "Tienson Qin ", 21 | "license": "ISC", 22 | "bin": { 23 | "mldoc": "./bin/cli.js" 24 | }, 25 | "dependencies": { 26 | "yargs": "^12.0.2" 27 | }, 28 | "bugs": { 29 | "url": "https://github.com/mldoc/mldoc/issues" 30 | }, 31 | "homepage": "https://github.com/mldoc/mldoc#readme" 32 | } 33 | -------------------------------------------------------------------------------- /lib/syntax/markdown_property.ml: -------------------------------------------------------------------------------- 1 | open Angstrom 2 | open Parsers 3 | open Type 4 | 5 | (* 6 | Add Property syntax to markdown format. 7 | key::value 8 | *) 9 | 10 | let property config = 11 | let only_key = 12 | spaces *> take_while1 (fun c -> c <> ':' && non_space_eol c) 13 | <* string "::" <* spaces 14 | <* (eol *> return () <|> end_of_input) 15 | in 16 | let key = 17 | spaces *> take_while1 (fun c -> c <> ':' && non_space_eol c) <* string ":: " 18 | in 19 | let value = 20 | spaces *> take_till is_eol <* (eol *> return () <|> end_of_input) 21 | in 22 | lift2 23 | (fun k v -> 24 | let value = String.trim v in 25 | let references = Property.property_references config value in 26 | (k, value, references)) 27 | key value 28 | <|> (only_key >>| fun k -> (k, "", [])) 29 | 30 | let parse config = many1 (property config) >>| fun kvs -> Property_Drawer kvs 31 | -------------------------------------------------------------------------------- /mlorg: -------------------------------------------------------------------------------- 1 | * mldoc TODOS 2 | ** DONE Heading numbers 3 | CLOSED: [2018-11-13 Tue 17:17] 4 | 5 | ** DONE macro expansion 6 | CLOSED: [2018-11-13 Tue 18:46] 7 | 8 | ** TODO support options 9 | *** DONE Heading 10 | CLOSED: [2018-11-14 Wed 14:20] 11 | ~#+OPTIONS: num:x~, *x* could be nil or number. 12 | 13 | *** Subscript, superscript ^:nil 14 | 15 | ** DONE table support column groups 16 | CLOSED: [2018-11-14 Wed 19:08] 17 | ** TODO tangle extraction 18 | ** TODO configuration 19 | 1. toc 20 | 2. num 21 | 3. html export 22 | 1. image extensions 23 | 2. mathjax 24 | 3. source highlight 25 | 4. standalone (html header) 26 | 5. css 27 | 6. javascript 28 | 4. hardbreak // 29 | 30 | 31 | 32 | ** TODO better error report 33 | ** TODO how to extent using javascript :experiment: 34 | ** TODO declarative parser using edn or json :experiment: 35 | ** TODO presentation 36 | revealjs? 37 | -------------------------------------------------------------------------------- /todo.org: -------------------------------------------------------------------------------- 1 | * mldoc TODOS 2 | ** DONE Heading numbers 3 | CLOSED: [2018-11-13 Tue 17:17] 4 | 5 | ** DONE macro expansion 6 | CLOSED: [2018-11-13 Tue 18:46] 7 | 8 | ** TODO support options 9 | *** DONE Heading 10 | CLOSED: [2018-11-14 Wed 14:20] 11 | ~#+OPTIONS: num:x~, *x* could be nil or number. 12 | 13 | *** Subscript, superscript ^:nil 14 | 15 | ** DONE table support column groups 16 | CLOSED: [2018-11-14 Wed 19:08] 17 | ** TODO tangle extraction 18 | ** TODO configuration 19 | 1. toc 20 | 2. num 21 | 3. html export 22 | 1. image extensions 23 | 2. mathjax 24 | 3. source highlight 25 | 4. standalone (html header) 26 | 5. css 27 | 6. javascript 28 | 4. hardbreak // 29 | 30 | 31 | 32 | ** TODO better error report 33 | ** TODO how to extent using javascript :experiment: 34 | ** TODO declarative parser using edn or json :experiment: 35 | ** TODO presentation 36 | revealjs? 37 | -------------------------------------------------------------------------------- /lib/syntax/extended/hash_tag.ml: -------------------------------------------------------------------------------- 1 | open! Prelude 2 | open Angstrom 3 | open Parsers 4 | 5 | let tag_delims = [ ','; ';'; '.'; '!'; '?'; '\''; '"'; ':'; '#' ] 6 | 7 | let hashtag_name = 8 | let hashtag_name_part = 9 | take_while1 (fun c -> 10 | non_space_eol c && (not (List.mem c tag_delims)) && c <> '[') 11 | <|> page_ref 12 | (* ignore last consecutive periods *) 13 | <|> ( take_while (fun c -> List.mem c tag_delims) 14 | *> (satisfy is_space_eol *> return () <|> end_of_input) 15 | *> return `Finish 16 | <|> (String.make 1 <$> not_one_of [ '#'; ','; '!'; '?'; '\''; '"'; ':' ] >>| fun c -> `Continue c) 17 | >>= fun r -> 18 | match r with 19 | | `Finish -> fail "hashtag_name_part finish" 20 | | `Continue c -> return c ) 21 | in 22 | fix (fun m -> 23 | List.cons <$> hashtag_name_part <*> m 24 | <|> (List.cons <$> hashtag_name_part <*> return [])) 25 | >>| String.concat "" 26 | -------------------------------------------------------------------------------- /lib/syntax/markdown_front_matter.ml: -------------------------------------------------------------------------------- 1 | (* https://jekyllrb.com/docs/front-matter/ *) 2 | (* 3 | --- 4 | layout: post 5 | title: Blogging Like a Hacker 6 | --- 7 | *) 8 | 9 | open Angstrom 10 | open Parsers 11 | open Type 12 | 13 | let kv_parse = 14 | let key_parser = take_while1 (fun c -> c <> ':' && non_eol c) in 15 | let sep_parser = char ':' <* spaces in 16 | let value_parser = take_till is_eol <|> (end_of_input >>| fun _ -> "") in 17 | let p = 18 | lift3 19 | (fun key _sep value -> Directive (key, value)) 20 | key_parser sep_parser value_parser 21 | in 22 | Helper.with_pos_meta p 23 | 24 | let parse = 25 | string "---" *> end_of_line 26 | *> end_string "---" (fun s -> 27 | (* multiple directives *) 28 | match 29 | parse_string ~consume:All 30 | (many1 (kv_parse <* (end_of_line <|> end_of_input))) 31 | s 32 | with 33 | | Ok result -> result 34 | | Error _e -> []) 35 | -------------------------------------------------------------------------------- /.github/workflows/format.yml: -------------------------------------------------------------------------------- 1 | name: Format 2 | 3 | on: 4 | pull_request: 5 | branches: [ master ] 6 | 7 | jobs: 8 | build: 9 | runs-on: ubuntu-latest 10 | steps: 11 | # Checks-out your repository under $GITHUB_WORKSPACE, so your job can access it 12 | - uses: actions/checkout@v2 13 | with: 14 | ref: ${{ github.head_ref }} 15 | 16 | - name: Set up OCaml 17 | uses: avsm/setup-ocaml@v1 18 | with: 19 | # Version of the OCaml compiler to initialise 20 | ocaml-version: 4.11.1 21 | 22 | - name: install dependencies 23 | run: opam install ocamlformat.0.16.0 dune 24 | 25 | - name: format 26 | run: | 27 | opam exec -- dune build @fmt --auto-promote || true 28 | 29 | - name: commit 30 | uses: stefanzweifel/git-auto-commit-action@v4.11.0 31 | with: 32 | commit_message: Apply formatting changes 33 | branch: ${{ github.head_ref }} 34 | -------------------------------------------------------------------------------- /lib/export/exporter.ml: -------------------------------------------------------------------------------- 1 | (* taken from mlorg *) 2 | module type Exporter = sig 3 | val name : string 4 | 5 | val default_filename : string -> string 6 | 7 | val export : 8 | refs:Reference.parsed_t option 9 | -> Conf.t 10 | -> Document.t 11 | -> out_channel 12 | -> unit 13 | end 14 | 15 | type exporter = (module Exporter) 16 | 17 | let find name = 18 | List.find (fun m -> 19 | let module M = (val m : Exporter) in 20 | M.name = name) 21 | 22 | module Exporters = struct 23 | include ExtList.Make (struct 24 | type t = exporter 25 | 26 | let base = 27 | [ (module Html.HtmlExporter : Exporter) 28 | ; (module Markdown.MarkdownExporter : Exporter) 29 | ; (module Opml.OPMLExporter : Exporter) 30 | ] 31 | end) 32 | 33 | let run exporter ~refs config doc output = 34 | let module M = (val exporter : Exporter) in 35 | M.export ~refs config doc output 36 | 37 | let find name = find name (get ()) 38 | 39 | let add = push 40 | end 41 | -------------------------------------------------------------------------------- /.github/workflows/ci.yml: -------------------------------------------------------------------------------- 1 | name: CI 2 | 3 | on: 4 | # Triggers the workflow on push or pull request events but only for the master branch 5 | push: 6 | branches: [ master ] 7 | pull_request: 8 | branches: [ master ] 9 | 10 | # Allows you to run this workflow manually from the Actions tab 11 | workflow_dispatch: 12 | 13 | jobs: 14 | build: 15 | runs-on: ubuntu-latest 16 | steps: 17 | # Checks-out your repository under $GITHUB_WORKSPACE, so your job can access it 18 | - uses: actions/checkout@v2 19 | 20 | - name: Set up OCaml 21 | uses: avsm/setup-ocaml@v1 22 | with: 23 | # Version of the OCaml compiler to initialise 24 | ocaml-version: 4.11.1 25 | 26 | - name: install dependencies 27 | run: opam install . --deps-only --with-doc --with-test 28 | 29 | - name: build 30 | run: | 31 | opam exec -- dune build @install @JS @main 32 | 33 | - name: runtest 34 | run: opam exec -- dune runtest 35 | 36 | -------------------------------------------------------------------------------- /js/package/bin/messenger.js: -------------------------------------------------------------------------------- 1 | function Messenger (writeMode, supress, mute) { 2 | 'use strict'; 3 | writeMode = writeMode || 'stderr'; 4 | supress = (!!supress || !!mute); 5 | mute = !!mute; 6 | this._print = (writeMode === 'stdout') ? console.log : console.error; 7 | 8 | this.errorExit = function (e) { 9 | if (!mute) { 10 | console.error('ERROR: ' + e.message); 11 | console.error('Run \'mldoc -h\' for help'); 12 | } 13 | process.exit(1); 14 | }; 15 | 16 | this.okExit = function () { 17 | if (!mute) { 18 | this._print('\n'); 19 | this._print('DONE!'); 20 | } 21 | process.exit(0); 22 | }; 23 | 24 | this.printMsg = function (msg) { 25 | if (supress || mute || !msg) { 26 | return; 27 | } 28 | this._print(msg); 29 | }; 30 | 31 | this.printError = function (msg) { 32 | if (mute) { 33 | return; 34 | } 35 | console.error(msg); 36 | }; 37 | 38 | } 39 | 40 | module.exports = Messenger; 41 | -------------------------------------------------------------------------------- /lib/syntax/property.ml: -------------------------------------------------------------------------------- 1 | open Angstrom 2 | open Prelude 3 | open Conf 4 | 5 | (* 6 | Property kinds: 7 | 1. [[a]], [[b]], [[c [[d]]]] 8 | 2. [[a]], #b, #c 9 | 3. "abc" 10 | 4. [[c]] blabla [[b]] 11 | *) 12 | 13 | (* steps: 14 | 1. check whether the property value is enclosed by quotes, if so, return empty 15 | 1. parsing all the links 16 | 2. if there's no links, check whether it's separated by `,` 17 | *) 18 | 19 | let property_references config s = 20 | let config = { config with inline_skip_macro = true } in 21 | let end_quoted = 22 | match last_char s with 23 | | Some '"' -> true 24 | | _ -> false in 25 | if s = "" || (s.[0] == '"' && end_quoted) then 26 | [] 27 | else 28 | match parse_string ~consume:All (Inline.parse config) s with 29 | | Ok result -> 30 | let result = List.map fst result in 31 | List.filter 32 | (fun e -> 33 | match e with 34 | | Inline.Tag _ -> true 35 | | Inline.Link _ -> true 36 | | Inline.Nested_link _ -> true 37 | | _ -> false) 38 | result 39 | | Error _ -> [] 40 | -------------------------------------------------------------------------------- /lib/syntax/email_address.ml: -------------------------------------------------------------------------------- 1 | open Angstrom 2 | open Parsers 3 | 4 | (* copied from https://github.com/dune-universe/dune-universe/blob/c7009f6f606b52b0c7a44841084009d9743f2246/packages/email_message.v0.13.0/email_address/src/email_address_parser_stable_v1.ml *) 5 | 6 | (* Ignore prefix for now. *) 7 | type t = 8 | { local_part : string 9 | ; domain : string 10 | } 11 | [@@deriving yojson] 12 | 13 | let string_contains = String.contains 14 | 15 | let whitespace_chars = " \r\n\t" 16 | 17 | let not_address_chars = "<>@," ^ whitespace_chars 18 | 19 | let not_domain_chars = not_address_chars ^ "'\"" 20 | 21 | let address_part = 22 | let local_part = 23 | take_while1 (fun chr -> not (string_contains not_address_chars chr)) 24 | "local_part" 25 | in 26 | let domain = 27 | char '@' 28 | *> take_while1 (fun chr -> not (string_contains not_domain_chars chr)) 29 | "domain" 30 | in 31 | lift2 (fun local_part domain -> { domain; local_part }) local_part domain 32 | 33 | let email = 34 | optional (char '<') *> address_part <* optional (char '>') "email" 35 | 36 | let to_string { local_part; domain } = local_part ^ "@" ^ domain 37 | -------------------------------------------------------------------------------- /js/package/bin/cli.js: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env node 2 | 3 | 'use strict'; 4 | 5 | var yargs = require('yargs'); 6 | 7 | yargs 8 | .version() 9 | .alias('v', 'version') 10 | .option('h', { 11 | alias: 'help', 12 | description: 'Show help' 13 | }) 14 | .option('q', { 15 | alias: 'quiet', 16 | description: 'Quiet mode. Only print errors', 17 | type: 'boolean', 18 | default: false 19 | }) 20 | .option('m', { 21 | alias: 'mute', 22 | description: 'Mute mode. Does not print anything', 23 | type: 'boolean', 24 | default: false 25 | }) 26 | .usage('Usage: mldoc [options]') 27 | .demand(1, 'You must provide a valid command') 28 | .command('convert', 'Converts files') 29 | .example('mldoc convert -i foo.org -o bar.html', 'Converts \'foo.org\' to \'bar.html\'') 30 | .wrap(yargs.terminalWidth()); 31 | 32 | var argv = yargs.argv, 33 | command = argv._[0]; 34 | 35 | if (command === 'convert') { 36 | require('./convert.cmd.js').run(); 37 | } else { 38 | yargs.showHelp(); 39 | } 40 | 41 | if (argv.help) { 42 | yargs.showHelp(); 43 | } 44 | process.exit(0); 45 | -------------------------------------------------------------------------------- /test/dune: -------------------------------------------------------------------------------- 1 | (executables 2 | (names test_markdown) 3 | (modules test_markdown) 4 | (libraries alcotest mldoc)) 5 | 6 | (executables 7 | (names test_outline_markdown) 8 | (modules test_outline_markdown) 9 | (libraries alcotest mldoc)) 10 | 11 | (executables 12 | (names test_org) 13 | (modules test_org) 14 | (libraries alcotest mldoc)) 15 | 16 | (executables 17 | (names gen_md_files) 18 | (modules gen_md_files) 19 | (libraries qcheck mldoc)) 20 | 21 | (executables 22 | (names test_zip) 23 | (modules test_zip) 24 | (libraries alcotest qcheck qcheck-alcotest mldoc)) 25 | 26 | (executables 27 | (names test_export_markdown) 28 | (modules test_export_markdown) 29 | (libraries alcotest mldoc)) 30 | 31 | (executables 32 | (names test_export_opml) 33 | (modules test_export_opml) 34 | (libraries alcotest mldoc)) 35 | 36 | (rule 37 | (alias runtest) 38 | (deps 39 | (:md test_markdown.exe) 40 | (:md-outline test_outline_markdown.exe) 41 | (:org test_org.exe) 42 | (:zip test_zip.exe) 43 | (:export-md test_export_markdown.exe) 44 | (:export-opml test_export_opml.exe)) 45 | (action 46 | (progn 47 | (run %{md}) 48 | (run %{md-outline}) 49 | (run %{org}) 50 | (run %{zip}) 51 | (run %{export-md}) 52 | (run %{export-opml})))) 53 | -------------------------------------------------------------------------------- /mldoc.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | synopsis: 3 | "Another Org-mode and Markdown parser implemented using OCaml and Angstrom" 4 | description: 5 | "Another Org-mode and Markdown parser implemented using OCaml and Angstrom." 6 | maintainer: ["logseq team"] 7 | authors: ["tiensonqin " "RCmerci "] 8 | homepage: "https://github.com/logseq/mldoc" 9 | bug-reports: "https://github.com/logseq/mldoc/issues" 10 | depends: [ 11 | "dune" {>= "3.5"} 12 | "ocaml" {>= "4.14.0"} 13 | "angstrom" {= "dev"} 14 | "cmdliner" {>= "1.1.0"} 15 | "core" 16 | "core_bench" 17 | "core_unix" 18 | "js_of_ocaml" {>= "5.2.0"} 19 | "js_of_ocaml-ppx" 20 | "ppx_deriving_yojson" 21 | "uri" 22 | "yojson" 23 | "lwt" 24 | "xmlm" {= "dev"} 25 | "odoc" {with-doc} 26 | "alcotest" {with-test} 27 | "qcheck" {with-test} 28 | "qcheck-alcotest" {with-test} 29 | ] 30 | build: [ 31 | ["dune" "subst"] {dev} 32 | [ 33 | "dune" 34 | "build" 35 | "-p" 36 | name 37 | "-j" 38 | jobs 39 | "@install" 40 | "@runtest" {with-test} 41 | "@doc" {with-doc} 42 | ] 43 | ] 44 | pin-depends: [ 45 | [ "angstrom.dev" "git+https://github.com/logseq/angstrom#fork" ] 46 | [ "xmlm.dev" "git+https://github.com/logseq/xmlm#fork" ] 47 | ] 48 | -------------------------------------------------------------------------------- /lib/syntax/markdown_code_block.ml: -------------------------------------------------------------------------------- 1 | open Angstrom 2 | open Parsers 3 | open Type 4 | open Prelude 5 | 6 | (* https://www.markdownguide.org/basic-syntax/#code-blocks *) 7 | (* 8 | Code Blocks 9 | To create code blocks, indent every line of the block by at least four spaces or one tab. 10 | 11 | 12 | 13 | 14 | 15 | *) 16 | let single_line = 17 | let spaces = 18 | tabs_or_ws >>= fun s -> 19 | let l = explode s in 20 | let tabs_count = List.length (List.filter (fun c -> Char.equal c '\t') l) in 21 | let indent = String.length s - tabs_count + (tabs_count * 4) in 22 | if indent >= 4 then 23 | return indent 24 | else 25 | fail "single_line not enough spaces" 26 | in 27 | lift2 (fun indent content -> (indent, content)) spaces line 28 | 29 | let parse = 30 | many1 31 | ( single_line <* (end_of_line <|> end_of_input) <* optional eols 32 | >>| fun (indent, s) -> (indent, s ^ "\n") ) 33 | >>= fun lines -> 34 | let start_indent, _content = List.hd lines in 35 | let lines = 36 | List.map 37 | (fun (i, c) -> 38 | if i > start_indent then 39 | String.make (i - start_indent) ' ' ^ c 40 | else 41 | c) 42 | lines 43 | in 44 | return @@ Example lines 45 | -------------------------------------------------------------------------------- /lib/syntax/tree_type.mli: -------------------------------------------------------------------------------- 1 | type 'a t = 'a Zip.t 2 | 3 | type value = Type.t_with_pos_meta Zip.l 4 | 5 | type value_with_content = Type.t_with_content Zip.l 6 | 7 | val of_blocks : Type.blocks -> Type.t_with_pos_meta t 8 | 9 | val of_blocks_without_pos : Type.t list -> Type.t_with_pos_meta t 10 | 11 | val of_value : value -> Type.t_with_pos_meta t 12 | 13 | val of_value_with_content : value_with_content -> Type.t_with_content t 14 | 15 | val to_value : Type.t_with_pos_meta t -> value 16 | 17 | val to_blocks : Type.t_with_pos_meta t -> Type.blocks 18 | 19 | val to_blocks_without_pos : Type.t_with_pos_meta t -> Type.t list 20 | 21 | val to_blocks_with_content : Type.t_with_content t -> Type.blocks_with_content 22 | 23 | (* remove all [Type.Property_Drawer] *) 24 | val remove_properties : Type.t t -> Type.t t 25 | 26 | (** replace page-embed, block-embed, block-references with its content *) 27 | val replace_embed_and_refs : 28 | Type.t_with_pos_meta t -> refs:Reference.parsed_t -> Type.t_with_pos_meta t 29 | 30 | (** replace [Type.Heading] with [Type.Paragraph] *) 31 | val replace_heading_with_paragraph : 32 | Type.t_with_pos_meta t -> Type.t_with_pos_meta t 33 | 34 | (** [flatten t] returns one-level tree *) 35 | val flatten : Type.t_with_pos_meta t -> Type.t_with_pos_meta t 36 | 37 | (** [remove_meta_chars] remove meta-chars. 38 | - [[text]] -> text 39 | - **text** -> text 40 | - __text__ -> text 41 | - ... *) 42 | val remove_meta_chars : 43 | Conf.meta_chars list -> Type.t_with_pos_meta t -> Type.t_with_pos_meta t 44 | -------------------------------------------------------------------------------- /lib/syntax/outline_inline.ml: -------------------------------------------------------------------------------- 1 | open! Prelude 2 | open Angstrom 3 | open Parsers 4 | open Conf 5 | 6 | let empty_plain _ = return (Inline.Plain "") 7 | 8 | let skip_char = any_char >>= empty_plain 9 | 10 | let in_plain_delims config c = 11 | match config.format with 12 | | Markdown -> c = '[' || c = '`' || is_whitespace c 13 | | Org -> c = '[' || c = '=' || c = '~' || is_whitespace c 14 | 15 | let skip_plain config = take_till (in_plain_delims config) >>= empty_plain 16 | 17 | let inline_code config = Inline.code config >>= empty_plain 18 | 19 | let inline_choices config : Inline.t_with_pos Angstrom.t = 20 | let skip_plain = any_char *> skip_plain config in 21 | let p = 22 | peek_char_fail >>= function 23 | | '#' -> Inline.hash_tag config 24 | | '[' -> Inline.nested_link_or_link config 25 | | '(' -> Inline.block_reference config 26 | | 'S' 27 | | 'C' 28 | | 'D' 29 | | 's' 30 | | 'c' 31 | | 'd' -> 32 | Inline.timestamp 33 | | c -> ( 34 | if is_whitespace c then 35 | skip_char 36 | else 37 | match config.format with 38 | | Markdown -> 39 | if c = '`' then 40 | inline_code config 41 | else 42 | fail "inline choice" 43 | | Org -> 44 | if c = '=' || c = '~' then 45 | inline_code config 46 | else 47 | fail "inline choice") 48 | in 49 | let p' = p <|> skip_plain <|> skip_char in 50 | (fun t -> (t, None)) <$> p' 51 | 52 | let parse config = 53 | many1 (inline_choices config) 54 | >>| (fun l -> 55 | let l = remove (fun (t, _) -> t = Inline.Plain "") l in 56 | Inline.concat_plains l) 57 | "inline" 58 | -------------------------------------------------------------------------------- /lib/syntax/extended/hiccup.ml: -------------------------------------------------------------------------------- 1 | open Prelude 2 | open Angstrom 3 | open Parsers 4 | 5 | let match_tag tag open_tag close_tag = 6 | let level_ref = ref 1 in 7 | let s_ref = ref "" in 8 | (* To determine whether the `]` is inside a string. *) 9 | let double_quotes = ref 0 in 10 | fix (fun parse -> 11 | end_string_2 close_tag ~ci:true (fun s -> 12 | (* FIXME: should exclude `[:` which insides any string *) 13 | let level = count_substring s open_tag in 14 | let s' = Str.global_replace (Str.regexp_string "\\\"") "" s in 15 | let quotes = count_substring s' "\"" in 16 | let quotes' = !double_quotes + quotes in 17 | let _ = double_quotes := quotes' in 18 | let is_even i = i mod 2 = 0 in 19 | let decrement = 20 | if is_even quotes' then 21 | 1 22 | else 23 | 0 24 | in 25 | let _ = level_ref := !level_ref + level - decrement in 26 | let _ = s_ref := !s_ref ^ s ^ close_tag in 27 | (* let _ = Printf.printf "Hiccup tag level: %d, tag: %s, content: %s, all content so far: %s, level ref: %d, decrement level: %d\n" level tag s !s_ref !level_ref decrement in *) 28 | if !level_ref <= 0 then 29 | return (open_tag ^ tag ^ !s_ref) 30 | else 31 | parse)) 32 | 33 | let element = 34 | string "[:" 35 | *> take_till1 (fun c -> is_space c || c == ']' || c == '.' || c == '#') 36 | >>= fun tag -> 37 | (if Raw_html.known_tag tag then 38 | return tag 39 | else 40 | fail ("html invalid tag: " ^ tag)) 41 | >>= fun tag -> match_tag tag "[:" "]" 42 | 43 | let parse = 44 | peek_string 2 >>= fun s -> 45 | match s with 46 | | "[:" -> element 47 | | _ -> fail "hiccup" 48 | -------------------------------------------------------------------------------- /bench/bench.ml: -------------------------------------------------------------------------------- 1 | open Mldoc.Parser 2 | open Mldoc.Conf 3 | open Core 4 | open Core_bench 5 | open Angstrom 6 | 7 | let doc_org = load_file "./examples/doc.org" 8 | let syntax_md = load_file "./examples/syntax.md" 9 | 10 | let config = 11 | { toc = true 12 | ; parse_outline_only = false 13 | ; heading_number = true 14 | ; keep_line_break = false 15 | ; format = Org 16 | ; heading_to_list = false 17 | ; exporting_keep_properties = false 18 | ; inline_type_with_pos = false 19 | ; inline_skip_macro = false 20 | ; export_md_indent_style = Dashes 21 | ; export_md_remove_options = [] 22 | ; hiccup_in_block = true 23 | ; enable_drawers = true 24 | ; parse_marker = true 25 | ; parse_priority = true 26 | } 27 | 28 | let outline_config = { config with parse_outline_only = true } 29 | 30 | let main () = 31 | Command_unix.run 32 | (Bench.make_command 33 | [ Bench.Test.create ~name:"Inline parse (doc)" (fun () -> 34 | let p = Inline.parse config in 35 | ignore (parse_string ~consume:All p syntax_md)) 36 | ; Bench.Test.create ~name:"Inline parse outline (doc)" (fun () -> 37 | let p = Outline_inline.parse outline_config in 38 | ignore (parse_string ~consume:All p syntax_md)) 39 | ; Bench.Test.create ~name:"Mldoc Org mode parser" (fun () -> 40 | ignore (parse config doc_org)) 41 | ; Bench.Test.create ~name:"Mldoc Org mode parser (outline only)" 42 | (fun () -> ignore (parse outline_config doc_org)) 43 | ; Bench.Test.create ~name:"Mldoc Markdown parser" (fun () -> 44 | ignore (parse config syntax_md)) 45 | ; Bench.Test.create ~name:"Mldoc Markdown parser (outline only)" 46 | (fun () -> ignore (parse outline_config syntax_md)) 47 | ]) 48 | 49 | let () = main () 50 | -------------------------------------------------------------------------------- /test/test_zip.ml: -------------------------------------------------------------------------------- 1 | open Zip 2 | open QCheck 3 | 4 | let g = 5 | Gen.( 6 | of_l 7 | <$> sized 8 | @@ fix (fun self n -> 9 | match n with 10 | | 0 -> map leaf nat 11 | | n -> 12 | frequency 13 | [ ( 5 14 | , branch 15 | <$> ( 0 -- (n / 2) >>= fun n' -> 16 | list_size (0 -- 10) (self n') ) ) 17 | ; (1, map leaf nat) 18 | ])) 19 | 20 | let arbitrary = make g 21 | 22 | (* sum zipper using next *) 23 | let sum_by_next z = 24 | let rec aux z r = 25 | match (node z, is_end z) with 26 | | Leaf n, false -> aux (next z) (r + n) 27 | | Leaf _, true -> r 28 | | Branch _, false -> aux (next z) r 29 | | Branch _, true -> r 30 | in 31 | aux z 0 32 | 33 | (* sum zipper using prev *) 34 | let sum_by_prev z = 35 | let rec to_end z = 36 | let z' = next z in 37 | if is_end z' then 38 | z 39 | else 40 | to_end z' 41 | in 42 | let rec aux z r = 43 | let r' = 44 | match node z with 45 | | Leaf n -> r + n 46 | | Branch _ -> r 47 | in 48 | match prev z with 49 | | Some z' -> aux z' r' 50 | | None -> r' 51 | in 52 | aux (to_end z) 0 53 | 54 | let sum z = 55 | let value = root z in 56 | let rec aux value = 57 | match value with 58 | | Leaf n -> n 59 | | Branch l -> List.fold_left (fun r e -> r + aux e) 0 l 60 | in 61 | aux value 62 | 63 | let next_prev_sum_test = 64 | Test.make ~name:"next_prev_sum_generative_test" ~count:1000 arbitrary 65 | (fun z -> 66 | let sum' = sum z in 67 | sum_by_next z = sum' && sum_by_prev z = sum') 68 | 69 | let () = 70 | Alcotest.run "zip" 71 | @@ [ ("next & prev", [ QCheck_alcotest.to_alcotest next_prev_sum_test ]) ] 72 | -------------------------------------------------------------------------------- /lib/syntax/markdown_definition.ml: -------------------------------------------------------------------------------- 1 | open Angstrom 2 | open Parsers 3 | open Type 4 | open Prelude 5 | 6 | (* First Term 7 | * : This is the definition of the first term. 8 | * 9 | * Second Term 10 | * : This is one definition of the second term. 11 | * : This is another definition of the second term. *) 12 | 13 | let term_definition = 14 | let non_colon_or_eol = function 15 | | ':' 16 | | '\r' 17 | | '\n' 18 | | '#' -> 19 | false 20 | | _ -> true 21 | in 22 | let l = 23 | spaces *> satisfy non_colon_or_eol >>= fun c -> 24 | line <* (end_of_input <|> end_of_line) >>| fun s -> String.make 1 c ^ s 25 | in 26 | many1 l 27 | 28 | let definition_content_item = 29 | spaces *> char ':' *> ws *> term_definition >>| function 30 | | lines -> String.concat "\n" lines 31 | 32 | (* copy from verbatim *) 33 | let definition_content = many1 definition_content_item 34 | 35 | let definition_parse config = 36 | let name = spaces *> line <* eol in 37 | name >>= fun name -> 38 | definition_content >>= fun lines -> 39 | let name = 40 | match parse_string ~consume:All (Inline.parse config) name with 41 | | Ok inlines -> inlines 42 | | Error _e -> Type_op.inline_list_with_none_pos [ Inline.Plain name ] 43 | in 44 | let content = 45 | List.map 46 | (fun line -> 47 | match 48 | parse_string ~consume:All (Inline.parse config) (String.trim line) 49 | with 50 | | Ok content -> Paragraph content 51 | | Error _e -> 52 | Paragraph (Type_op.inline_list_with_none_pos [ Inline.Plain line ])) 53 | lines 54 | in 55 | let list = 56 | { content 57 | ; items = [] 58 | ; number = None 59 | ; name 60 | ; checkbox = None 61 | ; indent = 0 62 | ; (* TODO: *) 63 | ordered = false 64 | } 65 | in 66 | return list 67 | 68 | let parse config = many1 (definition_parse config <* optional eols) 69 | -------------------------------------------------------------------------------- /lib/export/conf.ml: -------------------------------------------------------------------------------- 1 | type format = 2 | | Org 3 | | Markdown 4 | 5 | let format_to_yojson format = 6 | match format with 7 | | Org -> `String "Org" 8 | | Markdown -> `String "Markdown" 9 | 10 | let format_of_yojson json = 11 | match json with 12 | | `String "Org" -> Ok Org 13 | | `String "Markdown" -> Ok Markdown 14 | | _ -> Error "invalid format" 15 | 16 | type indent_style = 17 | | Dashes 18 | | Spaces 19 | | NoIndent 20 | 21 | let indent_style_to_yojson = function 22 | | Dashes -> `String "dashes" 23 | | Spaces -> `String "spaces" 24 | | NoIndent -> `String "no-indent" 25 | 26 | let indent_style_of_yojson = function 27 | | `String s -> ( 28 | match String.lowercase_ascii s with 29 | | "dashes" -> Ok Dashes 30 | | "spaces" -> Ok Spaces 31 | | "no-indent" -> Ok NoIndent 32 | | _ -> Ok Dashes) 33 | | _ -> Ok Dashes 34 | 35 | type meta_chars = 36 | | Page_ref (* [[text]] *) 37 | | Emphasis (* **text**, __text__, ... *) 38 | [@@deriving yojson] 39 | 40 | type t = 41 | { (* html: bool; *) 42 | (* hiccup: bool; *) 43 | toc : bool [@default false] 44 | ; parse_outline_only : bool [@default false] 45 | ; heading_number : bool [@default false] 46 | ; keep_line_break : bool (* FIXME: is this option deprecated? *) 47 | ; format : format 48 | ; heading_to_list : bool [@default false] (* export heading as list *) 49 | ; exporting_keep_properties : bool 50 | [@default false] (* keep properties when exporting *) 51 | ; inline_type_with_pos : bool [@default false] 52 | ; inline_skip_macro: bool [@default false] 53 | ; export_md_indent_style : indent_style [@default Dashes] 54 | ; export_md_remove_options : meta_chars list [@default []] 55 | ; hiccup_in_block : bool [@default true] 56 | ; enable_drawers : bool [@default true] 57 | ; parse_marker: bool [@default true] 58 | ; parse_priority: bool [@default true] 59 | } 60 | [@@deriving yojson] 61 | 62 | let is_markdown t = t.format = Markdown 63 | 64 | let is_org t = t.format = Org 65 | -------------------------------------------------------------------------------- /lib/syntax/latex_env.ml: -------------------------------------------------------------------------------- 1 | (* 2 | You can insert LaTeX blocks by: 3 | 4 | : $$Your big formulas$$ 5 | 6 | eg, 7 | 8 | $$ \sum_{k=1}^{+\infty} \frac 1 {k^2} = \frac{\pi^2} 6$$ 9 | 10 | or you can insert plain LaTeX environment 11 | 12 | : \begin{env}options 13 | : Contents 14 | : \end{env} 15 | 16 | \begin{equation} 17 | x=\sqrt{b} 18 | \end{equation} 19 | 20 | If $a^2=b$ and \( b=2 \), then the solution must be 21 | either $$ a=+\sqrt{2} $$ or \[ a=-\sqrt{2} \]. 22 | 23 | Whenever possible, you should use [[Custom%20blocks][custom blocks]], that get exported to 24 | latex environment in LaTeX-based outputs, and are more portable (in 25 | HTML, they are exported as div that you can style or script). 26 | 27 | (* TODO: *) 28 | \def\arraystretch{1.5} 29 | \begin{array}{c:c:c} 30 | a & b & c \\ \hline 31 | d & e & f \\ 32 | \hdashline 33 | g & h & i 34 | \end{array} 35 | 36 | x = \begin{cases} 37 | a &\text{if } b \\ 38 | c &\text{if } d 39 | \end{cases} 40 | *) 41 | open Angstrom 42 | open Parsers 43 | open Type 44 | open! Prelude 45 | 46 | let env_name_options_parser = 47 | string_ci "\\begin{" *> take_while1 (fun c -> c <> '}') 48 | <* char '}' 49 | >>| (fun name -> (name, None)) 50 | <* spaces_or_eols 51 | 52 | let parse _config = 53 | spaces *> env_name_options_parser >>= fun (name, options) -> 54 | let ending = "\\end{" ^ name ^ "}" in 55 | let ending_len = String.length ending in 56 | fix (fun m -> 57 | peek_char >>= fun c -> 58 | match c with 59 | | None -> return [] 60 | | Some '\\' -> 61 | (* check if equals to '\end{...}' *) 62 | available >>= fun len -> 63 | if len < ending_len then 64 | fail "ending" 65 | else 66 | peek_string ending_len >>= fun s -> 67 | if String.lowercase_ascii ending = String.lowercase_ascii s then 68 | advance ending_len >>= fun _ -> return [] 69 | else 70 | List.cons <$> (any_char >>| String.make 1) <*> m 71 | | Some _ -> List.cons <$> take_while1 (fun c -> c <> '\\') <*> m) 72 | >>| String.concat "" 73 | >>| fun content -> 74 | Latex_Environment (String.lowercase_ascii name, options, content) 75 | -------------------------------------------------------------------------------- /lib/syntax/paragraph.ml: -------------------------------------------------------------------------------- 1 | open! Prelude 2 | open Angstrom 3 | open Parsers 4 | open Type 5 | open Pos 6 | open Conf 7 | 8 | (* inline and footnotes *) 9 | 10 | let sep = take_while1 is_eol >>| fun s -> Paragraph_Sep (String.length s) 11 | 12 | let trim_last_space s = 13 | let n = String.length s in 14 | if n > 0 && s.[n - 1] = ' ' then 15 | String.sub s 0 (n - 1) 16 | else 17 | s 18 | 19 | let parse = line >>| fun l -> Paragraph_line l 20 | 21 | let parse_lines config lines pos1 pos2 = 22 | let lines = List.rev lines in 23 | let content = String.concat "" lines in 24 | let paragraph = 25 | let inline_parse = 26 | if config.parse_outline_only then 27 | Outline_inline.parse 28 | else 29 | Inline.parse 30 | in 31 | match parse_string ~consume:All (inline_parse config) content with 32 | | Ok result -> Paragraph result 33 | | Error _ -> 34 | Paragraph (Type_op.inline_list_with_none_pos [ Inline.Plain content ]) 35 | in 36 | (paragraph, { start_pos = pos1; end_pos = pos2 }) 37 | 38 | let concat_paragraph_lines config l = 39 | let acc, lines, pos1, pos2 = 40 | List.fold_left 41 | (fun (acc, lines, pos1, pos2) item -> 42 | match item with 43 | | Paragraph_line line, { start_pos; end_pos } -> 44 | let start_pos = 45 | if Option.is_none pos1 then 46 | Some start_pos 47 | else 48 | pos1 49 | in 50 | (acc, line :: lines, start_pos, end_pos) 51 | | Paragraph_Sep n, { start_pos; end_pos } -> 52 | let line = repeat n "\n" in 53 | let line = String.concat "" line in 54 | let start_pos = 55 | if Option.is_none pos1 then 56 | Some start_pos 57 | else 58 | pos1 59 | in 60 | (acc, line :: lines, start_pos, end_pos) 61 | | _other, _pos_meta -> 62 | if List.length lines > 0 then 63 | let pos1 = Option.default 0 pos1 in 64 | let paragraph_with_meta = parse_lines config lines pos1 pos2 in 65 | let acc = item :: paragraph_with_meta :: acc in 66 | (acc, [], None, 0) 67 | else 68 | (item :: acc, [], None, 0)) 69 | ([], [], None, 0) l 70 | in 71 | let acc = 72 | if List.length lines > 0 then 73 | let pos1 = Option.default 0 pos1 in 74 | let paragraph_with_meta = parse_lines config lines pos1 pos2 in 75 | paragraph_with_meta :: acc 76 | else 77 | acc 78 | in 79 | List.rev acc 80 | -------------------------------------------------------------------------------- /lib/mldoc_parser.ml: -------------------------------------------------------------------------------- 1 | open Angstrom 2 | open! Prelude 3 | 4 | let list_content_parsers config = 5 | let p = 6 | choice 7 | [ Table.parse config 8 | ; Type_parser.Block.parse config 9 | ; Latex_env.parse config 10 | ; Hr.parse config 11 | ; Type_parser.Block.results 12 | ; Comment.parse config 13 | ; Paragraph.parse 14 | ; Paragraph.sep 15 | ] 16 | in 17 | let p = Helper.with_pos_meta p in 18 | many1 p 19 | 20 | (* Orders care *) 21 | let parsers config = 22 | [ Paragraph.sep 23 | ; Directive.parse 24 | ; Drawer.parse config 25 | ; Type_parser.Heading.parse config 26 | ; Table.parse config 27 | ; Latex_env.parse config 28 | ; Type_parser.Block.parse config 29 | ; Footnote.parse config 30 | ; Type_parser.Lists.parse config (list_content_parsers config) 31 | ; Hr.parse config 32 | ; Type_parser.Block.results 33 | ; Comment.parse config 34 | ; Paragraph.parse 35 | ] 36 | 37 | (* TODO: ignore tags, page/block refs from Src, Example, etc. *) 38 | let outline_parsers config = 39 | [ Paragraph.sep 40 | ; Type_parser.Heading.parse config 41 | ; Drawer.parse config 42 | ; Directive.parse 43 | ; Paragraph.parse 44 | ] 45 | 46 | let md_front_matter_parse parse = 47 | Markdown_front_matter.parse >>= fun fm_result -> 48 | parse >>= fun result -> return (List.append fm_result result) 49 | 50 | let build_parsers parsers config = 51 | let parsers = parsers config in 52 | let choice = choice parsers in 53 | let p = Helper.with_pos_meta choice in 54 | let parse = many p in 55 | md_front_matter_parse parse <|> parse 56 | 57 | let parse config input = 58 | let outline_only = Conf.(config.parse_outline_only) in 59 | let parsers = build_parsers parsers config in 60 | match parse_string ~consume:All parsers input with 61 | | Ok result -> 62 | let ast = Paragraph.concat_paragraph_lines config result in 63 | let ast = 64 | if outline_only then 65 | Prelude.remove 66 | (fun (t, _) -> 67 | match t with 68 | | Type.Results 69 | | Type.Example _ 70 | | Type.Src _ 71 | | Type.Latex_Environment _ 72 | | Type.Latex_Fragment _ 73 | | Type.Displayed_Math _ 74 | | Type.Horizontal_Rule 75 | | Type.Raw_Html _ 76 | | Type.Hiccup _ -> 77 | true 78 | | _ -> false) 79 | ast 80 | else 81 | ast 82 | in 83 | if Conf.is_markdown config then 84 | List.map (fun (t, pos) -> (Type_op.md_unescaped t, pos)) ast 85 | else 86 | ast 87 | | Error err -> failwith err 88 | 89 | let load_file f = 90 | let ic = open_in f in 91 | let n = in_channel_length ic in 92 | let s = Bytes.create n in 93 | really_input ic s 0 n; 94 | close_in ic; 95 | Bytes.to_string s 96 | -------------------------------------------------------------------------------- /test/test_export_opml.ml: -------------------------------------------------------------------------------- 1 | let default_config : Conf.t = 2 | { toc = true 3 | ; parse_outline_only = false 4 | ; heading_number = true 5 | ; keep_line_break = false 6 | ; format = Conf.Markdown 7 | ; heading_to_list = false 8 | ; exporting_keep_properties = false 9 | ; inline_type_with_pos = false 10 | ; inline_skip_macro = false 11 | ; export_md_indent_style = Conf.Dashes 12 | ; export_md_remove_options = [] 13 | ; hiccup_in_block = true 14 | ; enable_drawers = true 15 | ; parse_marker = true 16 | ; parse_priority = true 17 | } 18 | 19 | let check_aux ?(config = default_config) source expect = 20 | let tl = Mldoc_parser.parse config source in 21 | let buf = Buffer.create 100 in 22 | let output_buf = Xmlm.make_output ~indent:(Some 2) (`Buffer buf) in 23 | let _ = Opml.blocks Reference.empty_parsed_t tl "title" output_buf in 24 | fun _ -> 25 | Alcotest.check Alcotest.string "check exported string" expect 26 | (Buffer.contents buf) 27 | 28 | let testcases = 29 | List.map (fun (case, level, f) -> Alcotest.test_case case level f) 30 | 31 | let testcase_list = 32 | [ ( "export opml" 33 | , testcases 34 | [ ( "normal" 35 | , `Quick 36 | , check_aux "- line1\n - line2\n line3\n - line4" 37 | "\n\ 38 | \n\ 39 | \ \n\ 40 | \ \n\ 41 | \ title\n\ 42 | \ \n\ 43 | \ \n\ 44 | \ \n\ 45 | \ \n\ 46 | \ \n\ 47 | \ \n\ 48 | \ \n\ 49 | \ \n\ 50 | \ \n\ 51 | " ) 52 | ; ( "normal (1)" 53 | , `Quick 54 | , check_aux 55 | "- ## line1\n\ 56 | \ - ## TODO line2\n\ 57 | \ line3\n\ 58 | \ - ## LATER [#A] line4" 59 | "\n\ 60 | \n\ 61 | \ \n\ 62 | \ \n\ 63 | \ title\n\ 64 | \ \n\ 65 | \ \n\ 66 | \ \n\ 67 | \ \n\ 68 | \ \n\ 69 | \ \n\ 70 | \ \n\ 71 | \ \n\ 72 | \ \n\ 73 | " ) 74 | ] ) 75 | ] 76 | 77 | let () = Alcotest.run "export-opml" testcase_list 78 | -------------------------------------------------------------------------------- /readme.org: -------------------------------------------------------------------------------- 1 | * Mldoc 2 | Another Org-mode and Markdown parser implemented using OCaml and [[https://github.com/inhabitedtype/angstrom][Angstrom]]. 3 | It's based on [[http://iso.mor.phis.me/projects/mlorg/][mlorg]] which is a high quality Org-mode parser written by [[https://github.com/asmanur?tab=repositories][Simon Castellan]]. 4 | 5 | ** Who's using Mldoc? 6 | - [[https://logseq.com][Logseq]], a local-first notes app (In development) 7 | 8 | ** Build 9 | #+begin_src sh 10 | # compile 11 | make 12 | 13 | # run test 14 | make test 15 | #+end_src 16 | 17 | ** Run utop 18 | #+begin_src sh 19 | cd lib 20 | dune utop 21 | #+end_src 22 | 23 | ** Usage 24 | *** For Javascript users 25 | #+BEGIN_SRC sh 26 | # install mldoc 27 | npm install -g mldoc 28 | 29 | # convert org mode file to html 30 | mldoc convert -i ./test.org -o ./test.html 31 | 32 | # convert markdown mode file to html 33 | mldoc convert -i ./test.markdown -o ./test.html 34 | #+END_SRC 35 | 36 | *** For OCaml users 37 | #+BEGIN_SRC sh 38 | # compile 39 | make 40 | 41 | # convert org file to html 42 | _build/default/bin/main.exe ./test.org -o ./test.html 43 | #+END_SRC 44 | 45 | *** Invoke utop in Emacs 46 | #+BEGIN_SRC sh 47 | opam config exec -- dune utop lib -- -emacs 48 | #+END_SRC 49 | 50 | ** Parsing todos [12/12] 51 | *** DONE Heading [7/7] 52 | 1. [X] level 53 | 2. [X] marker 54 | 3. [X] priority 55 | 4. [X] title 56 | 5. [X] tags 57 | 6. [X] stats 58 | 7. [X] footnote 59 | 60 | *** DONE Markup (Inline) [14/14] 61 | 1. [X] Latex fragment 62 | 2. [X] timestamp 63 | 3. [X] entity 64 | 4. [X] macro 65 | 5. [X] statistics cookie 66 | 6. [X] footnote reference 67 | 7. [X] link 68 | 8. [X] direct link 69 | 9. [X] target 70 | 10. [X] verbatim 71 | 11. [X] code 72 | 12. [X] nested emphasis [4/4] 73 | 1. [X] bold 74 | 2. [X] underline 75 | 3. [X] italic 76 | 4. [X] strike_through 77 | 13. [X] subscript 78 | 14. [X] superscript 79 | 80 | *** DONE Table [2/2] 81 | 1. [X] preliminary support 82 | 2. [X] column groups 83 | 84 | *** DONE List [3/3] 85 | 1. [X] Unordered list 86 | 2. [X] Ordered list 87 | 3. [X] Definition list 88 | 89 | *** DONE Directive 90 | 91 | *** DONE Block [5/5] 92 | 1. [X] src 93 | 2. [X] quote 94 | 3. [X] example 95 | 4. [X] custom 96 | 5. [X] block nested in block 97 | 98 | *** DONE Comment 99 | 100 | *** DONE Drawer 101 | Not exported. 102 | 103 | *** DONE Horizontal 104 | 105 | *** DONE Latex environment 106 | 107 | *** DONE Quoting 108 | *** DONE TOC 109 | 110 | ** DONE Export [2/2] 111 | 1. [X] json 112 | 2. [X] html 113 | -------------------------------------------------------------------------------- /lib/syntax/footnote.ml: -------------------------------------------------------------------------------- 1 | open! Prelude 2 | open Angstrom 3 | open Parsers 4 | open Type 5 | open Conf 6 | 7 | (* FIXME: markdown footnote not working well with indent *) 8 | 9 | (* 10 | [fn:myfootnote] Extensively used in large documents. 11 | 12 | [fn:2] Lorem ipsum dolor sit amet, consectetur adipisicing elit, sed do 13 | eiusmod tempor incididunt ut labore et dolore magna aliqua. Ut enim ad minim 14 | veniam, quis nostrud exercitation ullamco laboris nisi ut aliquip ex ea 15 | commodo consequat. Duis aute irure dolor in reprehenderit in voluptate velit 16 | esse cillum dolore eu fugiat nulla pariatur. Excepteur sint occaecat cupidatat 17 | non proident, sunt in culpa qui officia deserunt mollit anim id est laborum. 18 | 19 | great I like it very much 20 | *) 21 | 22 | (* https://www.gnu.org/software/emacs/manual/html_node/org/Footnotes.html *) 23 | (* Org mode extends the number-based syntax to named footnotes and optional inline definition. Here are the valid references: 24 | * 1. [fn:name] 25 | * A named footnote reference, where name is a unique label word, or, for simplicity of automatic creation, a number. 26 | * 2. [fn::This is the inline definition of this footnote] 27 | * A LaTeX-like anonymous footnote where the definition is given directly at the reference point. 28 | * 3. [fn:name:a definition] 29 | * An inline definition of a footnote, which also specifies a name for the note. Since Org allows multiple references to the same note, you can then use [fn:name] to create additional references. *) 30 | 31 | (* https://orgmode.org/manual/Footnotes.html *) 32 | (* It ends at the next footnote definition, headline, or after two consecutive empty lines. *) 33 | let name_part config = 34 | match config.format with 35 | | Org -> 36 | string "[fn:" *> take_while1 (fun c -> c <> ']' && non_eol c) 37 | <* char ']' <* spaces 38 | | Markdown -> Markdown_footnote.reference <* char ':' <* spaces 39 | 40 | let footnote_definition = 41 | let non_eol = function 42 | | '\r' 43 | | '\n' 44 | | '-' 45 | | '*' 46 | | '#' 47 | | '[' -> 48 | false 49 | | _ -> true 50 | in 51 | let l = 52 | spaces *> satisfy non_eol >>= fun c -> 53 | line <* (end_of_input <|> end_of_line) >>| fun s -> String.make 1 c ^ s 54 | in 55 | many1 l 56 | 57 | let definition_parse config = 58 | let name_part = name_part config in 59 | lift2 60 | (fun name lines -> 61 | let definition_content = String.concat "\n" lines in 62 | let definition = 63 | match 64 | parse_string ~consume:All (Inline.parse config) definition_content 65 | with 66 | | Ok inlines -> inlines 67 | | Error _e -> 68 | Type_op.inline_list_with_none_pos [ Inline.Plain definition_content ] 69 | in 70 | Footnote_Definition (name, definition)) 71 | name_part footnote_definition 72 | 73 | let parse config = optional ws *> definition_parse config <* optional eols 74 | -------------------------------------------------------------------------------- /lib/opml_parser.ml: -------------------------------------------------------------------------------- 1 | open! Prelude 2 | open Xmlm 3 | 4 | type headers = { title : string } [@@deriving yojson] 5 | 6 | type headers_and_blocks = headers * Type.blocks_with_content [@@deriving yojson] 7 | 8 | let parse_header (i : input) = 9 | let headers : headers = { title = "untitled" } in 10 | let rec aux headers i = 11 | match peek i with 12 | | `El_start ((_, "body"), _) -> headers 13 | | `El_start ((_, "title"), _) -> ( 14 | input i |> ignore; 15 | match input i with 16 | | `Data title -> aux { title = String.trim title } i 17 | | _ -> aux headers i) 18 | | `El_start _ 19 | | `El_end 20 | | `Data _ 21 | | `Dtd _ -> 22 | input i |> ignore; 23 | aux headers i 24 | in 25 | aux headers i 26 | 27 | type tree = 28 | | E of Xmlm.tag * tree list 29 | | D 30 | 31 | let body_to_tree i = 32 | Xmlm.input_tree ~el:(fun tag childs -> E (tag, childs)) ~data:(fun _ -> D) i 33 | 34 | let tree_to_string_tree_type tree = 35 | let open Option in 36 | let extracted_body = 37 | match tree with 38 | | E (((_, "body"), _), childs) -> childs 39 | | _ -> [] 40 | in 41 | let rec aux (tree : tree) = 42 | match tree with 43 | | E (((_, "outline"), attrs), childs) -> 44 | let text = 45 | List.find_map 46 | (function 47 | | (_, "text"), text -> Some text 48 | | _ -> None) 49 | attrs 50 | |? "" 51 | in 52 | let note = 53 | List.find_map 54 | (function 55 | | (_, "_note"), note -> Some note 56 | | _ -> None) 57 | attrs 58 | in 59 | let text_and_note = 60 | match note with 61 | | None -> [ Zip.Leaf text ] 62 | | Some note' -> [ Zip.Leaf text; Zip.Leaf note' ] 63 | in 64 | Zip.branch (List.append text_and_note (List.map aux childs)) 65 | | E _ 66 | | D -> 67 | Zip.branch [] 68 | in 69 | let remove_empty_branch l = 70 | let open Zip in 71 | let z = of_l l in 72 | let rec aux z = 73 | if is_end z then 74 | root z 75 | else 76 | match node z with 77 | | Branch [] -> ( 78 | match remove z with 79 | | Some z' -> aux (next z') 80 | | None -> aux (next z)) 81 | | _ -> aux (next z) 82 | in 83 | aux z 84 | in 85 | remove_empty_branch @@ Zip.branch @@ List.map aux extracted_body 86 | 87 | let string_tree_type_to_value = Markdown_transformer.String_Tree_Value.to_value 88 | 89 | let parse opml_string = 90 | let input = 91 | make_input 92 | (`String (0, opml_string)) 93 | ~entity:(function 94 | | "nbsp" -> Some " " 95 | | _ -> None) 96 | in 97 | let headers = parse_header input in 98 | let blocks = 99 | body_to_tree input |> tree_to_string_tree_type 100 | |> Markdown_transformer.String_Tree_Value.to_value 101 | |> Tree_type.of_value_with_content |> Tree_type.to_blocks_with_content 102 | in 103 | (headers, blocks) 104 | -------------------------------------------------------------------------------- /lib/syntax/drawer.ml: -------------------------------------------------------------------------------- 1 | (* 2 | Drawers a way to hide information in =org-mode=. The syntax is: 3 | :DRAWERNAME: 4 | Contents of the drawer (socks for instance) 5 | :END: 6 | 7 | There is a special kind of drawer that =mlorg= recognizes, it is the 8 | /PROPERTY/ drawer, which look like: 9 | : :PROPERTIES: 10 | : :KEY: Value 11 | : :KEY: Value 12 | : :KEY: Value 13 | : :END: 14 | They are used to store information about a heading and can be used to 15 | filter on them. (Exporters don't use them as of today) 16 | *) 17 | open! Prelude 18 | open Angstrom 19 | open Parsers 20 | open Type 21 | open Conf 22 | 23 | let end_mark = ":END:" 24 | 25 | let property config = 26 | let property_key = 27 | optional spaces 28 | *> between_char ':' ':' 29 | (take_while1 (fun c -> c <> ':' && c <> ' ' && non_eol c)) 30 | >>= fun s -> 31 | if String.lowercase_ascii s = "end" then 32 | fail "property key" 33 | else 34 | return s 35 | in 36 | let property_value = 37 | optional spaces *> optional_line <* (eol *> return () <|> end_of_input) 38 | in 39 | lift2 (fun key value -> 40 | let inlines = Property.property_references config value in 41 | (key, value, inlines)) property_key property_value 42 | 43 | let drawer_properties config = many (property config) 44 | 45 | let drawer_name = 46 | spaces 47 | *> between_char ':' ':' 48 | (take_while1 (fun c -> c <> ':' && c <> ' ' && non_eol c)) 49 | <* eol 50 | 51 | let parse1 config = 52 | let is_markdown = Conf.is_markdown config in 53 | (* anything but a headline and another drawer *) 54 | let p = 55 | let name = spaces *> string_ci ":PROPERTIES:" <* eol in 56 | lift2 57 | (fun _name properties -> Property_Drawer properties) 58 | name (drawer_properties config) 59 | in 60 | let p' = p <* spaces <* string_ci end_mark <* optional eol in 61 | if is_markdown then 62 | Markdown_property.parse config <|> p' 63 | else 64 | p' 65 | 66 | (* #+NAME: VALUE like orgmode property *) 67 | let name = 68 | between_string "#+" ":" (take_while1 (fun c -> c <> ':' && non_space_eol c)) 69 | 70 | let parse2 = 71 | let p = 72 | lift2 73 | (fun name value -> Property_Drawer [ (name, value, []) ]) 74 | name (spaces *> optional_line) 75 | in 76 | between_eols p 77 | 78 | let drawer_content = 79 | between_lines ~trim:false 80 | (fun line -> 81 | String.equal (String.lowercase_ascii (String.trim line)) ":end:") 82 | "drawer_content" 83 | 84 | let drawer_parse = 85 | let p = 86 | lift2 87 | (fun name content -> 88 | let name = String.lowercase_ascii name in 89 | let content = remove_last_newlines content in 90 | Drawer (name, content)) 91 | drawer_name drawer_content 92 | in 93 | p <* optional eol 94 | 95 | (* combine 96 | :PROPERTIES: :END: properties and #+NAME: VALUE properties *) 97 | let parse config = 98 | if config.enable_drawers then 99 | many1 (parse1 config <|> parse2) 100 | >>= (fun properties -> 101 | return 102 | @@ Property_Drawer 103 | (List.fold_left 104 | (fun r e -> 105 | match e with 106 | | Property_Drawer kvs -> List.append r kvs 107 | | _ -> failwith "unreachable") 108 | [] properties)) 109 | <|> drawer_parse 110 | else 111 | fail "drawer" 112 | -------------------------------------------------------------------------------- /bin/main.ml: -------------------------------------------------------------------------------- 1 | open Mldoc 2 | open Mldoc.Parser 3 | open Mldoc.Conf 4 | open Lwt 5 | open Cmdliner 6 | 7 | (* stdin *) 8 | let read_lines () = Lwt_io.read_lines Lwt_io.stdin |> Lwt_stream.to_list 9 | 10 | (* file *) 11 | let from_file filename = Lwt_io.lines_of_file filename |> Lwt_stream.to_list 12 | 13 | let generate backend output _opts filename = 14 | let extension = Filename.extension filename in 15 | let format = 16 | match extension with 17 | | ".markdown" 18 | | ".md" -> 19 | Markdown 20 | | _ -> Org 21 | in 22 | let lines = 23 | if filename = "-" then 24 | read_lines () 25 | else 26 | from_file filename 27 | in 28 | lines >>= function 29 | | lines -> 30 | let config = 31 | { toc = true 32 | ; parse_outline_only = true 33 | ; heading_number = true 34 | ; keep_line_break = false 35 | ; format 36 | ; heading_to_list = true 37 | ; exporting_keep_properties = true 38 | ; inline_type_with_pos = false 39 | ; inline_skip_macro = false 40 | ; export_md_indent_style = Dashes 41 | ; export_md_remove_options = [] 42 | ; hiccup_in_block = true 43 | ; enable_drawers = true 44 | ; parse_marker = true 45 | ; parse_priority = true 46 | } 47 | in 48 | let ast = parse config (String.concat "\n" lines) in 49 | let document = Document.from_ast None ast in 50 | let export = Exporters.find backend in 51 | let module E = (val export : Exporter.Exporter) in 52 | let output = 53 | if output = "" then 54 | E.default_filename filename 55 | else 56 | output 57 | in 58 | let fdout = 59 | if output = "-" then 60 | stdout 61 | else 62 | open_out output 63 | in 64 | (* FIXME: parse *) 65 | let result = Exporters.run ~refs:None export config document fdout in 66 | return result 67 | 68 | (* Cmd liner part *) 69 | 70 | (* Commonon options *) 71 | let output = 72 | let doc = "Write the generated file to $(docv). " in 73 | Arg.(value & opt string "" & info [ "o"; "output" ] ~docv:"OUTPUT-FILE" ~doc) 74 | 75 | let backend = 76 | let doc = "Uses $(docv) to generate the output. (`-` for stdout)" in 77 | Arg.(value & opt string "html" & info [ "b"; "backend" ] ~docv:"BACKEND" ~doc) 78 | 79 | let filename = 80 | let doc = "The input filename to use. (`-` for stdin) " in 81 | Arg.(value & pos 0 string "-" & info [] ~docv:"FILENAME" ~doc) 82 | 83 | let options = 84 | let doc = 85 | "Extra option to use to configure the behaviour. (Can be used multiple \ 86 | times)" 87 | in 88 | Arg.( 89 | value 90 | & opt_all (pair ~sep:'=' string string) [] 91 | & info [ "x"; "option" ] ~docv:"OPTIONS" ~doc) 92 | 93 | let cmd = Term.(const generate $ backend $ output $ options $ filename) 94 | let doc = "converts org-mode or markdown files into various formats" 95 | let options = [] 96 | 97 | let man = 98 | [ `S "DESCRIPTION" 99 | ; `P 100 | "$(tname) can currently converts org-mode or markdown files into other \ 101 | formats such as\n\ 102 | \ HTML." 103 | ] 104 | @ options 105 | 106 | let infos = Cmd.info "mldoc" ~version:"0" ~doc ~man 107 | 108 | let main () = 109 | match Cmd.v infos cmd |> Cmd.eval_value with 110 | | Ok (`Ok expr) -> Lwt_main.run expr 111 | | _ -> exit 1 112 | 113 | let () = 114 | let _ = Printexc.record_backtrace true in 115 | if not !Sys.interactive then main () 116 | -------------------------------------------------------------------------------- /lib/syntax/timestamp.ml: -------------------------------------------------------------------------------- 1 | open Prelude 2 | 3 | type date = 4 | { year : int 5 | ; month : int 6 | ; day : int 7 | } 8 | [@@deriving yojson] 9 | 10 | type time = 11 | { hour : int 12 | ; min : int 13 | } 14 | [@@deriving yojson] 15 | 16 | type repetition_kind = 17 | | Plus 18 | | DoublePlus 19 | | Dotted 20 | [@@deriving yojson] 21 | 22 | type repetition_duration = 23 | | Hour 24 | | Day 25 | | Week 26 | | Month 27 | | Year 28 | [@@deriving yojson] 29 | 30 | type t = 31 | { date : date 32 | ; wday : string 33 | ; time : time option [@default None] 34 | ; repetition : 35 | ((repetition_kind * repetition_duration * int) option[@default None]) 36 | ; active : bool 37 | } 38 | [@@deriving yojson] 39 | 40 | let year t = t.date.year 41 | 42 | let month t = t.date.month 43 | 44 | let day t = t.date.day 45 | 46 | let hour t = Option.map_default (fun x -> x.hour) 0 t.time 47 | 48 | let min t = Option.map_default (fun x -> x.min) 0 t.time 49 | 50 | let hour_opt t = Option.map_default (fun x -> Some x.hour) None t.time 51 | 52 | let min_opt t = Option.map_default (fun x -> Some x.min) None t.time 53 | 54 | let null_date = { year = 0; month = 0; day = 0 } 55 | 56 | (* let null_time = {min= 0; hour= 0} *) 57 | 58 | let parse_time s = 59 | try Scanf.sscanf s "%d:%d" (fun hour min -> Some { hour; min }) 60 | with _ -> None 61 | 62 | let parse_date s = 63 | try 64 | Scanf.sscanf s "%d-%d-%d" (fun year month day -> Some { year; month; day }) 65 | with _ -> None 66 | 67 | let repetition_kind_to_string = function 68 | | Plus -> "+" 69 | | DoublePlus -> "++" 70 | | Dotted -> ".+" 71 | 72 | let parse_repetition_marker kind s = 73 | try 74 | Scanf.sscanf s "%d%c" (fun n c -> 75 | match c with 76 | | 'h' -> Some (kind, Hour, n) 77 | | 'd' -> Some (kind, Day, n) 78 | | 'w' -> Some (kind, Week, n) 79 | | 'm' -> Some (kind, Month, n) 80 | | 'y' -> Some (kind, Year, n) 81 | | _ -> None) 82 | with _ -> None 83 | 84 | let date_to_string d = Printf.sprintf "%d-%02d-%02d" d.year d.month d.day 85 | 86 | let time_to_string t = Printf.sprintf "%02d:%02d" t.hour t.min 87 | 88 | let repetition_duration_to_string = function 89 | | Hour -> "h" 90 | | Day -> "d" 91 | | Week -> "w" 92 | | Month -> "m" 93 | | Year -> "y" 94 | 95 | let repetition_to_string (kind, duration, n) = 96 | let kind = repetition_kind_to_string kind in 97 | let duration = repetition_duration_to_string duration in 98 | Printf.sprintf "%s%d%s" kind n duration 99 | 100 | let to_string t = 101 | Printf.sprintf "%c%s%c" 102 | (if t.active then 103 | '<' 104 | else 105 | '[') 106 | ([ Some (date_to_string t.date) 107 | ; Some t.wday 108 | ; Option.map time_to_string t.time 109 | ; Option.map repetition_to_string t.repetition 110 | ] 111 | |> filter_map identity |> String.concat " ") 112 | (if t.active then 113 | '>' 114 | else 115 | ']') 116 | 117 | let sub d d' = 118 | { year = d'.year - d.year; month = d'.month - d.month; day = d'.day - d.day } 119 | 120 | let repetition_parser s date time c = 121 | if s.[1] <> '+' then 122 | let repetition = 123 | parse_repetition_marker Plus (String.sub s 1 (String.length s - 1)) 124 | in 125 | (date, time, repetition) 126 | else 127 | let kind = 128 | if c = '+' then 129 | DoublePlus 130 | else 131 | Dotted 132 | in 133 | let repetition = 134 | parse_repetition_marker kind (String.sub s 2 (String.length s - 2)) 135 | in 136 | (date, time, repetition) 137 | -------------------------------------------------------------------------------- /lib/syntax/raw_html.ml: -------------------------------------------------------------------------------- 1 | open Prelude 2 | open Angstrom 3 | open Parsers 4 | 5 | (* TODO: attributes check *) 6 | (* TODO: quickcheck test, the output should be equal to the exactly input *) 7 | 8 | let known_tags = 9 | [ "a" 10 | ; "abbr" 11 | ; "address" 12 | ; "area" 13 | ; "article" 14 | ; "aside" 15 | ; "audio" 16 | ; "b" 17 | ; "base" 18 | ; "bdi" 19 | ; "bdo" 20 | ; "blockquote" 21 | ; "body" 22 | ; "br" 23 | ; "button" 24 | ; "canvas" 25 | ; "caption" 26 | ; "cite" 27 | ; "code" 28 | ; "col" 29 | ; "colgroup" 30 | ; "data" 31 | ; "datalist" 32 | ; "dd" 33 | ; "del" 34 | ; "dfn" 35 | ; "div" 36 | ; "dl" 37 | ; "dt" 38 | ; "em" 39 | ; "embed" 40 | ; "fieldset" 41 | ; "figcaption" 42 | ; "figure" 43 | ; "footer" 44 | ; "form" 45 | ; "h1" 46 | ; "h2" 47 | ; "h3" 48 | ; "h4" 49 | ; "h5" 50 | ; "h6" 51 | ; "head" 52 | ; "header" 53 | ; "hr" 54 | ; "html" 55 | ; "i" 56 | ; "iframe" 57 | ; "img" 58 | ; "input" 59 | ; "ins" 60 | ; "kbd" 61 | ; "keygen" 62 | ; "label" 63 | ; "legend" 64 | ; "li" 65 | ; "link" 66 | ; "main" 67 | ; "map" 68 | ; "mark" 69 | ; "meta" 70 | ; "meter" 71 | ; "nav" 72 | ; "noscript" 73 | ; "object" 74 | ; "ol" 75 | ; "optgroup" 76 | ; "option" 77 | ; "output" 78 | ; "p" 79 | ; "param" 80 | ; "pre" 81 | ; "progress" 82 | ; "q" 83 | ; "rb" 84 | ; "rp" 85 | ; "rt" 86 | ; "rtc" 87 | ; "ruby" 88 | ; "s" 89 | ; "samp" 90 | ; "script" 91 | ; "section" 92 | ; "select" 93 | ; "small" 94 | ; "source" 95 | ; "span" 96 | ; "strong" 97 | ; "style" 98 | ; "sub" 99 | ; "sup" 100 | ; "table" 101 | ; "tbody" 102 | ; "td" 103 | ; "template" 104 | ; "textarea" 105 | ; "tfoot" 106 | ; "th" 107 | ; "thead" 108 | ; "time" 109 | ; "title" 110 | ; "tr" 111 | ; "track" 112 | ; "u" 113 | ; "ul" 114 | ; "var" 115 | ; "video" 116 | ; "details" 117 | ; "summary" 118 | ; "wbr" 119 | ] 120 | 121 | let known_tag s = 122 | let s = String.lowercase_ascii s in 123 | List.mem s known_tags 124 | 125 | let match_tag tag open_tag close_tag left_char = 126 | let level_ref = ref 1 in 127 | let s_ref = ref "" in 128 | fix (fun parse -> 129 | end_string_2 close_tag ~ci:true (fun s -> 130 | let level_without_attrs = count_substring s open_tag in 131 | let level_with_attrs = count_substring s (left_char ^ tag ^ " ") in 132 | let level = level_without_attrs + level_with_attrs in 133 | let _ = level_ref := !level_ref + level - 1 in 134 | let _ = s_ref := !s_ref ^ s ^ close_tag in 135 | if !level_ref <= 0 then 136 | return (left_char ^ tag ^ !s_ref) 137 | else 138 | parse)) 139 | 140 | let self_close_tag tag = 141 | end_string "/>" (fun s -> String.concat "" [ "<"; tag; s; "/>" ]) 142 | 143 | let tag_wrapper = 144 | char '<' *> take_till1 (fun c -> is_space c || c == '>') >>= fun tag -> 145 | (if known_tag tag then 146 | return tag 147 | else 148 | fail ("html invalid tag: " ^ tag)) 149 | >>= fun tag -> 150 | let open_tag = "<" ^ tag ^ ">" in 151 | let close_tag = "" in 152 | match_tag tag open_tag close_tag "<" <|> self_close_tag tag 153 | 154 | (* Idea and part of the code from Omd *) 155 | let parse = 156 | peek_string 10 >>= fun s -> 157 | match explode s with 158 | | '<' :: '?' :: _ -> between_string_strict_wrapper "" 159 | (* *) 160 | | '<' :: '!' :: '-' :: '-' :: _ -> between_string_strict_wrapper "" 161 | (* *) 162 | | '<' :: '!' :: '[' :: 'C' :: 'D' :: 'A' :: 'T' :: 'A' :: '[' :: _ -> 163 | between_string_strict_wrapper " *) 165 | | '<' :: '!' :: _ -> between_string_strict_wrapper "" 166 | | '<' :: _ -> tag_wrapper 167 | | _ -> fail "raw html" 168 | -------------------------------------------------------------------------------- /lib/transform/markdown_transformer.ml: -------------------------------------------------------------------------------- 1 | open Prelude 2 | module Z = Zip 3 | 4 | module String_Tree_Value : sig 5 | type t = string Z.l 6 | 7 | val of_value : Tree_type.value -> config:Conf.t -> t 8 | val to_value : t -> Tree_type.value_with_content 9 | end = struct 10 | type t = string Z.l 11 | 12 | let default_config : Conf.t = 13 | { toc = true 14 | ; parse_outline_only = false 15 | ; heading_number = true 16 | ; keep_line_break = false 17 | ; format = Conf.Markdown 18 | ; heading_to_list = false 19 | ; exporting_keep_properties = false 20 | ; inline_type_with_pos = false 21 | ; inline_skip_macro = false 22 | ; export_md_indent_style = Conf.Dashes 23 | ; export_md_remove_options = [] 24 | ; hiccup_in_block = true 25 | ; enable_drawers = true 26 | ; parse_marker = true 27 | ; parse_priority = true 28 | } 29 | 30 | let rec of_value v ~config = 31 | match v with 32 | | Z.Leaf (t, _pos) -> 33 | Z.leaf @@ Output.to_string 34 | @@ Markdown.block (Markdown.default_state ()) config t 35 | | Z.Branch [] -> Z.Branch [] 36 | | Z.Branch l -> Z.branch @@ List.map (of_value ~config) l 37 | 38 | let collect_body_part l = 39 | let rec aux r l = 40 | match l with 41 | | [] -> (r, []) 42 | | (Z.Leaf _ as h) :: t -> aux (h :: r) t 43 | | Z.Branch _ :: _ as rest -> (List.rev r, rest) 44 | in 45 | aux [] l 46 | 47 | let to_value t = 48 | let rec aux t ~level = 49 | match t with 50 | | Z.Branch [] -> Z.Branch [] 51 | | Z.Branch [ (Z.Branch _ as e) ] -> aux e ~level 52 | | Z.Branch (Z.Branch _ :: _ as l) -> Z.branch @@ List.map (aux ~level) l 53 | | Z.Branch (Z.Leaf h :: t) -> 54 | (* FIXME: feel bad to operations(concat "-") on string directly here *) 55 | let h = "- " ^ h in 56 | let ast = Mldoc_parser.parse default_config h in 57 | let body, rest = collect_body_part t in 58 | let body_ast = 59 | List.map 60 | (function 61 | | Z.Leaf e -> 62 | let ast = Mldoc_parser.parse default_config e in 63 | let ast' = 64 | List.map 65 | (fun (ast, (pos : Pos.pos_meta)) -> 66 | ( ast 67 | , String.sub e pos.start_pos (pos.end_pos - pos.start_pos) 68 | )) 69 | ast 70 | in 71 | Some ast' 72 | | Z.Branch _ -> None) 73 | body 74 | |> List.concat_map (function 75 | | None -> [] 76 | | Some e -> e) 77 | in 78 | let head_ast, body_ast' = 79 | match ast with 80 | | [] -> failwith "empty ast" 81 | | h :: t -> (h, t) 82 | in 83 | let head, pos = head_ast in 84 | let head' = 85 | match head with 86 | | Type.Heading h -> Type.Heading { h with level } 87 | | _ -> head 88 | in 89 | let head_content = 90 | let len = pos.end_pos - 2 - pos.start_pos in 91 | let len = 92 | if len > 0 then 93 | len 94 | else 95 | 0 96 | in 97 | String.sub h (2 + pos.start_pos) len 98 | in 99 | let head_ast' = (head', head_content) in 100 | let body_ast' = 101 | List.map 102 | (fun (ast, (pos : Pos.pos_meta)) -> 103 | (ast, String.sub h pos.start_pos (pos.end_pos - pos.start_pos))) 104 | body_ast' 105 | in 106 | let body_ast'' = body_ast' @ body_ast in 107 | Z.branch 108 | @@ (Z.leaf head_ast' :: List.map Z.leaf body_ast'') 109 | @ List.map (aux ~level:(level + 1)) rest 110 | | Z.Leaf _ as l -> aux (Z.branch [ l ]) ~level 111 | in 112 | aux t ~level:1 113 | end 114 | -------------------------------------------------------------------------------- /lib/export/opml.ml: -------------------------------------------------------------------------------- 1 | open Prelude 2 | open Conf 3 | 4 | let default_state = Markdown.default_state 5 | let empty_references = Reference.empty_parsed_t 6 | 7 | let default_config = 8 | { toc = true 9 | ; parse_outline_only = false 10 | ; heading_number = true 11 | ; keep_line_break = false 12 | ; format = Conf.Markdown 13 | ; heading_to_list = true 14 | ; exporting_keep_properties = false 15 | ; inline_type_with_pos = false 16 | ; inline_skip_macro = false 17 | ; export_md_indent_style = Spaces 18 | ; export_md_remove_options = [] 19 | ; hiccup_in_block = true 20 | ; enable_drawers = true 21 | ; parse_marker = true 22 | ; parse_priority = true 23 | } 24 | 25 | let attr ?(uri = "") local value : Xmlm.attribute = ((uri, local), value) 26 | let tag name attrs : Xmlm.tag = (("", name), attrs) 27 | 28 | (* only concat Leaf list, ignore Branch elem *) 29 | let zipl_to_string_list l = 30 | List.map 31 | (fun e -> 32 | match e with 33 | | Zip.Leaf s -> s 34 | | Zip.Branch _ -> "") 35 | l 36 | 37 | let outline_frag ?(childs = []) ?note text : string Zip.l Xmlm.frag = 38 | let text_attr = attr "text" text in 39 | let attrs = 40 | match note with 41 | | None 42 | | Some [] -> 43 | [ text_attr ] 44 | | Some note' -> [ text_attr; attr "_note" (String.concat "\n" note') ] 45 | in 46 | `El ((("", "outline"), attrs), childs) 47 | 48 | let collect_outline_note_part (l : string Zip.l list) = 49 | let rec aux r l = 50 | let note_part = r in 51 | match l with 52 | | [] -> (r, []) 53 | | (Zip.Leaf _ as h) :: t -> aux (h :: note_part) t 54 | | Zip.Branch _ :: _ as rest -> (List.rev note_part, rest) 55 | in 56 | aux [] l 57 | 58 | let rec plain_tree_to_frag 59 | (plain_tree : Markdown_transformer.String_Tree_Value.t) : 60 | string Zip.l Xmlm.frag = 61 | let open Zip in 62 | match plain_tree with 63 | | Leaf s -> outline_frag s 64 | | Branch [] -> `Data "" 65 | | Branch (Leaf h :: t) -> 66 | let note_part, rest = collect_outline_note_part t in 67 | let note_part_string_list = zipl_to_string_list note_part in 68 | outline_frag ~childs:rest ~note:note_part_string_list h 69 | | Branch [ (Branch _ as e) ] -> plain_tree_to_frag e 70 | | Branch (Branch _ :: _ as l) -> outline_frag ~childs:l "" 71 | 72 | let output_tree_type o tree = Xmlm.output_tree plain_tree_to_frag o tree 73 | 74 | type output_header = { title : string } 75 | 76 | let output_with_header o { title } tree = 77 | let open Xmlm in 78 | output o (`Dtd None); 79 | output o (`El_start (tag "opml" [ attr "version" "2.0" ])); 80 | output o (`El_start (tag "head" [])); 81 | output o (`El_start (tag "title" [])); 82 | output o (`Data title); 83 | (* title *) output o `El_end; 84 | (* head *) output o `El_end; 85 | (* body *) output o (`El_start (tag "body" [])); 86 | let _ = 87 | match tree with 88 | | Zip.Leaf _ -> output_tree_type o tree 89 | | Zip.Branch l -> List.iter (output_tree_type o) l 90 | in 91 | (* body *) 92 | output o `El_end; 93 | (* opml *) output o `El_end 94 | 95 | let blocks refs tl title output_buf = 96 | let open Tree_type in 97 | of_blocks tl 98 | |> replace_embed_and_refs ~refs 99 | |> replace_heading_with_paragraph |> to_value 100 | |> Markdown_transformer.String_Tree_Value.of_value ~config:default_config 101 | |> output_with_header output_buf { title } 102 | 103 | module OPMLExporter = struct 104 | let name = "opml" 105 | let default_filename = change_ext "opml" 106 | 107 | let export ~refs _config (doc : Document.t) output = 108 | let open Option in 109 | let refs = 110 | refs |? Reference.{ parsed_embed_blocks = []; parsed_embed_pages = [] } 111 | in 112 | let title = doc.filename |? (doc.title |? "untitled") in 113 | let output_buf = Xmlm.make_output ~indent:(Some 2) (`Channel output) in 114 | blocks refs doc.blocks title output_buf 115 | end 116 | -------------------------------------------------------------------------------- /lib/syntax/type.ml: -------------------------------------------------------------------------------- 1 | type inline_list = Inline.t_with_pos list [@@deriving yojson] 2 | 3 | type inline_list_no_pos = Inline.t list [@@deriving yojson] 4 | 5 | type heading = 6 | { title : inline_list (** The title as inline formatted content *) 7 | ; tags : string list (** The tags set by the user *) 8 | ; marker : string option [@default None] (** TODO, DONE, and so on *) 9 | ; level : int (** The level (number of stars) -- starts at 1 *) 10 | ; numbering : int list option [@default None] 11 | ; priority : char option [@default None] (** The optional priority *) 12 | ; anchor : string 13 | ; meta : meta 14 | ; unordered : bool (** whether it's an unordered list (starts with `-`) **) 15 | ; size : int option 16 | } 17 | [@@deriving yojson] 18 | 19 | and meta = 20 | { timestamps : Inline.timestamp list 21 | ; properties : (string * string * Inline.t list) list (** The properties of the heading *) 22 | } 23 | [@@deriving yojson] 24 | 25 | and list_item = 26 | { content : t list (** The contents of the current item *) 27 | ; items : list_item list 28 | ; number : int option [@default None] (** Its number *) 29 | ; name : Inline.t_with_pos list (** Definition name *) 30 | ; checkbox : bool option [@default None] (** Was it checked *) 31 | ; indent : int (** Indentation of the current item. *) 32 | ; ordered : bool 33 | } 34 | [@@deriving yojson] 35 | 36 | and table = 37 | { header : row option [@default None] 38 | ; groups : group list (* rows groups *) 39 | ; col_groups : int list 40 | } 41 | [@@deriving yojson] 42 | 43 | and group = row list 44 | 45 | and row = col list 46 | 47 | and col = Inline.t list 48 | 49 | (** {2 Code blocks} *) 50 | and code_block = 51 | { lines : string list 52 | ; language : string option [@default None] 53 | (** The language the code is written in *) 54 | ; options : string list option [@default None] 55 | ; pos_meta : Pos.pos_meta 56 | } 57 | [@@deriving yojson] 58 | (** Code blocks *) 59 | 60 | and t = 61 | | Paragraph of Inline.t_with_pos list 62 | (** A paragraph containing only inline text *) 63 | | Paragraph_line of string (** Internal usage *) 64 | | Paragraph_Sep of int 65 | | Heading of heading (** A heading *) 66 | | List of list_item list (** A list [item] *) 67 | | Directive of string * string (** A directive [name, value] *) 68 | (* blocks *) 69 | | Results (* TODO: include content or not? *) 70 | | Example of string list 71 | (** [Examples] used to typeset random code snippets. The integer is the line number in the source file. *) 72 | | Src of code_block 73 | (** [Src] is used to typeset code snippets. The integer is the line number in the source file. *) 74 | | Quote of t list (** Quoted text *) 75 | | Export of string * string list option * string 76 | | CommentBlock of string list 77 | | Custom of string * string option * t list * string 78 | (** Custom block of the form 79 | #+begin_name opts 80 | DATA 81 | #+end *) 82 | | Latex_Fragment of Inline.latex_fragment 83 | | Latex_Environment of string * string option * string 84 | (** Latex environment. Of the form 85 | {v \begin{foo} 86 | bar 87 | \end{foo} v} 88 | *) 89 | | Displayed_Math of string 90 | (* FIXME: *) 91 | | Drawer of string * string list (** A drawer *) 92 | | Property_Drawer of (string * string * Inline.t list) list (** A property drawer *) 93 | | Footnote_Definition of string * Inline.t_with_pos list 94 | (** The definition of a footnote : name and contents *) 95 | | Horizontal_Rule (** Horizontal rule *) 96 | | Table of table (** A block *) 97 | | Comment of string (** Comment *) 98 | | Raw_Html of string 99 | | Hiccup of string 100 | [@@deriving yojson] 101 | 102 | and t_with_pos_meta = t * Pos.pos_meta [@@deriving yojson] 103 | 104 | and t_with_content = t * string [@@deriving yojson] 105 | 106 | and blocks = t_with_pos_meta list [@@deriving yojson] 107 | 108 | and blocks_with_content = t_with_content list [@@deriving yojson] 109 | 110 | (* and blocks = t list [@@deriving yojson] *) 111 | 112 | let pp fmt t = 113 | Format.pp_print_string fmt @@ Yojson.Safe.pretty_to_string @@ to_yojson t 114 | -------------------------------------------------------------------------------- /lib/syntax/table.ml: -------------------------------------------------------------------------------- 1 | open Angstrom 2 | open Parsers 3 | open Prelude 4 | open Type 5 | 6 | (* https://orgmode.org/manual/Column-Groups.html#Column-Groups *) 7 | (* 8 | | N | N^2 | N^3 | N^4 | sqrt(n) | sqrt[4](N) | 9 | |---+-----+-----+-----+---------+------------| 10 | | / | < | | > | < | > | 11 | | 1 | 1 | 1 | 1 | 1 | 1 | 12 | | 2 | 4 | 8 | 16 | 1.4142 | 1.1892 | 13 | | 3 | 9 | 27 | 81 | 1.7321 | 1.3161 | 14 | |---+-----+-----+-----+---------+------------| 15 | #+TBLFM: $2=$1^2::$3=$1^3::$4=$1^4::$5=sqrt($1)::$6=sqrt(sqrt(($1))) 16 | *) 17 | 18 | (* https://www.markdownguide.org/extended-syntax/#alignment *) 19 | (* 20 | | Syntax | Description | Test Text | 21 | | :--- | :----: | ---: | 22 | | Header | Title | Here's this | 23 | | Paragraph | Text | And more | 24 | **) 25 | 26 | (* TODO: markdown add alignment support *) 27 | 28 | let boundaries_spec = spaces *> string "#+TBLFM:" *> line 29 | 30 | let separated_line = 31 | spaces *> char '|' 32 | *> take_while1 (fun c -> c = '-' || c = '+' || c = '|' || c = ' ' || c = ':') 33 | (* add '|' to support markdown*) 34 | <* spaces 35 | <* eol 36 | 37 | let split_into_columns s = String.split_on_char '|' s |> List.map String.trim 38 | 39 | let row_line = 40 | let open String in 41 | spaces *> char '|' *> take_till1 is_eol <* optional eol >>= fun line -> 42 | let line = trim line in 43 | let len = length line - 1 in 44 | if len >= 0 then 45 | if get line len <> '|' then 46 | fail "raw_line" 47 | else 48 | let s = sub line 0 len in 49 | return @@ split_into_columns s 50 | else 51 | fail "raw_line" 52 | 53 | let group config = 54 | let p rows = 55 | fix (fun p -> 56 | optional separated_line >>= function 57 | | None -> 58 | (* new row *) 59 | row_line >>= fun row -> 60 | let row = 61 | List.map 62 | (fun col -> 63 | result_default [ Inline.Plain col ] 64 | (Result.map (List.map fst) 65 | (parse_string ~consume:All (Inline.parse config) col))) 66 | row 67 | in 68 | rows := row :: !rows; 69 | p <|> return @@ List.rev !rows 70 | | Some _ -> 71 | (* separated *) 72 | return @@ List.rev !rows) 73 | in 74 | clear_parser_resource p (ref []) "table group" 75 | 76 | let is_col_row row = 77 | let open Inline in 78 | List.for_all 79 | (function 80 | | [ Plain s ] -> s = "/" || s = "<" || s = "" || s = ">" 81 | | _ -> false) 82 | row 83 | 84 | let build_col_groups row = 85 | let open Inline in 86 | let open List in 87 | try 88 | let l = 89 | fold_left 90 | (fun acc element -> 91 | match element with 92 | | [ Plain "/" ] -> 1 :: acc 93 | | [ Plain "<" ] -> 1 :: acc 94 | | [ Plain "" ] 95 | | [ Plain ">" ] -> 96 | (hd acc + 1) :: tl acc 97 | | _ -> failwith "build_col_groups") 98 | [] row 99 | in 100 | rev l 101 | with _ -> [ length row ] 102 | 103 | let extract_col_row header t = 104 | let open List in 105 | try 106 | match hd (hd t) with 107 | | row when is_col_row row -> (header, tl (hd t) :: tl t, row) 108 | | row -> (header, t, row) 109 | with _ -> (header, t, []) 110 | 111 | let parse config = 112 | let p groups = 113 | fix (fun p -> 114 | group config >>= fun g -> 115 | groups := g :: !groups; 116 | p <|> return @@ List.rev !groups) 117 | in 118 | optional eols *> clear_parser_resource p (ref []) "table" 119 | <* optional boundaries_spec 120 | >>= function 121 | | groups -> 122 | let header, groups, col_groups = 123 | match groups with 124 | | [] -> (None, [], []) 125 | | [] :: t -> extract_col_row None t 126 | | (h1 :: t1) :: t -> 127 | let groups = 128 | if List.length t1 = 0 then 129 | t 130 | else 131 | List.concat [ [ t1 ]; t ] 132 | in 133 | extract_col_row (Some h1) groups 134 | in 135 | let col_groups = build_col_groups col_groups in 136 | return @@ Table { header; groups; col_groups } 137 | -------------------------------------------------------------------------------- /lib/syntax/extended/nested_link.ml: -------------------------------------------------------------------------------- 1 | (* Syntax from https://roamresearch.com *) 2 | 3 | (* [[Introduction to [[Logseq]]]] *) 4 | 5 | open! Prelude 6 | open Angstrom 7 | open Parsers 8 | 9 | type child = 10 | | Label of string 11 | | Nested_link of t_with_pos 12 | 13 | and children = child list 14 | 15 | and t = 16 | { content : string 17 | ; children : children 18 | } 19 | 20 | and t_with_pos = t * Pos.pos_meta option 21 | 22 | let rec to_yojson { content; children } : Yojson.Safe.t = 23 | let child_to_yojson child = 24 | match child with 25 | | Label s -> `List [ `String "Label"; `String s ] 26 | | Nested_link (t, None) -> `List [ `String "Nested_link"; to_yojson t ] 27 | | Nested_link (t, Some pos) -> 28 | `List 29 | [ `String "Nested_link" 30 | ; `List [ to_yojson t; Pos.pos_meta_to_yojson pos ] 31 | ] 32 | in 33 | `Assoc 34 | [ ("content", `String content) 35 | ; ("children", `List (List.map child_to_yojson children)) 36 | ] 37 | 38 | let rec child_of_yojson (json : Yojson.Safe.t) = 39 | let ( >>= ) = Ppx_deriving_yojson_runtime.( >>= ) in 40 | match json with 41 | | `List [ `String "Label"; `String s ] -> Ok (Label s) 42 | | `List [ `String "Nested_link"; (`Assoc _ as t) ] -> 43 | of_yojson t >>= fun t' -> Ok (Nested_link (t', None)) 44 | | `List [ `String "Nested_link"; `List [ t; pos ] ] -> 45 | Pos.pos_meta_of_yojson pos >>= fun pos' -> 46 | of_yojson t >>= fun t' -> Ok (Nested_link (t', Some pos')) 47 | | _ -> Result.Error "invalid_arg: child_of_yojson" 48 | 49 | and of_yojson (json : Yojson.Safe.t) = 50 | match json with 51 | | `Assoc [ ("content", `String content); ("children", `List children) ] -> 52 | let children' = 53 | Prelude.List.map 54 | (fun child -> 55 | match child_of_yojson child with 56 | | Ok v -> [ v ] 57 | | _ -> []) 58 | children 59 | |> Prelude.List.flatten 60 | in 61 | Ok { content; children = children' } 62 | | _ -> Result.Error "invalid_arg: Nested_link.of_yojson" 63 | 64 | let rec forward_pos t forward = 65 | let open Pos in 66 | let { children; _ } = t in 67 | { t with 68 | children = 69 | List.map 70 | (fun child -> 71 | match child with 72 | | Nested_link (t, Some pos) -> 73 | Nested_link 74 | ( forward_pos t forward 75 | , Some 76 | { start_pos = pos.start_pos + forward 77 | ; end_pos = pos.end_pos + forward 78 | } ) 79 | | _ -> child) 80 | children 81 | } 82 | 83 | let open_brackets = "[[" 84 | 85 | let close_brackets = "]]" 86 | 87 | let match_brackets () = 88 | let level_ref = ref 1 in 89 | let s_ref = ref "" in 90 | (* To determine whether the `]` is inside a string. *) 91 | string "[[" 92 | *> fix (fun parse -> 93 | end_string_2 close_brackets ~ci:true (fun s -> 94 | let level = count_substring s open_brackets in 95 | let _ = level_ref := !level_ref + level - 1 in 96 | let _ = s_ref := !s_ref ^ s ^ close_brackets in 97 | if !level_ref <= 0 then 98 | let v = !s_ref in 99 | let _ = level_ref := 1 in 100 | let _ = s_ref := "" in 101 | return (open_brackets ^ v) 102 | else 103 | parse)) 104 | 105 | let label_parse = take_while1 (fun c -> c <> '[') >>| fun s -> Label s 106 | 107 | let parse (config : Conf.t) = 108 | let open Pos in 109 | let prefix_pos = Stack.create () in 110 | Stack.push 0 prefix_pos; 111 | fix (fun p -> 112 | let children_parse = many1 (choice [ label_parse; p ]) in 113 | pos >>= fun start_pos -> 114 | let start_pos = start_pos + Stack.top prefix_pos in 115 | match_brackets () >>= fun s -> 116 | pos >>= fun end_pos -> 117 | let end_pos = end_pos + Stack.top prefix_pos in 118 | Stack.push (start_pos + 2) prefix_pos; 119 | let inner_s = String.sub s 2 (String.length s - 4) in 120 | let result = 121 | match parse_string ~consume:All children_parse inner_s with 122 | | Ok result -> result 123 | | Error _e -> [ Label inner_s ] 124 | in 125 | let _ = Stack.pop prefix_pos in 126 | let pos = 127 | if config.inline_type_with_pos then 128 | Some { start_pos; end_pos } 129 | else 130 | None 131 | in 132 | return @@ Nested_link ({ content = s; children = result }, pos)) 133 | >>= function 134 | | Label _l -> fail "nested link" 135 | | Nested_link ({ content; children }, _) -> 136 | if List.length children <= 1 then 137 | fail "nested link" 138 | else 139 | return @@ { content; children } 140 | -------------------------------------------------------------------------------- /lib/export/xml.ml: -------------------------------------------------------------------------------- 1 | open Prelude 2 | 3 | (* taken from mlorg *) 4 | 5 | type t = 6 | | Empty 7 | | Data of string 8 | | Block of string * (string * string) list * t list 9 | | Raw of string 10 | | List of t list 11 | 12 | let empty = Empty 13 | 14 | let block ?(attr = []) name children = Block (name, attr, children) 15 | 16 | let data s = Data s 17 | 18 | let raw s = Raw s 19 | 20 | let list = function 21 | | [] -> Empty 22 | | l -> List l 23 | 24 | let quote, _ = ('"', '"') 25 | 26 | let output_string_rewrite fd s = 27 | let l = String.length s in 28 | for p = 0 to l - 1 do 29 | match s.[p] with 30 | | '>' -> output_string fd ">" 31 | | '<' -> output_string fd "<" 32 | | '&' -> 33 | if p < l - 1 && s.[p + 1] = '#' then 34 | output_char fd '&' 35 | else 36 | output_string fd "&" 37 | | '\'' -> output_string fd "'" 38 | | c when c = quote -> output_string fd """ 39 | | c -> output_char fd c 40 | done 41 | 42 | let output_attribs fd = 43 | let write (name, value) = 44 | Printf.fprintf fd "%s=\"" name; 45 | output_string_rewrite fd value; 46 | Printf.fprintf fd "\"" 47 | in 48 | let rec aux = function 49 | | [ x ] -> write x 50 | | [] -> () 51 | | t :: q -> 52 | write t; 53 | Printf.fprintf fd " "; 54 | aux q 55 | in 56 | aux 57 | 58 | let indent fd num = output_string fd (String.make num ' ') 59 | 60 | let write_string o s = 61 | output_string o s; 62 | output_char o '\000' 63 | 64 | let output_lines ?(rewrite = true) fd indent_level lines = 65 | match Prelude.lines lines with 66 | | t :: q -> 67 | let output = 68 | if rewrite then 69 | output_string_rewrite fd 70 | else 71 | write_string fd 72 | in 73 | output t; 74 | List.iter 75 | (fun s -> 76 | output_char fd '\n'; 77 | indent fd indent_level; 78 | output s) 79 | q; 80 | if String.length lines >= 1 then 81 | if lines.[String.length lines - 1] = '\n' then output "\n" 82 | | [] -> () 83 | 84 | let output ?(offset = 0) fd inlines prep_inlines exceptions space_significants 85 | trees = 86 | let rec write ?(ctx_inline = false) indent_level = function 87 | | Empty -> () 88 | | Data s -> output_lines fd indent_level s 89 | | Raw s -> Printf.fprintf fd "%s" s 90 | | List l -> List.iter (write indent_level) l 91 | | Block (name, attribs, children) -> 92 | let inline = List.mem name inlines in 93 | let close_tag = children = [] && not (List.mem name exceptions) in 94 | let is_child_inline = 95 | List.exists 96 | (function 97 | | Block (name, _, _) -> List.mem name inlines 98 | | _ -> true) 99 | children 100 | in 101 | let lvl = 102 | if not (List.mem name space_significants) then 103 | indent_level + 2 104 | else 105 | 0 106 | in 107 | if not inline then ( 108 | if ctx_inline then output_string fd "\n"; 109 | indent fd indent_level 110 | ); 111 | Printf.fprintf fd "<%s" name; 112 | if attribs <> [] then ( 113 | output_char fd ' '; 114 | output_attribs fd attribs 115 | ); 116 | if close_tag then 117 | output_string fd " />" 118 | else ( 119 | output_string fd ">"; 120 | if (not inline) && not is_child_inline then output_string fd "\n"; 121 | List.iter (write ~ctx_inline:is_child_inline lvl) children; 122 | if 123 | lvl > 0 && (not inline) 124 | && ((not (List.mem name prep_inlines)) 125 | || List.exists 126 | (function 127 | | Block (k, _, _child) -> List.mem k prep_inlines 128 | | _ -> false) 129 | children) 130 | then ( 131 | (if children <> [] then 132 | match last_opt children with 133 | | Some (Data _) -> output_string fd "\n" 134 | | Some _ 135 | | None -> 136 | ()); 137 | indent fd indent_level 138 | ); 139 | Printf.fprintf fd "" name 140 | ); 141 | if not inline then output_char fd '\n' 142 | in 143 | List.iter (write offset) trees; 144 | output_string fd "\n" 145 | 146 | let output_xhtml ?offset chan = 147 | output chan ?offset 148 | [ "u"; "i"; "em"; "b"; "img"; "a"; "code"; "sup"; "sub"; "abbr"; "span" ] 149 | [ "p" 150 | ; "li" 151 | ; "ol" 152 | ; "dt" 153 | ; "td" 154 | ; "h1" 155 | ; "h2" 156 | ; "h3" 157 | ; "h4" 158 | ; "h5" 159 | ; "hr" 160 | ; "th" 161 | ; "ul" 162 | ; "title" 163 | ] 164 | [ "div"; "span"; "ul" ] [ "pre"; "code" ] 165 | -------------------------------------------------------------------------------- /lib/option.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Option - functions for the option type 3 | * Copyright (C) 2003 Nicolas Cannasse 4 | * 2008 David Teller (Contributor) 5 | * 6 | * This library is free software; you can redistribute it and/or 7 | * modify it under the terms of the GNU Lesser General Public 8 | * License as published by the Free Software Foundation; either 9 | * version 2.1 of the License, or (at your option) any later version, 10 | * with the special exception on linking described in file LICENSE. 11 | * 12 | * This library is distributed in the hope that it will be useful, 13 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 15 | * Lesser General Public License for more details. 16 | * 17 | * You should have received a copy of the GNU Lesser General Public 18 | * License along with this library; if not, write to the Free Software 19 | * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA 20 | *) 21 | 22 | (* copy from batteries *) 23 | 24 | type 'a t = 'a option 25 | 26 | let some x = Some x 27 | 28 | let may f = function 29 | | None -> () 30 | | Some v -> f v 31 | 32 | (*$T may 33 | let x = ref 3 in may incr (Some x); !x = 4 34 | *) 35 | 36 | let map f = function 37 | | None -> None 38 | | Some v -> Some (f v) 39 | 40 | (*$T map 41 | map succ None = None 42 | map succ (Some 3) = (Some 4) 43 | *) 44 | 45 | let apply = function 46 | | None -> fun x -> x 47 | | Some f -> f 48 | 49 | (*$T apply 50 | apply None 3 = 3 51 | apply (Some succ) 3 = 4 52 | *) 53 | 54 | let filter f = function 55 | | Some x when f x -> Some x 56 | | _ -> None 57 | 58 | (*$T filter 59 | filter (fun _ -> true) None = None 60 | filter (fun _ -> true) (Some 3) = Some 3 61 | filter (fun _ -> false) (Some 3) = None 62 | *) 63 | 64 | let default v = function 65 | | None -> v 66 | | Some v -> v 67 | 68 | (*$T default 69 | default 3 None = 3 70 | default 3 (Some 4) = 4 71 | *) 72 | 73 | let default_delayed l = function 74 | | None -> l () 75 | | Some v -> v 76 | 77 | (*$T default_delayed 78 | default_delayed (fun () -> 3) None = 3 79 | default_delayed (fun () -> assert false) (Some 4) = 4 80 | *) 81 | 82 | let is_some = function 83 | | None -> false 84 | | _ -> true 85 | 86 | (*$T is_some 87 | not (is_some None) 88 | is_some (Some ()) 89 | *) 90 | 91 | let is_none = function 92 | | None -> true 93 | | _ -> false 94 | 95 | (*$T is_none 96 | is_none None 97 | not (is_none (Some ())) 98 | *) 99 | 100 | let get_exn s e = 101 | match s with 102 | | None -> raise e 103 | | Some v -> v 104 | 105 | (*$T get_exn 106 | try get_exn None Exit with Exit -> true 107 | try get_exn (Some true) Exit with Exit -> false 108 | *) 109 | 110 | let get s = get_exn s (Invalid_argument "Option.get") 111 | 112 | (*$T get 113 | try get None with Invalid_argument _ -> true 114 | try get (Some true) with Invalid_argument _ -> false 115 | *) 116 | 117 | let map_default f v = function 118 | | None -> v 119 | | Some v2 -> f v2 120 | 121 | (*$T map_default 122 | map_default succ 2 None = 2 123 | map_default succ 2 (Some 3) = 4 124 | *) 125 | 126 | let map_default_delayed f l = function 127 | | None -> l () 128 | | Some v -> f v 129 | 130 | (*$T map_default_delayed 131 | map_default_delayed succ (fun () -> 2) None = 2 132 | map_default_delayed succ (fun () -> assert false) (Some 3) = 4 133 | *) 134 | 135 | let compare ?(cmp = Stdlib.compare) a b = 136 | match a with 137 | | None -> ( 138 | match b with 139 | | None -> 0 140 | | Some _ -> -1) 141 | | Some x -> ( 142 | match b with 143 | | None -> 1 144 | | Some y -> cmp x y) 145 | 146 | (*$T compare 147 | compare (Some 0) (Some 1) < 0 148 | compare (Some 0) (Some 0) = 0 149 | compare (Some 0) (Some (-1)) > 0 150 | compare None (Some ()) < 0 151 | compare None None = 0 152 | compare (Some ()) None > 0 153 | compare ~cmp:(fun _ _ -> 0) (Some (fun x -> x)) (Some (fun y -> y)) = 0 154 | *) 155 | 156 | let eq ?(eq = ( = )) x y = 157 | match (x, y) with 158 | | None, None -> true 159 | | Some a, Some b -> eq a b 160 | | _ -> false 161 | 162 | (*$T eq 163 | eq ~eq:(fun a b -> (a land 1) = (b land 1)) (Some 1) (Some 3) 164 | eq (Some 3) (None) = false 165 | eq None None = true 166 | *) 167 | 168 | module Monad = struct 169 | type 'a m = 'a option 170 | 171 | let return x = Some x 172 | 173 | let bind m f = 174 | match m with 175 | | None -> None 176 | | Some x -> f x 177 | end 178 | 179 | let bind = Monad.bind 180 | 181 | let return = Monad.return 182 | 183 | (*$T bind 184 | bind None (fun s -> Some s) = None 185 | bind (Some ()) (fun s -> Some s) = Some () 186 | *) 187 | 188 | module Labels = struct 189 | let may ~f o = may f o 190 | 191 | let map ~f o = map f o 192 | 193 | let map_default ~f d o = map_default f d o 194 | end 195 | 196 | module Infix = struct 197 | let ( |? ) x def = default def x 198 | 199 | let ( >>= ) = Monad.bind 200 | 201 | let ( >>| ) e f = map f e 202 | end 203 | 204 | include Infix 205 | -------------------------------------------------------------------------------- /js/package/bin/convert.cmd.js: -------------------------------------------------------------------------------- 1 | var yargs = require('yargs'), 2 | fs = require('fs'), 3 | Messenger = require('./messenger.js'), 4 | MO = require('../index').Mldoc; 5 | 6 | yargs.usage('Usage: mldoc convert [options]') 7 | .example('mldoc convert -i', 'Reads from stdin and outputs to stdout') 8 | .example('mldoc convert -i foo.org -o bar.html', 'Reads \'foo.org\' and writes to \'bar.html\'') 9 | .example('mldoc convert -i foo.md -f ast', 'Reads \'foo.md\' and writes its AST to stdout') 10 | .version() 11 | .alias('v', 'version') 12 | .config('c') 13 | .alias('c', 'config') 14 | .help('h') 15 | .alias('h', 'help') 16 | .option('i', { 17 | alias: 'input', 18 | describe: 'Input source. Usually a org file. If omitted or empty, reads from stdin', 19 | type: 'string' 20 | }) 21 | .option('o', { 22 | alias: 'output', 23 | describe: 'Output target. Usually a html file. If omitted or empty, writes to stdout', 24 | type: 'string', 25 | default: false 26 | }) 27 | .option('f', { 28 | alias: 'format', 29 | describe: 'Output format', 30 | type: 'string', 31 | default: false 32 | }) 33 | .option('u', { 34 | alias: 'encoding', 35 | describe: 'Input encoding', 36 | type: 'string', 37 | default: 'utf8' 38 | }) 39 | .option('with-pos', { 40 | describe: 'Include positions meta', 41 | type: 'boolean', 42 | default: false 43 | }) 44 | .option('a', { 45 | alias: 'append', 46 | describe: 'Append data to output instead of overwriting', 47 | type: 'boolean', 48 | default: false 49 | }) 50 | .option('q', { 51 | alias: 'quiet', 52 | description: 'Quiet mode. Only print errors', 53 | type: 'boolean', 54 | default: false 55 | }) 56 | .option('m', { 57 | alias: 'mute', 58 | description: 'Mute mode. Does not print anything', 59 | type: 'boolean', 60 | default: false 61 | }); 62 | 63 | function run () { 64 | 'use strict'; 65 | var argv = yargs.argv, 66 | readMode = (!argv.i || argv.i === '') ? 'stdin' : 'file', 67 | writeMode = (!argv.o || argv.o === '') ? 'stdout' : 'file', 68 | msgMode = (writeMode === 'file') ? 'stdout' : 'stderr', 69 | /** 70 | * MSG object 71 | * @type {Messenger} 72 | */ 73 | messenger = new Messenger(msgMode, argv.quiet, argv.mute), 74 | read = (readMode === 'stdin') ? readFromStdIn : readFromFile, 75 | write = (writeMode === 'stdout') ? writeToStdOut : writeToFile, 76 | content, output_content, config; 77 | 78 | var extension = (readMode === 'file') ? argv.i.split('.').pop() : ''; 79 | var format = (extension === 'org') ? 'Org' : 'Markdown'; 80 | 81 | var to_extension = (writeMode === 'file') ? argv.o.split('.').pop() : ''; 82 | var to_format = argv.format || to_extension || 'markdown'; 83 | to_format = to_format.replace('md', 'markdown'); 84 | 85 | messenger.printMsg('...'); 86 | // read the input 87 | messenger.printMsg('Reading data from ' + readMode + '...'); 88 | content = read(argv.encoding); 89 | 90 | // process the input 91 | messenger.printMsg('Parsing file...'); 92 | messenger.printMsg('Converting to ' + to_format); 93 | 94 | // TODO: add config options 95 | config = JSON.stringify({ 96 | "toc": false, 97 | "parse_outline_only": false, 98 | "heading_number": false, 99 | "keep_line_break": false, 100 | "format": format, 101 | "heading_to_list": false, 102 | "exporting_keep_properties": true, 103 | "inline_type_with_pos": argv.withPos, 104 | "export_md_remove_options": [], 105 | "hiccup_in_block": true, 106 | }); 107 | if (to_format === 'ast') 108 | output_content = JSON.stringify( 109 | JSON.parse( MO.parseInlineJson(content, config) ), 110 | null, 4); 111 | else 112 | output_content = MO.export(to_format, content, config, '{}'); 113 | 114 | // write the output 115 | messenger.printMsg('Writing data to ' + writeMode + '...'); 116 | write(output_content, argv.append); 117 | messenger.okExit(); 118 | 119 | function readFromStdIn () { 120 | try { 121 | var size = fs.fstatSync(process.stdin.fd).size; 122 | if (size === 0) 123 | return '' 124 | const buffer = Buffer.alloc(size) 125 | fs.readSync(process.stdin.fd, buffer) 126 | return buffer.toString(argv.encoding) 127 | } catch (e) { 128 | var err = new Error('Could not read from stdin, reason: ' + e.message); 129 | messenger.errorExit(err); 130 | } 131 | } 132 | 133 | function readFromFile (encoding) { 134 | try { 135 | return fs.readFileSync(argv.i, encoding); 136 | } catch (err) { 137 | messenger.errorExit(err); 138 | } 139 | } 140 | 141 | function writeToStdOut (file) { 142 | return process.stdout.write(file); 143 | } 144 | 145 | function writeToFile (file, append) { 146 | // If a flag is passed, it means we should append instead of overwriting. 147 | // Only works with files, obviously 148 | var write = (append) ? fs.appendFileSync : fs.writeFileSync; 149 | try { 150 | write(argv.o, file); 151 | } catch (err) { 152 | messenger.errorExit(err); 153 | } 154 | } 155 | } 156 | 157 | module.exports = exports = { 158 | run: run 159 | }; 160 | -------------------------------------------------------------------------------- /test/gen_md_files.ml: -------------------------------------------------------------------------------- 1 | open QCheck.Gen 2 | open Mldoc 3 | 4 | type state = { mutable last_level : int } 5 | 6 | let page_ref_g (pagenames : string list) = 7 | oneofl pagenames >|= fun pagename -> 8 | Inline.Link 9 | { url = Inline.Search pagename 10 | ; label = [ Inline.Plain "" ] 11 | ; title = None 12 | ; full_text = Printf.sprintf "[[%s]]" pagename 13 | ; metadata = "" 14 | } 15 | 16 | let unicode_table = 17 | ["¡"; "¢"; "£"; "¤"; "¥"; "¦"; "§"; "¨"; "©"; "ª"; "«"; "¬"; "­"; "®"; "¯"; "°"; "±"; "²"; "³"; "´"; "µ"; "¶"; "·"; "¸"; "¹"; "º"; "»"; "¼"; "½"; "¾"; "¿"; "À"; "Á"; "Â"; "Ã"; "Ä"; "Å"; "Æ"; "Ç"; "È"; "É"; "Ê"; "Ë"; "Ì"; "Í"; "Î"; "Ï"; "Ð"; "Ñ"; "Ò"; "Ó"; "Ô"; "Õ"; "Ö"; "×"; "Ø"; "Ù"; "Ú"; "Û"; "Ü"; "Ý"; "Þ"; "ß"; "à"; "á"; "â"; "ã"; "ä"; "å"; "æ"; "ç"; "è"; "é"; "ê"; "ë"; "ì"; "í"; "î"; "ï"; "ð"; "ñ"; "ò"; "ó"; "ô"; "õ"; "ö"; "÷"; "ø"; "ù"; "ú"; "û"; "ü"; "ý"; "þ"; "ÿ";] [@ocamlformat "disable"] 18 | 19 | let char_table = 20 | [' '; '!'; '"'; '#'; '$'; '%'; '&'; '\''; '('; ')'; '*'; '+'; ','; '-'; '.'; 21 | (* '/'; *) '0'; '1'; '2'; '3'; '4'; '5'; '6'; '7'; '8'; '9'; ':'; ';'; '<'; '='; 22 | '>'; '?'; '@'; 'A'; 'B'; 'C'; 'D'; 'E'; 'F'; 'G'; 'H'; 'I'; 'J'; 'K'; 'L'; 23 | 'M'; 'N'; 'O'; 'P'; 'Q'; 'R'; 'S'; 'T'; 'U'; 'V'; 'W'; 'X'; 'Y'; 'Z'; '['; 24 | '\\'; ']'; '^'; '_'; '`'; 'a'; 'b'; 'c'; 'd'; 'e'; 'f'; 'g'; 'h'; 'i'; 'j'; 25 | 'k'; 'l'; 'm'; 'n'; 'o'; 'p'; 'q'; 'r'; 's'; 't'; 'u'; 'v'; 'w'; 'x'; 'y'; 26 | 'z'; '{'; '|'; '}'; (* '\n' *)] [@ocamlformat "disable"] 27 | 28 | let page_names n = 29 | let pagename i = 30 | let+ pagename_l = 31 | list_size (1 -- 10) 32 | @@ frequency 33 | [ (1, string_size ~gen:(oneofl char_table) (0 -- 5)) 34 | ; (1, oneofl unicode_table) 35 | ] 36 | in 37 | String.(concat "" pagename_l ^ string_of_int i) 38 | in 39 | List.map (fun i -> generate1 (pagename i)) (List.init n (( + ) 1)) 40 | 41 | let dir_names = page_names 42 | 43 | let plain_inline_g = 44 | string_size ~gen:(char_range 'A' 'Z') (1 -- 100) >|= fun s -> Inline.Plain s 45 | 46 | let inline_g pagenames = 47 | frequency [ (10, plain_inline_g); (1, page_ref_g pagenames) ] 48 | 49 | let inlines_g pagenames = list_size (1 -- 10) (inline_g pagenames) 50 | 51 | let level_candidates max = 52 | let max' = (max + 3) / 4 in 53 | List.init max' (fun i -> ((i + 1) * 4) - 3) 54 | 55 | let heading ?(init = false) pagenames state = 56 | let marker_g = 57 | frequencyl 58 | [ (1, Some "TODO"); (1, Some "DOING"); (1, Some "DONE"); (7, None) ] 59 | in 60 | let level_g = 61 | oneofl 62 | (if init then 63 | [ 1 ] 64 | else 65 | level_candidates (state.last_level + 4)) 66 | in 67 | inlines_g pagenames >>= fun inlines -> 68 | marker_g >>= fun marker -> 69 | level_g >>= fun level -> 70 | state.last_level <- level; 71 | return 72 | @@ Type.Heading 73 | { title = inlines 74 | ; tags = [] 75 | ; marker 76 | ; level 77 | ; numbering = None 78 | ; priority = None 79 | ; anchor = "" 80 | ; meta = { timestamps = []; properties = [] } 81 | ; unordered = true 82 | } 83 | 84 | let paragragh pagenames = 85 | inlines_g pagenames >|= fun inlines -> Type.Paragraph inlines 86 | 87 | let blocks_g pagenames : Type.blocks t = 88 | let state = { last_level = 1 } in 89 | let dummy_pos : Type.pos_meta = { start_pos = 0; end_pos = 0 } in 90 | let* init_heading = heading ~init:true pagenames state in 91 | let init_heading_with_pos = (init_heading, dummy_pos) in 92 | let block_with_pos_g = 93 | frequency [ (3, paragragh pagenames); (1, heading pagenames state) ] 94 | >|= fun b -> (b, dummy_pos) 95 | in 96 | let* blocks' = list_size (10 -- 500) block_with_pos_g in 97 | return (init_heading_with_pos :: blocks') 98 | 99 | let document_g pagename pagenames = 100 | let* blocks = blocks_g pagenames in 101 | let title = pagename in 102 | return 103 | ({ filename = Some title 104 | ; blocks 105 | ; directives = [] 106 | ; title = Some title 107 | ; subtitle = None 108 | ; author = None 109 | ; toc = [] 110 | } 111 | : Document.t) 112 | 113 | let config : Conf.t = 114 | { toc = true 115 | ; parse_outline_only = false 116 | ; heading_number = true 117 | ; keep_line_break = false 118 | ; format = Conf.Markdown 119 | ; heading_to_list = true 120 | ; exporting_keep_properties = false 121 | ; inline_type_with_pos = false 122 | ; export_md_indent_style = Dashes 123 | ; export_md_remove_options = [] 124 | ; hiccup_in_block = true 125 | ; enable_drawers = true 126 | } 127 | 128 | (* ./gen_md_files.exe *) 129 | let _ = 130 | let argv = Array.to_list Sys.argv in 131 | let page_num = 132 | List.nth_opt argv 1 133 | |> Option.map_default (fun n -> Option.default 1 (int_of_string_opt n)) 1 134 | in 135 | let dir_num = 136 | List.nth_opt argv 2 137 | |> Option.map_default (fun n -> Option.default 1 (int_of_string_opt n)) 1 138 | in 139 | let exporter = Exporters.find "markdown" in 140 | let pagenames = page_names page_num in 141 | let dirnames = dir_names dir_num in 142 | List.iter (fun dirname -> Unix.mkdir dirname 0o777) dirnames; 143 | List.iter 144 | (fun pagename -> 145 | let doc = generate1 (document_g pagename pagenames) in 146 | let filepath = 147 | generate1 148 | ( oneofl dirnames >|= fun dirname -> 149 | Printf.sprintf "%s/%s.md" dirname pagename ) 150 | in 151 | let chan = open_out filepath in 152 | Exporters.run exporter ~refs:None config doc chan) 153 | pagenames 154 | -------------------------------------------------------------------------------- /lib/document.ml: -------------------------------------------------------------------------------- 1 | open Prelude 2 | open Type 3 | 4 | type toc = toc_item list [@@deriving yojson] 5 | 6 | and toc_item = 7 | { title : Inline.t_with_pos list 8 | ; level : int 9 | ; anchor : string 10 | ; numbering : int list 11 | ; items : toc 12 | } 13 | 14 | type directives = (string * string) list [@@deriving yojson] 15 | 16 | (** 17 | A document is: 18 | - some content before the first heading 19 | - a list of top-level headings 20 | - a list of directive 21 | - the footnotes inside the beginning of the file. 22 | *) 23 | type t = 24 | { filename : string option (** The filename the document was parsed from *) 25 | ; blocks : blocks (** Blocks content *) 26 | ; directives : directives (** The directives present in the file *) 27 | ; title : string option [@default None] (** The document's title *) 28 | ; subtitle : string option [@default None] (** The document's subtitle *) 29 | ; author : string option [@default None] (** The document's author *) 30 | ; toc : toc (** Table of content *) 31 | } 32 | [@@deriving yojson] 33 | 34 | exception Non_timestamp 35 | 36 | let get_timestamps inlines = 37 | let open Inline in 38 | try 39 | List.fold_left 40 | (fun acc t -> 41 | match t with 42 | | Timestamp t -> t :: acc 43 | | Break_Line 44 | | Hard_Break_Line -> 45 | acc 46 | | _ -> raise Non_timestamp) 47 | [] inlines 48 | with Non_timestamp -> [] 49 | 50 | let compute_heading_numbering level toc = 51 | match toc with 52 | | [] -> [ 1 ] 53 | | p :: _ -> 54 | if p.level = level then 55 | drop_last 1 p.numbering @ [ last p.numbering + 1 ] 56 | else if p.level < level then 57 | (* child *) 58 | p.numbering @ [ 1 ] 59 | else 60 | (* breakout *) 61 | let diff = p.level - level in 62 | let offset = List.length p.numbering - (diff + 1) in 63 | let before, after = split_n offset p.numbering in 64 | before @ [ List.hd after + 1 ] 65 | 66 | let ast_to_json ast = toc_item_to_yojson ast |> Yojson.Safe.to_string 67 | 68 | let rec toc_append_item parent depth item = 69 | if depth = 1 then 70 | { parent with items = parent.items @ [ item ] } 71 | else 72 | let item = 73 | let parent' = last parent.items in 74 | toc_append_item parent' (depth - 1) item 75 | in 76 | { parent with items = drop_last 1 parent.items @ [ item ] } 77 | 78 | let toc_tree items = 79 | let rec go acc = function 80 | | [] -> List.rev acc 81 | | ({ numbering; _ } as h) :: tl -> ( 82 | match List.length numbering with 83 | | 1 -> 84 | (* parent *) 85 | go (h :: acc) tl 86 | | _ -> 87 | (* child *) 88 | let parent = List.hd acc in 89 | let depth = List.length numbering - 1 in 90 | let parent = toc_append_item parent depth h in 91 | go (parent :: List.tl acc) tl) 92 | in 93 | go [] items 94 | 95 | let from_ast filename ast = 96 | let find_directive directives k = 97 | try 98 | let r = List.assoc k directives in 99 | Some r 100 | with Not_found -> None 101 | in 102 | let rec aut directives blocks toc = function 103 | | [] -> (List.rev directives, List.rev blocks, List.rev toc) 104 | | (h, pos_meta) :: tl -> ( 105 | let update_meta f = 106 | match blocks with 107 | | (Heading heading, pos_meta) :: _tl -> 108 | (Heading (f heading), pos_meta) :: List.tl blocks 109 | | _ -> (h, pos_meta) :: blocks 110 | in 111 | match h with 112 | | Directive (k, v) -> 113 | let directives = (k, v) :: directives in 114 | aut directives blocks toc tl 115 | | Heading 116 | { title 117 | ; tags 118 | ; marker 119 | ; level 120 | ; priority 121 | ; anchor 122 | ; meta 123 | ; unordered 124 | ; size 125 | ; _ 126 | } -> 127 | let numbering = compute_heading_numbering level toc in 128 | let h = 129 | Heading 130 | { title 131 | ; tags 132 | ; marker 133 | ; level 134 | ; priority 135 | ; anchor 136 | ; meta 137 | ; numbering = Some numbering 138 | ; unordered 139 | ; size 140 | } 141 | in 142 | let toc_item = { title; level; anchor; numbering; items = [] } in 143 | aut directives ((h, pos_meta) :: blocks) (toc_item :: toc) tl 144 | | Paragraph inlines -> 145 | let blocks = 146 | match get_timestamps (Type_op.inline_list_strip_pos inlines) with 147 | | [] -> (h, pos_meta) :: blocks 148 | | timestamps -> 149 | update_meta (fun heading -> 150 | let timestamps' = 151 | List.append timestamps heading.meta.timestamps 152 | in 153 | { heading with 154 | meta = { heading.meta with timestamps = timestamps' } 155 | }) 156 | in 157 | aut directives blocks toc tl 158 | | Property_Drawer properties -> 159 | let blocks = 160 | update_meta (fun heading -> 161 | { heading with meta = { heading.meta with properties } }) 162 | in 163 | aut directives blocks toc tl 164 | | _ -> aut directives ((h, pos_meta) :: blocks) toc tl) 165 | in 166 | let directives, blocks, toc = aut [] [] [] ast in 167 | { filename 168 | ; directives 169 | ; blocks 170 | ; title = find_directive directives "TITLE" 171 | ; subtitle = find_directive directives "SUBTITLE" 172 | ; author = find_directive directives "AUTHOR" 173 | ; toc = toc_tree toc 174 | } 175 | -------------------------------------------------------------------------------- /lib/syntax/type_op.ml: -------------------------------------------------------------------------------- 1 | open! Prelude 2 | open Pos 3 | open Type 4 | 5 | let remove_properties = 6 | List.filter (function 7 | | Type.Property_Drawer _ -> false 8 | | _ -> true) 9 | 10 | let inline_list_with_dummy_pos (l : 'a list) : ('a * pos_meta option) list = 11 | List.map (fun i -> (i, Some Pos.dummy_pos)) l 12 | 13 | let inline_list_with_none_pos (l : 'a list) : ('a * pos_meta option) list = 14 | List.map (fun i -> (i, None)) l 15 | 16 | let inline_list_strip_pos (l : ('a * pos_meta option) list) : 'a list = 17 | List.map fst l 18 | 19 | let inline_with_pos i start_pos end_pos = 20 | (i, Some ({ start_pos; end_pos } : Pos.pos_meta)) 21 | 22 | let inline_with_dummy_pos i = (i, Some Pos.dummy_pos) 23 | 24 | let inline_move_forward (i, pos) ~forward_pos = 25 | ( i 26 | , match pos with 27 | | None -> None 28 | | Some { start_pos; end_pos } -> 29 | Some 30 | { start_pos = start_pos + forward_pos; end_pos = end_pos + forward_pos } 31 | ) 32 | 33 | let inline_list_move_forward l forward_pos = 34 | List.map (inline_move_forward ~forward_pos) l 35 | 36 | let rec type_move_forawrd t forward_pos = 37 | match t with 38 | | Paragraph l -> Paragraph (inline_list_move_forward l forward_pos) 39 | | Heading h -> 40 | Heading { h with title = inline_list_move_forward h.title forward_pos } 41 | | List items -> 42 | List 43 | (List.map 44 | (fun l -> 45 | { l with 46 | content = 47 | List.map (fun t -> type_move_forawrd t forward_pos) l.content 48 | ; name = inline_list_move_forward l.name forward_pos 49 | }) 50 | items) 51 | | Quote l -> Quote (List.map (fun t -> type_move_forawrd t forward_pos) l) 52 | | Footnote_Definition (s, l) -> 53 | Footnote_Definition (s, inline_list_move_forward l forward_pos) 54 | | _ -> t 55 | 56 | let unescaped_md_string s = 57 | let open Bytes in 58 | let b = of_string s in 59 | let n = ref 0 in 60 | let i = ref 0 in 61 | let lenb = length b in 62 | while !i < lenb do 63 | n := 64 | !n 65 | + 66 | match get b !i with 67 | | '\\' when !i + 1 < lenb && Parsers.is_md_escape_char (get b (!i + 1)) -> 68 | i := !i + 2; 69 | 1 70 | | _ -> 71 | incr i; 72 | 1 73 | done; 74 | if !n = length b then 75 | s 76 | else 77 | let b' = create !n in 78 | n := 0; 79 | let i = ref 0 in 80 | let len_1 = length b - 1 in 81 | while !i <= len_1 do 82 | (match get b !i with 83 | | '\\' when !i < len_1 -> 84 | let c = get b (!i + 1) in 85 | if Parsers.is_md_escape_char c then 86 | set b' !n c 87 | else ( 88 | set b' !n '\\'; 89 | incr n; 90 | set b' !n c 91 | ); 92 | incr i 93 | | c -> set b' !n c); 94 | incr n; 95 | incr i 96 | done; 97 | to_string b' 98 | 99 | let map_escaped_string t f = 100 | let rec inline_aux (t : Inline.t) = 101 | match t with 102 | | Inline.Emphasis (em_type, tl) -> 103 | Inline.Emphasis (em_type, List.map inline_aux tl) 104 | | Inline.Tag tl -> Inline.Tag (List.map inline_aux tl) 105 | | Inline.Plain s -> Inline.Plain (f s) 106 | | Inline.Link link -> 107 | let label = List.map inline_aux link.label in 108 | let url = 109 | match link.url with 110 | | Inline.File s -> Inline.File (f s) 111 | | Inline.Search s -> Inline.Search (f s) 112 | | Inline.Page_ref s -> Inline.Page_ref (f s) 113 | | Inline.Complex complex -> 114 | Inline.Complex { complex with link = f complex.link } 115 | | Inline.Block_ref _ -> link.url 116 | | Inline.Embed_data _ -> link.url 117 | in 118 | Inline.Link { link with label; url } 119 | | Inline.Subscript tl -> Inline.Subscript (List.map inline_aux tl) 120 | | Inline.Superscript tl -> Inline.Superscript (List.map inline_aux tl) 121 | | Inline.Footnote_Reference fr -> 122 | Inline.Footnote_Reference 123 | { fr with definition = Option.map (List.map inline_aux) fr.definition } 124 | | _ -> t 125 | in 126 | let rec block_list_aux list_item = 127 | let content' = List.map block_aux list_item.content in 128 | let items = List.map block_list_aux list_item.items in 129 | let name = 130 | List.map (fun (t', pos) -> (inline_aux t', pos)) list_item.name 131 | in 132 | { list_item with content = content'; items; name } 133 | and block_aux (t : Type.t) = 134 | match t with 135 | | Paragraph l -> 136 | Paragraph (List.map (fun (t', pos) -> (inline_aux t', pos)) l) 137 | | Heading heading -> 138 | let title' = 139 | List.map (fun (t', pos) -> (inline_aux t', pos)) heading.title 140 | in 141 | Heading { heading with title = title' } 142 | | List l -> List (List.map block_list_aux l) 143 | | Quote tl -> Quote (List.map block_aux tl) 144 | | Custom (name, opts, data, s) -> 145 | let data' = List.map block_aux data in 146 | Custom (name, opts, data', s) 147 | | Footnote_Definition (name, content) -> 148 | let content' = List.map (fun (t', pos) -> (inline_aux t', pos)) content in 149 | Footnote_Definition (name, content') 150 | | Table table -> 151 | let header = Option.map (List.map (List.map inline_aux)) table.header in 152 | let groups = 153 | List.map (List.map (List.map (List.map inline_aux))) table.groups 154 | in 155 | Table { table with header; groups } 156 | | _ -> t 157 | in 158 | block_aux t 159 | 160 | (** unescape string in Type.Plain: 161 | e.g. \* -> * 162 | see also Parsers.md_escape_chars 163 | text in code fence should preserve '\' *) 164 | let md_unescaped t = map_escaped_string t unescaped_md_string 165 | 166 | (** TODO *) 167 | let md_escaped _t = failwith "not impl yet" 168 | -------------------------------------------------------------------------------- /test/test_export_markdown.ml: -------------------------------------------------------------------------------- 1 | let default_config : Conf.t = 2 | { toc = true 3 | ; parse_outline_only = false 4 | ; heading_number = true 5 | ; keep_line_break = false 6 | ; format = Conf.Markdown 7 | ; heading_to_list = false 8 | ; exporting_keep_properties = false 9 | ; inline_type_with_pos = false 10 | ; inline_skip_macro = false 11 | ; export_md_indent_style = Conf.Dashes 12 | ; export_md_remove_options = [] 13 | ; hiccup_in_block = true 14 | ; enable_drawers = true 15 | ; parse_marker = true 16 | ; parse_priority = true 17 | } 18 | 19 | let refs : Reference.parsed_t = 20 | { parsed_embed_blocks = 21 | [ ( "ref1" 22 | , ( [ Type.Heading 23 | { Type.title = 24 | Type_op.inline_list_with_none_pos 25 | [ Inline.Plain "ref1-text" ] 26 | ; tags = [] 27 | ; marker = None 28 | ; level = 1 29 | ; numbering = None 30 | ; priority = None 31 | ; anchor = "ref1-text" 32 | ; meta = { Type.timestamps = []; properties = [] } 33 | ; unordered = true 34 | ; size = None 35 | } 36 | ; Type.Property_Drawer 37 | [ ("id", "60d2ead8-23c1-4617-b2df-4ef0dcfbbf2e", []) ] 38 | ] 39 | , [ Type.Heading 40 | { Type.title = 41 | Type_op.inline_list_with_none_pos 42 | [ Inline.Plain "ref1-text" ] 43 | ; tags = [] 44 | ; marker = None 45 | ; level = 1 46 | ; numbering = None 47 | ; priority = None 48 | ; anchor = "ref1-text" 49 | ; meta = { Type.timestamps = []; properties = [] } 50 | ; unordered = true 51 | ; size = None 52 | } 53 | ; Type.Property_Drawer 54 | [ ("id", "60d2ead8-23c1-4617-b2df-4ef0dcfbbf2e", []) ] 55 | ] ) ) 56 | ] 57 | ; parsed_embed_pages = [] 58 | } 59 | 60 | let check_aux ?(config = default_config) source expect = 61 | let tl = Mldoc_parser.parse config source in 62 | let ol = Markdown.blocks refs config tl in 63 | fun _ -> 64 | Alcotest.check Alcotest.string "check exported string" expect 65 | (Output.to_string ol) 66 | 67 | let testcases = 68 | List.map (fun (case, level, f) -> Alcotest.test_case case level f) 69 | 70 | let export_md = 71 | [ ( "replace block-ref" 72 | , testcases 73 | [ ( "merge paragraph" 74 | , `Quick 75 | (* append 2 spaces at end to add
break tag when rendering*) 76 | , check_aux "- text1 ((ref1)) text2" "- text1 ref1-text text2 " ) 77 | ] ) 78 | ; ( "export md" 79 | , testcases 80 | [ ( "(1)" 81 | , `Quick 82 | , check_aux "- line1\n line2\n - line3\n line4" 83 | "- line1 \n line2 \n\t- line3 \n\t line4" ) 84 | ; ( "(2)" 85 | , `Quick 86 | , check_aux "- line1\n line2\n - > line3\n > line4" 87 | "- line1 \n line2 \n\t- \n\t > line3 \n\t line4 \n" ) 88 | ; ( "(3)" 89 | , `Quick 90 | , check_aux 91 | "- line1\n\ 92 | \ line2\n\ 93 | \ - > line3\n\ 94 | \ > line4\n\ 95 | \ - line5\n\ 96 | \ [[line6]]" 97 | "- line1 \n\ 98 | \ line2 \n\ 99 | \t- \n\ 100 | \t > line3 \n\ 101 | \t line4 \n\n\ 102 | \t\t- line5 \n\ 103 | \t\t [[line6]]" ) 104 | ; ( "(4)" 105 | , `Quick 106 | , check_aux 107 | "- line1\n\ 108 | \ line2\n\ 109 | \ - > line3\n\ 110 | \ > line4\n\ 111 | \ - line5\n\ 112 | \ [[line6]]\n\ 113 | \ -\n\ 114 | \tprop:: hahaha\n\ 115 | \t```\n\ 116 | \t dwdw\n\ 117 | \t jdiejdie\n\ 118 | \t```" 119 | "- line1 \n\ 120 | \ line2 \n\ 121 | \t- \n\ 122 | \t > line3 \n\ 123 | \t line4 \n\n\ 124 | \t\t- line5 \n\ 125 | \t\t [[line6]] \n\ 126 | \t\t\t- \n\ 127 | \t\t\t ```\n\ 128 | \t\t\t \t dwdw\n\ 129 | \t\t\t \t jdiejdie\n\ 130 | \t\t\t ```" ) 131 | ; ( "(5)" 132 | , `Quick 133 | , check_aux "- `key`: content **bold**test" 134 | "- `key`: content **bold**test " ) 135 | ; ("(6)", `Quick, check_aux "## heading" "## heading ") 136 | ; ( "(7)" 137 | , `Quick 138 | , check_aux "- **bold** *italic*\ntest" 139 | "- **bold** *italic* \n test" ) 140 | ; ( "indent style='spaces' (1)" 141 | , `Quick 142 | , check_aux 143 | ~config: 144 | { default_config with export_md_indent_style = Conf.Spaces } 145 | "- line1\n line2\n - > line3\n > line4" 146 | "line1\nline2 \n\t> line3 \n\tline4 \n" ) 147 | ; ( "indent style='spaces' (2)" 148 | , `Quick 149 | , check_aux 150 | ~config: 151 | { default_config with export_md_indent_style = Conf.Spaces } 152 | "- line1\n\ 153 | \ line2\n\ 154 | \ - > line3\n\ 155 | \ > line4\n\ 156 | \ - line5\n\ 157 | \ [[line6]]" 158 | "line1\n\ 159 | line2 \n\ 160 | \t> line3 \n\ 161 | \tline4 \n\n\ 162 | \t\tline5\n\ 163 | \t\t[[line6]]" ) 164 | ; ( "indent style='no-indent' (2)" 165 | , `Quick 166 | , check_aux 167 | ~config: 168 | { default_config with export_md_indent_style = Conf.NoIndent } 169 | "- line1\n\ 170 | \ line2\n\ 171 | \ - > line3\n\ 172 | \ > line4\n\ 173 | \ - line5\n\ 174 | \ [[line6]]" 175 | "line1\nline2 \n> line3 \nline4 \n\nline5\n[[line6]]" ) 176 | ; ( "heading size" 177 | , `Quick 178 | , check_aux "- # line1\n - ## TODO line2\n - line3" 179 | "- # line1 \n\t- ## TODO line2 \n\t- line3 " ) 180 | ; ( "replace cloze with its content (1)" 181 | , `Quick 182 | , check_aux "- {{cloze content1,content2}}" "- content1,content2 " ) 183 | ; ( "replace cloze with its content (2)" 184 | , `Quick 185 | , check_aux "- {{cloze (content1,content2)}}" 186 | "- (content1,content2) " ) 187 | ] ) 188 | ] 189 | 190 | let () = Alcotest.run "export-md" export_md 191 | -------------------------------------------------------------------------------- /lib/syntax/heading0.ml: -------------------------------------------------------------------------------- 1 | open Angstrom 2 | open Parsers 3 | open Prelude 4 | open Type 5 | open Conf 6 | 7 | module MakeHeading (Block : sig 8 | val parse : Conf.t -> Type.t Angstrom.t 9 | end) = 10 | struct 11 | (* TODO: Markdown alternate syntax, 12 | https://www.markdownguide.org/basic-syntax/#alternate-syntax 13 | *) 14 | 15 | (* todo keywords *) 16 | let marker = 17 | string "TODO" <|> string "DOING" <|> string "WAITING" <|> string "WAIT" 18 | <|> string "DONE" <|> string "CANCELED" <|> string "CANCELLED" 19 | <|> string "STARTED" <|> string "IN-PROGRESS" <|> string "NOW" 20 | <|> string "LATER" 21 | >>= fun s -> 22 | peek_char >>= function 23 | | None -> return s 24 | | Some c -> 25 | if c == ' ' then 26 | return s 27 | else 28 | fail "Marker should followed by some spaces" 29 | 30 | let org_level = take_while1 (fun c -> c = '*') 31 | 32 | (* return (level, is_unordered, size) *) 33 | let level config = 34 | let result = 35 | match config.format with 36 | | Org -> 37 | org_level >>= fun s -> 38 | let len = String.length s in 39 | return (len, true, None) 40 | | Markdown -> 41 | let markdown_heading = 42 | Markdown_level.parse >>| fun (indents, s) -> 43 | let len = String.length s in 44 | ( Option.map_default 45 | (fun indents -> String.length indents + 1) 46 | 1 indents 47 | , false 48 | , Some len ) 49 | in 50 | let unordered = 51 | lift2 52 | (fun result size -> 53 | match (result, size) with 54 | | Some s, None -> 55 | let len = String.length s in 56 | (len + 1, true, None) 57 | | None, None -> (1, true, None) 58 | | Some s, Some size -> 59 | let len = String.length s in 60 | (len + 1, true, Some (String.length size)) 61 | | None, Some size -> (1, true, Some (String.length size))) 62 | (optional tabs_or_ws <* char '-') 63 | (optional 64 | @@ (spaces *> take_while1 (fun c -> c = '#') 65 | <* (unsafe_lookahead (satisfy is_space_eol) *> return () 66 | <|> end_of_input))) 67 | in 68 | markdown_heading <|> unordered 69 | in 70 | result 71 | <* ( peek_char >>= fun c -> 72 | match c with 73 | | None -> return () 74 | | Some c' when List.mem c' whitespace_chars -> return () 75 | | _ -> fail "need whitespace after (#|*|-)" ) 76 | 77 | let priority = string "[#" *> any_char <* char ']' 78 | 79 | let seperated_tags = 80 | sep_by (char ':') (take_while1 (fun x -> x <> ':' && non_space_eol x)) 81 | 82 | let tags = char ':' *> seperated_tags <* char ':' 83 | 84 | let title_aux_p config = 85 | let config = { config with Conf.hiccup_in_block = false } in 86 | Angstrom.unsafe_lookahead 87 | (choice 88 | [ Drawer.parse config 89 | ; Hr.parse config 90 | ; Table.parse config 91 | ; Latex_env.parse config 92 | ; Block.parse config 93 | ; Footnote.parse config 94 | ; Paragraph.parse 95 | ]) 96 | 97 | (* not include priority, tags, marker 98 | return (title_line_string, first Type.t) *) 99 | let title config = 100 | title_aux_p config >>= fun t -> 101 | match t with 102 | | Paragraph_line _ -> line 103 | | _ -> return "" 104 | 105 | let is_blank s = 106 | let n = String.length s in 107 | let rec aut_is_blank i = 108 | if i = n then 109 | true 110 | else 111 | let c = s.[i] in 112 | if is_space c then 113 | aut_is_blank (i + 1) 114 | else 115 | false 116 | in 117 | aut_is_blank 0 118 | 119 | let anchor_link s = 120 | let map_char = function 121 | | ('a' .. 'z' | 'A' .. 'Z' | '0' .. '9' | '(' | ')') as c -> 122 | String.make 1 c 123 | | ' ' 124 | | '_' 125 | | '-' -> 126 | "_" 127 | | c -> Printf.sprintf "-%x-" (int_of_char c) 128 | in 129 | explode (String.trim s) |> List.map map_char |> String.concat "" 130 | 131 | let parse config = 132 | let p = 133 | lift4 134 | (fun (level, unordered, size) marker priority pos_and_title -> 135 | let title = 136 | match pos_and_title with 137 | | None -> [] 138 | | Some (_pos, title) -> ( 139 | let inline_parse = 140 | if config.parse_outline_only then 141 | Outline_inline.parse 142 | else 143 | Inline.parse 144 | in 145 | match parse_string ~consume:All (inline_parse config) title with 146 | | Ok title -> title 147 | | Error _e -> []) 148 | in 149 | let title, tags = 150 | match title with 151 | | [] -> (title, []) 152 | | _ -> ( 153 | match config.format with 154 | | Org -> ( 155 | let last_inline = List.nth title (List.length title - 1) in 156 | match last_inline with 157 | | Inline.Plain s, _ -> 158 | let s = String.trim s in 159 | if String.length s > 1 && s.[String.length s - 1] = ':' then 160 | let prefix, maybe_tags = splitr (fun c -> c <> ' ') s in 161 | match parse_string ~consume:All tags maybe_tags with 162 | | Ok tags -> 163 | let title = 164 | if prefix = "" then 165 | drop_last 1 title 166 | else 167 | drop_last 1 title 168 | @ Type_op.inline_list_with_none_pos 169 | [ Inline.Plain prefix ] 170 | in 171 | let open Option in 172 | let last_plain = 173 | List.nth_opt title (List.length title - 1) 174 | >>| fun (inline_t, pos) -> 175 | ( (match inline_t with 176 | | Inline.Plain s -> Inline.Plain (String.rtrim s ^ " ") 177 | | _ -> inline_t) 178 | , pos ) 179 | in 180 | let title' = 181 | if Option.is_some last_plain then 182 | let _, butlast_title = butlast title in 183 | List.append butlast_title [ Option.get last_plain ] 184 | else 185 | title 186 | in 187 | (title', remove is_blank tags) 188 | | _ -> (title, []) 189 | else 190 | (title, []) 191 | | _ -> (title, [])) 192 | | Markdown -> (title, [])) 193 | in 194 | let anchor = 195 | anchor_link (Inline.asciis (Type_op.inline_list_strip_pos title)) 196 | in 197 | let meta = { timestamps = []; properties = [] } in 198 | Heading 199 | { level 200 | ; marker 201 | ; priority 202 | ; title 203 | ; tags 204 | ; anchor 205 | ; meta 206 | ; numbering = None 207 | ; unordered 208 | ; size 209 | }) 210 | (level config "Heading level") 211 | (if not config.parse_marker then 212 | return None 213 | else 214 | optional (ws *> marker "Heading marker")) 215 | (if not config.parse_priority then 216 | return None 217 | else 218 | optional (ws *> priority "Heading priority")) 219 | (optional (ws *> Angstrom.both pos (title config) "Heading title")) 220 | in 221 | p <* optional (end_of_line <|> end_of_input) 222 | end 223 | -------------------------------------------------------------------------------- /lib/syntax/lists0.ml: -------------------------------------------------------------------------------- 1 | open Angstrom 2 | open Parsers 3 | open Prelude 4 | open Type 5 | open Conf 6 | 7 | module MakeLists (Heading : sig 8 | val parse : Conf.t -> Type.t Angstrom.t 9 | end) = 10 | struct 11 | let indent_parser = 12 | peek_spaces_or_tabs 13 | >>| (function 14 | | s -> String.length s) 15 | <|> return 0 16 | 17 | let check_listitem config line = 18 | let indent = get_indent line in 19 | let number = 20 | try Scanf.sscanf (String.trim line) "%d" (fun x -> Some x) 21 | with _ -> None 22 | in 23 | match number with 24 | | Some number -> (indent, true, false, Some number) 25 | | None -> 26 | if String.length line - indent >= 2 then 27 | let prefix = String.sub line indent 2 in 28 | let star_condition = 29 | if is_markdown config then 30 | prefix = "* " 31 | else 32 | indent <> 0 && prefix = "* " 33 | in 34 | let is_item = 35 | if is_markdown config then 36 | prefix = "+ " || star_condition 37 | else 38 | prefix = "+ " || star_condition || prefix = "- " 39 | in 40 | 41 | let is_heading = 42 | if is_markdown config then 43 | prefix = "- " 44 | else 45 | indent = 0 && prefix = "* " 46 | in 47 | (indent, is_item, is_heading, None) 48 | else if String.length line - indent >= 1 then 49 | let prefix = String.sub line indent 1 in 50 | let is_heading = 51 | if is_markdown config then 52 | prefix = "-" 53 | else 54 | indent = 0 && prefix = "*" 55 | in 56 | (indent, false, is_heading, None) 57 | else 58 | (indent, false, false, None) 59 | 60 | let terminator items = 61 | if !items = [] then 62 | fail "list" 63 | else 64 | let result = !items in 65 | return @@ List.rev result 66 | 67 | let content_parser config list_parser content_parsers indent lines = 68 | fix (fun content_parser -> 69 | take_till1 is_eol >>= fun content -> 70 | lines := content :: !lines; 71 | two_eols (List.rev !lines, []) (* two newlines end this list *) 72 | <|> optional eol 73 | *> (peek_char >>= function 74 | | None -> return (List.rev !lines, []) 75 | | Some c -> 76 | if is_eol c then ( 77 | lines := "\n" :: !lines; 78 | eol *> content_parser 79 | ) else if is_space c then 80 | peek_line >>= fun content -> 81 | let indent', is_item, is_heading, _number = 82 | check_listitem config content 83 | in 84 | if is_heading then 85 | return (List.rev !lines, []) 86 | else if is_item then 87 | if indent' <= indent then 88 | (* breakout, another item or a new list. *) 89 | return (List.rev !lines, []) 90 | else 91 | (* list item child *) 92 | list_parser content_parsers (ref []) indent' 93 | >>= fun items -> return (List.rev !lines, items) 94 | else 95 | (* content of current item *) 96 | optional eols *> content_parser 97 | else 98 | return (List.rev !lines, []))) 99 | 100 | let format_parser config indent = 101 | let choices = 102 | if is_markdown config || indent <> 0 then 103 | char '+' <|> char '*' 104 | else 105 | char '+' <|> char '-' 106 | in 107 | let unordered_format = choices *> ws *> return None in 108 | let ordered_format = 109 | digits <* char '.' <* ws >>= fun number -> return (Some number) 110 | in 111 | unordered_format <|> ordered_format 112 | 113 | let checkbox_parser = 114 | string "[ ]" *> return (Some false) 115 | <|> string_ci "[X]" *> return (Some true) 116 | <|> return None 117 | 118 | let format_checkbox_parser config indent = 119 | lift2 120 | (fun format checkbox -> (format, checkbox)) 121 | (format_parser config indent) 122 | (checkbox_parser <* spaces) 123 | 124 | (* name :: definition *) 125 | let definition config s = 126 | let name_parser = end_string " ::" (fun s -> s) in 127 | match parse_string ~consume:All name_parser s with 128 | | Ok name -> ( 129 | let l = String.length name + 3 in 130 | let name, description = 131 | if String.length s >= l + 1 then 132 | let nc = s.[l] in 133 | if is_space nc || is_eol nc then 134 | (Some name, String.sub s l (String.length s - l)) 135 | else 136 | (None, s) 137 | else 138 | (Some name, "") 139 | in 140 | match name with 141 | | Some name -> 142 | let name = 143 | match parse_string ~consume:All (Inline.parse config) name with 144 | | Ok inlines -> inlines 145 | | Error _e -> Type_op.inline_list_with_none_pos [ Inline.Plain name ] 146 | in 147 | (name, description) 148 | | None -> ([], description)) 149 | | Error _e -> ([], s) 150 | 151 | let rec list_parser config content_parsers items last_indent = 152 | fix (fun list -> 153 | indent_parser >>= fun indent -> 154 | (* breakout, if heading found in list *) 155 | unsafe_lookahead (Heading.parse config) *> return true <|> return false 156 | >>= fun is_heading -> 157 | if last_indent > indent || is_heading then 158 | terminator items 159 | (* breakout *) 160 | else 161 | let content_parser number checkbox = 162 | content_parser config (list_parser config) content_parsers indent 163 | (ref []) 164 | >>= fun (content, children) -> 165 | let ordered = 166 | match number with 167 | | Some _ -> true 168 | | None -> false 169 | in 170 | let content = List.map String.trim content in 171 | let content = String.concat "\n" content in 172 | let name, content = 173 | if ordered then 174 | ([], content) 175 | else 176 | definition config content 177 | in 178 | let content = 179 | match parse_string ~consume:All content_parsers content with 180 | | Ok result -> 181 | let result = Paragraph.concat_paragraph_lines config result in 182 | List.map fst result 183 | | Error _e -> 184 | [ Paragraph 185 | (Type_op.inline_list_with_none_pos [ Inline.Plain content ]) 186 | ] 187 | in 188 | let item = 189 | { content 190 | ; name 191 | ; items = children 192 | ; number 193 | ; checkbox 194 | ; indent 195 | ; ordered 196 | } 197 | in 198 | items := item :: !items; 199 | list 200 | in 201 | Angstrom.take indent 202 | *> (* skip indent *) 203 | ( format_checkbox_parser config indent >>= fun (number, checkbox) -> 204 | match number with 205 | | None -> content_parser None checkbox 206 | | Some number -> 207 | content_parser (Some (int_of_string number)) checkbox ) 208 | <|> terminator items 209 | (* breakout *)) 210 | 211 | let parse_aux config content_parsers = 212 | let r = ref [] in 213 | let p = list_parser config content_parsers r 0 in 214 | optional eols *> p >>= fun result -> 215 | r := []; 216 | return @@ List result 217 | <|> 218 | let _ = r := [] in 219 | fail "list" 220 | 221 | let md_definition config = 222 | Markdown_definition.parse config >>= fun result -> return @@ List result 223 | 224 | let parse config content_parsers = 225 | match config.format with 226 | | Org -> parse_aux config content_parsers 227 | | Markdown -> parse_aux config content_parsers <|> md_definition config 228 | end 229 | -------------------------------------------------------------------------------- /lib/syntax/block0.ml: -------------------------------------------------------------------------------- 1 | open! Prelude 2 | open Angstrom 3 | open Parsers 4 | open Type 5 | open Conf 6 | open Helper 7 | open Pos 8 | 9 | module MakeBlock (Lists : sig 10 | val parse : 11 | Conf.t -> (Type.t * Pos.pos_meta) list Angstrom.t -> Type.t Angstrom.t 12 | end) = 13 | struct 14 | (* There are 2 kinds of blocks. 15 | 1. `begin ... end` 16 | #+BEGIN_X 17 | line1 18 | line 2 19 | #+END_x 20 | 21 | 2. Verbatim, each line starts with `:`. 22 | *) 23 | 24 | let results = spaces *> string "#+RESULTS:" >>= fun _ -> return Results 25 | 26 | let verbatim = lines_starts_with (char ':') "verbatim" 27 | 28 | let md_blockquote = 29 | char '>' 30 | *> lines_while 31 | (spaces *> char '>' *> spaces *> eol *> return "" 32 | <|> ( spaces *> optional (char '>') *> spaces *> line >>= fun line -> 33 | if 34 | not 35 | (starts_with line "- " || starts_with line "# " 36 | || starts_with line "id:: " || line = "-" || line = "#") 37 | then 38 | return line 39 | else 40 | fail "new block" )) 41 | "markdown blockquote" 42 | 43 | let displayed_math = 44 | string "$$" *> end_string "$$" (fun s -> Displayed_Math s) 45 | 46 | let separate_name_options = function 47 | | None -> (None, None) 48 | | Some s -> ( 49 | match String.split_on_char ' ' s with 50 | | [] -> (None, None) 51 | | [ name ] -> (Some name, None) 52 | | name :: options -> (Some name, Some options)) 53 | 54 | (* ``` json 55 | * { 56 | * "firstName": "John", 57 | * "lastName": "Smith", 58 | * "age": 25 59 | * } 60 | * ``` *) 61 | let fenced_language = 62 | (string "```" <|> string "~~~") *> spaces *> optional line <* optional eol 63 | 64 | let fenced_code_block = 65 | fenced_language >>= fun language_and_options -> 66 | let p = 67 | between_lines ~trim:false 68 | (fun line -> 69 | starts_with (String.trim line) "```" 70 | || starts_with (String.trim line) "~~~") 71 | "fenced_code_block" 72 | in 73 | let p' = with_pos_meta p in 74 | p' >>| fun (lines, { start_pos; end_pos }) -> 75 | let pos_meta = { start_pos; end_pos = end_pos - 3 } in 76 | let language, options = separate_name_options language_and_options in 77 | Src { language; options; lines; pos_meta } 78 | 79 | let block_name_options_parser = 80 | lift2 81 | (fun name options -> 82 | match options with 83 | | None 84 | | Some "" -> 85 | (name, None) 86 | | _ -> (name, options)) 87 | (string_ci "#+begin_" *> non_spaces) 88 | (spaces *> optional line) 89 | <* optional eol 90 | 91 | let list_content_parsers config block_parse = 92 | let p = 93 | choice 94 | [ Table.parse config 95 | ; block_parse 96 | ; Directive.parse 97 | ; Latex_env.parse config 98 | ; Hr.parse config 99 | ; results 100 | ; Comment.parse config 101 | ; Paragraph.parse 102 | ; Paragraph.sep 103 | ] 104 | in 105 | let p = Helper.with_pos_meta p in 106 | many1 p 107 | 108 | let block_content_parsers config block_parse = 109 | let list_content_parser = list_content_parsers config block_parse in 110 | let p = 111 | choice 112 | [ Directive.parse 113 | ; Table.parse config 114 | ; Lists.parse config list_content_parser 115 | ; block_parse 116 | ; Latex_env.parse config 117 | ; Hr.parse config 118 | ; results 119 | ; Comment.parse config 120 | ; Paragraph.parse 121 | ; Paragraph.sep 122 | ] 123 | in 124 | let p = Helper.with_pos_meta p in 125 | many1 p 126 | 127 | let block_parse config = 128 | fix (fun parse -> 129 | let p = 130 | peek_char_fail >>= function 131 | | '#' -> ( 132 | block_name_options_parser >>= fun (name, options) -> 133 | let p = 134 | between_lines ~trim:false 135 | (fun line -> 136 | let prefix = "#+end_" ^ name in 137 | starts_with (String.trim line) prefix) 138 | "block" 139 | in 140 | let p' = with_pos_meta p in 141 | p' >>| fun (lines, { start_pos; end_pos }) -> 142 | (* clear indents *) 143 | let lines = 144 | if lines = [] then 145 | [] 146 | else 147 | let indent = get_indent (List.hd lines) in 148 | if indent = 0 then 149 | lines 150 | else 151 | List.map 152 | (fun line -> 153 | let line_ltrim = String.ltrim line in 154 | if String.length line - String.length line_ltrim >= indent 155 | then 156 | safe_sub line indent (String.length line - indent) 157 | else if line_ltrim = "" then 158 | line 159 | else 160 | line_ltrim) 161 | lines 162 | in 163 | let name = String.lowercase_ascii name in 164 | match name with 165 | | "src" -> 166 | let language, options = separate_name_options options in 167 | let pos_meta = { start_pos; end_pos = end_pos - 9 } in 168 | Src { language; options; lines; pos_meta } 169 | | "example" -> Example lines 170 | | "quote" -> 171 | let content = String.concat "" lines in 172 | let result = 173 | match 174 | parse_string ~consume:All 175 | (block_content_parsers config parse) 176 | content 177 | with 178 | | Ok result -> 179 | let result = Paragraph.concat_paragraph_lines config result in 180 | List.map fst result 181 | | Error _e -> [] 182 | in 183 | Quote result 184 | | "export" -> 185 | (* export html, etc *) 186 | let name, options = separate_name_options options in 187 | let name = 188 | match name with 189 | | None -> "" 190 | | Some s -> s 191 | in 192 | let content = String.concat "" lines in 193 | Export (name, options, content) 194 | | "comment" -> CommentBlock lines 195 | | _ -> 196 | let content = String.concat "" lines in 197 | let result = 198 | match 199 | parse_string ~consume:All 200 | (block_content_parsers config parse) 201 | content 202 | with 203 | | Ok result -> 204 | let result = Paragraph.concat_paragraph_lines config result in 205 | List.map fst result 206 | | Error _e -> [] 207 | in 208 | Custom (name, options, result, content)) 209 | | ':' -> ( 210 | (* verbatim block *) 211 | match config.format with 212 | | Org -> verbatim >>| fun lines -> Example lines 213 | | Markdown -> fail "block") 214 | | '>' -> 215 | md_blockquote >>| fun lines -> 216 | let content = String.concat "" lines in 217 | let result = 218 | match 219 | parse_string ~consume:All 220 | (block_content_parsers config parse) 221 | content 222 | with 223 | | Ok result -> 224 | let result = Paragraph.concat_paragraph_lines config result in 225 | List.map fst result 226 | | Error _e -> [] 227 | in 228 | Quote result 229 | | '`' 230 | | '~' -> 231 | fenced_code_block 232 | | '$' -> displayed_math 233 | | '<' -> Raw_html.parse >>| fun s -> Raw_Html s 234 | | '[' -> 235 | if config.hiccup_in_block then 236 | Hiccup.parse >>| fun s -> Hiccup s 237 | else 238 | fail "block" 239 | | _ -> fail "block" 240 | in 241 | between_eols p) 242 | 243 | let parse config = 244 | match config.format with 245 | | Org -> block_parse config 246 | | Markdown -> block_parse config 247 | end 248 | -------------------------------------------------------------------------------- /examples/syntax.md: -------------------------------------------------------------------------------- 1 | # Markdown 语法参考 2 | 3 | ## 0. 简述 4 | 5 | Markdown 是一种 Lightweight 标记语言，易读、易写、易改，主要为了方便在 Web 端快速书写文档，由转换器转换为 HTML 呈现在 Web 页面上，最初的 Markdown 转换程序，是一个 Perl 脚本。Markdown 可以使用简单的几个字符，如 `#`, `*`, 等，编写出格式丰富的整齐化一的文档来。 6 | 7 | 现在，越来越多的 Web 程序支持 Markdown 的在线编辑和展示，如： 8 | 9 | * [GitHub](https://github.com/) 10 | * [Stack Overflow](http://stackoverflow.com/) 11 | * [Reddit](https://www.reddit.com/) 12 | * [简书](http://www.jianshu.com/) 13 | * [作业部落](https://www.zybuluo.com/) 14 | 15 | 专用于 Downdown 写作或支持该格式编写的编辑器很多，Windows 平台有 Typora, MarkdownPad, MarkPad 等。OSX 平台可选的就太多了，有 Mou, Ulysses, iA Writer, Typed, MacDown, Typora 等一系列好用的工具软件。除此之外，还有一大批如 GNU Emacs, Vim, Sublime Tex, Atom 等猿类编辑器也支持这种格式。 16 | 17 | Markdown 文件一般用 `.md` 或 `.markdown` 作为扩展名。 18 | 19 | 20 | ## 1. 标准 Markdown 21 | 22 | ### 1.1 加粗和强调 23 | 24 | ``` 25 | *emphasize* **strong** 26 | 27 | _emphasize_ __strong__ 28 | 29 | _强调是可以**嵌套**的_ 30 | ``` 31 | 32 | *emphasize* **emphasize** 33 | 34 | _emphasize_ __strong__ 35 | 36 | _强调是可以**嵌套**的_ 37 | 38 | ### 1.2 链接和Email 39 | 40 | ``` 41 | 链接到 [Github](https://github.com/ "Github"). 42 | ``` 43 | 44 | 链接到 [Github](https://github.com/ "Github"). 45 | 46 | ``` 47 | 定义链接的ID后 [example][id]，可以在文档下方再定义链接的目标地址： 48 | ``` 49 | 50 | ``` 51 | [id]: http://example.com/ "Title" 52 | ``` 53 | 54 | 定义链接的ID后 [example][id]，可以在文档下方再定义链接的目标地址： 55 | 56 | [id]: http://example.com/ "Title" 57 | 58 | 电子邮件链接： 59 | 60 | ``` 61 | 电子邮件链接实例 62 | ``` 63 | 64 | 电子邮件链接实例 65 | 66 | ### 1.3 图片 67 | 68 | ``` 69 | ![图片替换文本（禁止显示图片时会显示此文本）](/path/img.jpg "图片标题（鼠标放到图片上时会显示此文本）") 70 | ``` 71 | 72 | 图片也可以先插入到正文，之后再根据 id 定义图片的路径和显示文本： 73 | 74 | ``` 75 | ![图片替换文本（禁止显示图片时会显示此文本）][id] 76 | ``` 77 | 78 | ``` 79 | [id]: /url/to/img.jpg "图片标题（鼠标放到图片上时会显示此文本）" 80 | ``` 81 | 82 | ### 1.4 标题 83 | 84 | Markdown 支持两种标题的语法，类 Setext 和类 Atx 形式。 85 | 86 | Atx 形式最多支持6级标题： 87 | 88 | ``` 89 | # Header 1 # 90 | ## Header 2 ## 91 | ... 92 | ###### Header 6 93 | ``` 94 | 95 | 类 Setext 形式是用底线的形式，利用 = （一级标题）和 - （二级标题） 96 | 97 | ``` 98 | Header 1 99 | ======== 100 | Header 2 101 | -------- 102 | ``` 103 | 104 | 这种方式不推荐，统一使用类 Atx 形式即可。 105 | 106 | ### 1.5 列表 107 | 108 | Markdown 支持有序列表和无序列表。 109 | 110 | `
    ` 无序列表使用星号`*`、加号`+`或是减号`-`-作为列表标记： 111 | 112 | ``` 113 | * Item 1 114 | * Item 2 115 | * Item 2a 116 | * Item 2b 117 | ``` 118 | 119 | * Item 1 120 | * Item 2 121 | * Item 2a 122 | * Item 2b 123 | 124 | `
      ` 有序列表则使用数字接着一个英文句点： 125 | 126 | 有序列表和无序列表可以混合嵌套： 127 | 128 | ``` 129 | 1. Item 1 130 | 2. Item 2 131 | 3. Item 3 132 | * Item 3a 133 | * Item 3b 134 | ``` 135 | 136 | 1. Item 1 137 | 2. Item 2 138 | 3. Item 3 139 | * Item 3a 140 | * Item 3b 141 | 142 | 需要说明的一点是，你在列表标记上使用的数字并不会影响输出的 HTML 结果，上面的列表所产生的 HTML 标记为： 143 | 144 |
        145 |
      1. Bird
        2. 146 |
      2. McHale
        3. 147 |
      3. Parish
        4. 148 |
      149 | 150 | 如果你的列表标记写成： 151 | 152 | ``` 153 | 1. Bird 154 | 1. McHale 155 | 1. Parish 156 | ``` 157 | 158 | 甚至是： 159 | 160 | ``` 161 | 3. Bird 162 | 1. McHale 163 | 8. Parish 164 | ``` 165 | 166 | 你都会得到完全相同的 HTML 输出。重点在于，你可以让 Markdown 文件的列表数字和输出的结果相同，或是你懒一点，你可以完全不用在意数字的正确性。 167 | 168 | 如果你使用懒惰的写法，建议第一个项目最好还是从 1. 开始，因为 Markdown 未来可能会支持有序列表的 start 属性。 169 | 170 | 当然，项目列表很可能会不小心产生，像是下面这样的写法 171 | 172 | ``` 173 | 1986. What a great season. 174 | ``` 175 | 176 | 换句话说，也就是在行首出现数字-句点-空白，要避免这样的状况，你可以在句点前面加上反斜杠。 177 | 178 | ``` 179 | 1986\. What a great season. 180 | ``` 181 | 182 | ### 1.6 引用 183 | 184 | ``` 185 | > Email-style angle brackets 186 | > are used for blockquotes. 187 | > > And, they can be nested. 188 | > #### Headers in blockquotes 189 | > 190 | > * You can quote a list. 191 | > * Etc. 192 | ``` 193 | 194 | > Email-style angle brackets 195 | > are used for blockquotes. 196 | > > And, they can be nested. 197 | > 198 | > #### Headers in blockquotes 199 | > 200 | > * You can quote a list. 201 | > * Etc. 202 | 203 | ### 1.7 代码 204 | 205 | #### 1.7.1 行内代码 206 | 207 | ``` 208 | 行内代码 ``，也可以放在两对反引号之间：`` ``。 209 | ``` 210 | 211 | 行内代码 ``，也可以放在两对反引号之间：`` ``。 212 | 213 | #### 1.7.2 代码块 214 | 215 | 代码块每行前添加 缩进 4个空格 或 1个制表符： 216 | 217 | #!/usr/bin/perl 218 | use strict; 219 | use warnings; 220 | 221 | # first, create your message 222 | use Email::MIME; 223 | my $message = Email::MIME->create( 224 | header_str => [ 225 | From => 'you@example.com', 226 | To => 'friend@example.com', 227 | Subject => 'Happy birthday!', 228 | ], 229 | attributes => { 230 | encoding => 'quoted-printable', 231 | charset => 'ISO-8859-1', 232 | }, 233 | body_str => "Happy birthday to you!\n", 234 | ); 235 | 236 | # send the message 237 | use Email::Sender::Simple qw(sendmail); 238 | sendmail($message); 239 | 240 | 下文也会提到 GitHub 支持的可指定编程语言的代码块，带语法高亮： 241 | 242 | ``` 243 | ``` 244 | 示例输出（注意，这是 GitHub 支持的 Markdown 格式，用其他 Markdown 编辑器要能无法正常解析改代码块）： 245 | 246 | ```perl 247 | #!/usr/bin/perl 248 | use strict; 249 | use warnings; 250 | 251 | # first, create your message 252 | use Email::MIME; 253 | my $message = Email::MIME->create( 254 | header_str => [ 255 | From => 'you@example.com', 256 | To => 'friend@example.com', 257 | Subject => 'Happy birthday!', 258 | ], 259 | attributes => { 260 | encoding => 'quoted-printable', 261 | charset => 'ISO-8859-1', 262 | }, 263 | body_str => "Happy birthday to you!\n", 264 | ); 265 | 266 | # send the message 267 | use Email::Sender::Simple qw(sendmail); 268 | sendmail($message); 269 | ``` 270 | 271 | ### 1.8 换行 272 | 273 | 插入一个空白行即可 274 | 275 | ### 1.9 水平线 276 | 277 | 3个以上短线或*号： 278 | 279 | ``` 280 | --- 281 | * * * 282 | - - - - 283 | ``` 284 | 285 | ### 1.10 反斜杠 286 | 287 | Markdown 可以利用反斜杠来插入一些在语法中有其它意义的符号，例如：如果你想要用星号加在文字旁边的方式来做出强调效果（但不用 `` 标签），你可以在星号的前面加上反斜杠： 288 | 289 | ``` 290 | \*literal asterisks\* 291 | ``` 292 | 293 | Markdown 支持以下这些符号前面加上反斜杠来帮助插入普通的符号： 294 | 295 | ``` 296 | \ 反斜线 297 | ` 反引号 298 | * 星号 299 | _ 底线 300 | {} 花括号 301 | [] 方括号 302 | () 括弧 303 | # 井字号 304 | + 加号 305 | - 减号 306 | . 英文句点 307 | ! 惊叹号 308 | ``` 309 | 310 | --- 311 | 312 | ## 2. 其他语法 313 | 314 | ### 2.1 脚注 315 | 316 | ``` 317 | 这些文字带有脚注[^1] 318 | ``` 319 | [^1]: 我是脚注。 320 | 321 | ### 2.2 表格 322 | 323 | 简单表格： 324 | 325 | ``` 326 | First Header | Second Header | Third Header 327 | ------------ | ------------- | ------------ 328 | Content Cell | Content Cell | Content Cell 329 | Content Cell | Content Cell | Content Cell 330 | ``` 331 | 332 | First Header | Second Header | Third Header 333 | ------------ | ------------- | ------------ 334 | Content Cell | Content Cell | Content Cell 335 | Content Cell | Content Cell | Content Cell 336 | 337 | 也可以在行首和行尾加上 | ，效果一样： 338 | 339 | ``` 340 | | First Header | Second Header | Third Header | 341 | | ------------ | ------------- | ------------ | 342 | | Content Cell | Content Cell | Content Cell | 343 | | Content Cell | Content Cell | Content Cell | 344 | ``` 345 | 346 | | First Header | Second Header | Third Header | 347 | | ------------ | ------------- | ------------ | 348 | | Content Cell | Content Cell | Content Cell | 349 | | Content Cell | Content Cell | Content Cell | 350 | 351 | 使用英文冒号可以给列设定对齐方式： 352 | 353 | ``` 354 | First Header | Second Header | Third Header 355 | :----------- | :-----------: | -----------: 356 | Left | Center | Right 357 | Left | Center | Right 358 | ``` 359 | 360 | First Header | Second Header | Third Header 361 | :----------- | :-----------: | -----------: 362 | Left | Center | Right 363 | Left | Center | Right 364 | 365 | ### 2.3 锚点 366 | 367 | Markdown 中也可以给使用锚链接，下面这是一个普通的 H2 标题： 368 | 369 | ``` 370 | ## H2 标题实例 371 | ``` 372 | 373 | 加个 id 属性就可以给标题加上锚点： 374 | 375 | ``` 376 | ## [带锚点的 H2 实例](id:anchor1) 377 | ``` 378 | 379 | 链接到上面的锚点，我们只需要如下的语法即可： 380 | 381 | ``` 382 | 预览时点击 [锚链接](#anchor1) 383 | ``` 384 | 385 | ### 2.4 删除线 386 | 387 | ``` 388 | ~~Strikethrough~~ 389 | ``` 390 | 391 | ~~Strikethrough 实例~~ 392 | 393 | ## 3. GitHub 支持的 Markdown 语法 394 | 395 | ### 3.1 语法高亮 396 | 397 | ```javascript 398 | function fancyAlert(arg) { 399 | if(arg) { 400 | $.facebox({div:'#foo'}) 401 | } 402 | } 403 | ``` 404 | 405 | ```javascript 406 | function fancyAlert(arg) { 407 | if(arg) { 408 | $.facebox({div:'#foo'}) 409 | } 410 | } 411 | ``` 412 | 413 | GitHub 支持的编程语主高亮列表，请查看 [linguist](https://github.com/github/linguist/blob/master/lib/linguist/languages.yml)。 414 | 415 | ### 3.2 任务列表 416 | 417 | ``` 418 | - [x] @mentions, #refs, [links](), **formatting**, and tags supported 419 | - [x] list syntax required (any unordered or ordered list supported) 420 | - [x] this is a complete item 421 | - [ ] this is an incomplete item 422 | ``` 423 | 424 | - [x] @mentions, #refs, [links](), **formatting**, and tags supported 425 | - [x] list syntax required (any unordered or ordered list supported) 426 | - [x] this is a complete item 427 | - [ ] this is an incomplete item 428 | 429 | ### 3.3 SHA 引用 430 | 431 | GitHub 上每个提交都有一个 SHA-1 hash，用它在文档中添加一个指向 GitHut 提交的链接： 432 | 433 | ``` 434 | 16c999e8c71134401a78d4d46435517b2271d6ac 435 | mojombo@16c999e8c71134401a78d4d46435517b2271d6ac 436 | mojombo/github-flavored-markdown@16c999e8c71134401a78d4d46435517b2271d6ac 437 | ``` 438 | 439 | ### 3.4 同一个仓库中的 Issue 引用 440 | 441 | 类似 SHA 引用，也可以添加指定编码的仓库内 Issue 或 Pull Request 链接： 442 | 443 | ``` 444 | #1 445 | mojombo#1 446 | mojombo/github-flavored-markdown#1 447 | ``` 448 | 449 | ### 3.5 @某用户 450 | 451 | 类似微博，也可以在 GitHub Markdown 文档中添加 `@WisdomFusion` 的提醒。 452 | 453 | ### 3.6 自动链接 454 | 455 | 任何光秃秃的链接都会被自动转为链接的，如 456 | 457 | https://github.com/ 458 | 459 | ### 3.7 对 emoji 的支持 460 | 461 | 这个比较炫酷，文档中还支持 emoji！ 462 | 463 | ``` 464 | :smile: :exclamation: :thumbsup: 465 | ``` 466 | :smile: :exclamation: :thumbsup: 467 | 468 | emoji列表：http://www.emoji-cheat-sheet.com/ 469 | 470 | ## 4. 参考文档 471 | 472 | * https://guides.github.com/features/mastering-markdown/ 473 | * https://help.github.com/articles/basic-writing-and-formatting-syntax/ 474 | * http://www.markdown.cn/ 475 | -------------------------------------------------------------------------------- /lib/parsers.ml: -------------------------------------------------------------------------------- 1 | open Angstrom 2 | open Prelude 3 | 4 | let whitespace_chars = [ ' '; '\t'; '\n'; '\r'; '\012' ] 5 | 6 | let is_whitespace c = c = ' ' || c = '\t' || c = '\n' || c = '\r' || c = '\012' 7 | 8 | let space_chars = [ ' '; '\t'; '\026'; '\012' ] 9 | 10 | module CharSet = Set.Make (Char) 11 | 12 | let md_escape_chars = 13 | "!\"#$%&'()*+,-./:;<=>?@[]^_`{|}~\\" |> explode |> CharSet.of_list 14 | 15 | let is_md_escape_char c = CharSet.mem c md_escape_chars 16 | 17 | let is_space c = List.mem c space_chars 18 | 19 | let is_tab = function 20 | | '\t' -> true 21 | | _ -> false 22 | 23 | let is_tab_or_space = is_space 24 | 25 | let non_tab_or_space = not << is_tab_or_space 26 | 27 | let non_space = not << is_space 28 | 29 | let eol_chars = [ '\r'; '\n' ] 30 | 31 | let is_eol c = List.mem c eol_chars 32 | 33 | let non_eol = not << is_eol 34 | 35 | let non_space_eol c = non_space c && non_eol c 36 | 37 | let is_space_eol c = is_space c || is_eol c 38 | 39 | let is_hex = function 40 | | '0' .. '9' 41 | | 'a' .. 'f' 42 | | 'A' .. 'F' -> 43 | true 44 | | _ -> false 45 | 46 | let digits = take_while1 is_digit 47 | 48 | let eol = string "\n" <|> string "\r\n" 49 | 50 | let eols = take_while1 is_eol 51 | 52 | let two_eols result = eol *> eol *> return result 53 | 54 | let ws = take_while1 is_space 55 | 56 | let tabs = take_while1 is_tab 57 | 58 | let tabs_or_ws = take_while1 is_tab_or_space 59 | 60 | let spaces = skip_while is_space 61 | 62 | let spaces_or_eols = skip_while (fun c -> is_eol c || is_space c) 63 | 64 | let non_spaces = take_while1 non_space_eol 65 | 66 | let letters = take_while1 is_letter 67 | 68 | let count_spaces = take_while is_space 69 | 70 | let lex p = p <* spaces 71 | 72 | let optional p = option None (lift (fun x -> Some x) p) 73 | 74 | let optional_list p = option [] p 75 | 76 | let lift5 f a b c d e = lift4 f a b c d <*> e 77 | 78 | let between_char c1 c2 p = char c1 *> p <* char c2 79 | 80 | let between_string begin' end' p = string begin' *> p <* string end' 81 | 82 | let between_string_ci begin' end' p = string_ci begin' *> p <* string end' 83 | 84 | let chainl1 e op = 85 | let rec go acc = lift2 (fun f x -> f acc x) op e >>= go <|> return acc in 86 | e >>= fun init -> go init 87 | 88 | let end_string s ?(ci = false) f = 89 | let open String in 90 | let last_s = sub s (length s - 1) 1 in 91 | let prev = ref None in 92 | let string_equal x y = 93 | if ci then 94 | lowercase_ascii x = lowercase_ascii y 95 | else 96 | x = y 97 | in 98 | take_while1 (fun c -> 99 | let p = 100 | match !prev with 101 | | None -> make 1 c 102 | | Some s' -> 103 | let s' = s' ^ make 1 c in 104 | if length s' > length s then 105 | sub s' 1 (length s) 106 | else 107 | s' 108 | in 109 | prev := Some p; 110 | if string_equal p s then 111 | false 112 | else 113 | true) 114 | <* string last_s 115 | >>= fun s' -> 116 | let p = !prev in 117 | prev := None; 118 | match p with 119 | | None -> fail "end string" 120 | | Some x -> 121 | if string_equal x s then 122 | let s' = sub s' 0 (length s' - length s + 1) in 123 | return @@ f s' 124 | else 125 | fail "end_string" 126 | 127 | let end_string_2 s ?(ci = false) f = 128 | let open String in 129 | let last_s = sub s (length s - 1) 1 in 130 | let prev = ref None in 131 | let string_equal x y = 132 | if ci then 133 | lowercase_ascii x = lowercase_ascii y 134 | else 135 | x = y 136 | in 137 | take_while (fun c -> 138 | let p = 139 | match !prev with 140 | | None -> make 1 c 141 | | Some s' -> 142 | let s' = s' ^ make 1 c in 143 | if length s' > length s then 144 | sub s' 1 (length s) 145 | else 146 | s' 147 | in 148 | prev := Some p; 149 | if string_equal p s then 150 | false 151 | else 152 | true) 153 | <* string last_s 154 | >>= fun s' -> 155 | let p = !prev in 156 | prev := None; 157 | match p with 158 | | None -> fail "end string" 159 | | Some x -> 160 | if string_equal x s then 161 | let s' = sub s' 0 (length s' - length s + 1) in 162 | f s' 163 | else 164 | fail "end_string" 165 | 166 | let between_string_strict begin' end' ?(ci = false) f = 167 | string begin' *> end_string end' ~ci f 168 | 169 | let between_string_strict_wrapper ?(ci = false) begin' end' = 170 | string begin' 171 | *> end_string end' ~ci (fun s -> String.concat "" [ begin'; s; end' ]) 172 | 173 | let peek_line = take_till (fun c -> c = '\r' || c = '\n') |> unsafe_lookahead 174 | 175 | let peek_spaces = ws |> unsafe_lookahead 176 | 177 | let peek_spaces_or_tabs = tabs_or_ws |> unsafe_lookahead 178 | 179 | let take_till1 f = take_while1 (fun c -> not (f c)) 180 | 181 | let line = take_till1 is_eol 182 | 183 | let optional_line = take_till is_eol 184 | 185 | let line_without_spaces = take_till1 (fun c -> c = '\r' || c = '\n' || c = ' ') 186 | 187 | let clear_parser_resource p r error = 188 | p r >>= fun result -> 189 | r := []; 190 | return result 191 | <|> 192 | let _ = r := [] in 193 | fail error 194 | 195 | let between_lines ?(trim = true) end_check error = 196 | let p lines = 197 | fix (fun body_parser -> 198 | line <|> (eol >>| fun _ -> "\n") >>= fun line -> 199 | let line = 200 | if trim then 201 | String.trim line 202 | else 203 | line 204 | in 205 | if end_check line then 206 | let lines = List.rev !lines in 207 | return lines 208 | else 209 | let _ = lines := line :: !lines in 210 | body_parser) 211 | in 212 | clear_parser_resource p (ref []) error 213 | 214 | let between_eols p = optional eols *> optional spaces *> p <* optional eols 215 | 216 | let rec at_most m p = 217 | if m = 0 then 218 | return [] 219 | else 220 | lift2 (fun x xs -> x :: xs) p (at_most (m - 1) p) <|> return [] 221 | 222 | let limits n m p = lift2 (fun xs ys -> xs @ ys) (count n p) (at_most m p) 223 | 224 | let lines_while p = 225 | let line = p <* optional eol >>| fun s -> s ^ "\n" in 226 | many1 line 227 | 228 | let lines_starts_with p = lines_while ((spaces *> p <* spaces) *> optional_line) 229 | 230 | let lines_till p = many_till (line <* optional eol) p 231 | 232 | let one_of cl = satisfy (fun c -> List.mem c cl) 233 | 234 | let not_one_of cl = satisfy (fun c -> not (List.mem c cl)) 235 | 236 | let take_while1_include_backslash chars_can_escape f = 237 | let last_backslash = ref false in 238 | take_while1 (fun c -> 239 | if !last_backslash && List.mem c chars_can_escape then ( 240 | last_backslash := false; 241 | true 242 | ) else if !last_backslash then ( 243 | last_backslash := false; 244 | f c 245 | ) else if c = '\\' then ( 246 | last_backslash := true; 247 | true 248 | ) else 249 | f c) 250 | 251 | let page_ref, page_ref_ignore_bracket = 252 | (* allow single char ']' in pagename but "]]" *) 253 | let page_name_part = 254 | take_while1_include_backslash [ ']' ] (fun c -> non_eol c && c <> ']') 255 | <|> ( available >>= fun len -> 256 | if len < 2 then 257 | fail "page_name_part" 258 | else 259 | peek_string 2 >>= fun s -> 260 | if is_eol s.[0] then 261 | fail "page_name_part2" 262 | else if s = "]]" then 263 | fail "page_name_part3" 264 | else 265 | return s >>= fun _ -> any_char >>| String.make 1 ) 266 | in 267 | let page_name = 268 | fix (fun m -> List.cons <$> page_name_part <*> m <|> return []) 269 | >>| String.concat "" 270 | >>= fun s -> 271 | if String.length s = 0 then 272 | fail "page_name" 273 | else 274 | return s 275 | in 276 | let p = list [ string "[["; page_name; string "]]" ] in 277 | (p >>| String.concat "", p >>| fun l -> List.nth l 1) 278 | 279 | let block_ref, block_ref_ignore_bracket = 280 | let p = 281 | list 282 | [ string "((" 283 | ; take_while1 (function 284 | | ')' -> false 285 | | _ -> true) 286 | ; string "))" 287 | ] 288 | in 289 | (p >>| String.concat "", p >>| fun l -> List.nth l 1) 290 | 291 | let any_char_string = String.make 1 <$> any_char 292 | 293 | let string_contains_balanced_brackets ?(escape_chars = []) 294 | ?(excluded_ending_chars = []) bracket_pair other_delims = 295 | let left, right = unzip bracket_pair in 296 | fix (fun (m : string list list t) -> 297 | choice 298 | [ (fun s l -> [ List.cons s (List.flatten l) ]) 299 | <$> take_while1_include_backslash escape_chars (fun c -> 300 | (not @@ List.mem c other_delims) 301 | && (not @@ List.mem c excluded_ending_chars) 302 | && (not (List.mem c left)) 303 | && not (List.mem c right)) 304 | <*> m 305 | ; ( peek_char >>= fun c -> 306 | match c with 307 | | None -> fail "finish" 308 | | Some c when List.mem c left -> 309 | (fun left l right -> [ [ left ]; List.flatten l; right ]) 310 | <$> any_char_string <*> m 311 | <*> (char (List.assoc c bracket_pair) 312 | >>= (fun c -> 313 | (fun right l -> List.cons right (List.flatten l)) 314 | <$> return (String.make 1 c) 315 | <*> m) 316 | <|> return []) 317 | | Some c when List.mem c excluded_ending_chars -> 318 | available >>= fun len -> 319 | if len < 2 then 320 | fail "finish" 321 | else 322 | peek_string 2 >>= fun s -> 323 | let s1 = s.[1] in 324 | if List.mem s1 other_delims then 325 | fail "finish" 326 | else 327 | (fun c l -> [ [ c ]; List.flatten l ]) 328 | <$> any_char_string <*> m 329 | | Some _ -> fail "delims" ) 330 | ; return [ [] ] 331 | ]) 332 | >>| (String.concat "" << List.flatten) 333 | -------------------------------------------------------------------------------- /lib/zip.ml: -------------------------------------------------------------------------------- 1 | open Prelude 2 | open Option 3 | 4 | module type S = sig 5 | type 'a t 6 | 7 | type 'a l = 8 | | Leaf of 'a 9 | | Branch of 'a l list 10 | 11 | val leaf : 'a -> 'a l 12 | 13 | val branch : 'a l list -> 'a l 14 | 15 | val of_l : 'a l -> 'a t 16 | 17 | val of_list : 'a list -> 'a t 18 | 19 | val node : 'a t -> 'a l 20 | 21 | val is_branch : 'a t -> bool 22 | 23 | val children : 'a t -> 'a l list option 24 | 25 | val children_exn : 'a t -> 'a l list 26 | 27 | val path : 'a t -> 'a l list 28 | 29 | val lefts : 'a t -> 'a l list 30 | 31 | val rights : 'a t -> 'a l list 32 | 33 | val down : 'a t -> 'a t option 34 | 35 | val up : 'a t -> 'a t option 36 | 37 | val root : 'a t -> 'a l 38 | 39 | val right : 'a t -> 'a t option 40 | 41 | val rightmost : 'a t -> 'a t 42 | 43 | val left : 'a t -> 'a t option 44 | 45 | val leftmost : 'a t -> 'a t 46 | 47 | val insert_left : 'a t -> item:'a l -> 'a t option 48 | 49 | val insert_right : 'a t -> item:'a l -> 'a t option 50 | 51 | val insert_lefts : 'a t -> items:'a l list -> 'a t option 52 | 53 | val insert_rights : 'a t -> items:'a l list -> 'a t option 54 | 55 | val replace : 'a t -> item:'a l -> 'a t 56 | 57 | val edit : 'a t -> f:('a l -> 'a l) -> 'a t 58 | 59 | val insert_child : 'a t -> item:'a l -> 'a t option 60 | 61 | val append_child : 'a t -> item:'a l -> 'a t option 62 | 63 | val next : 'a t -> 'a t 64 | 65 | val prev : 'a t -> 'a t option 66 | 67 | val is_end : 'a t -> bool 68 | 69 | val remove : 'a t -> 'a t option 70 | end 71 | 72 | module Zipper : S = struct 73 | type 'a l = 74 | | Leaf of 'a 75 | | Branch of 'a l list 76 | 77 | type 'a ppath = 78 | { left : 'a l list 79 | ; right : 'a l list 80 | ; pnodes : 'a l list 81 | ; ppath : 'a ppath option 82 | ; changed : bool 83 | } 84 | 85 | type 'a t = 86 | { value : 'a l 87 | ; ppath : 'a ppath option 88 | ; left : 'a l list 89 | ; right : 'a l list 90 | ; pnodes : 'a l list 91 | ; changed : bool 92 | ; end' : bool 93 | } 94 | 95 | (* internal helpers *) 96 | 97 | let leaf a = Leaf a 98 | 99 | let branch a = Branch a 100 | 101 | let bool_to_option = function 102 | | true -> Some () 103 | | false -> None 104 | 105 | let list_to_option l = 106 | match l with 107 | | [] -> None 108 | | h :: t -> Some (h, t) 109 | 110 | let butlast l = 111 | match List.rev l with 112 | | [] -> (None, []) 113 | | [ h ] -> (Some h, []) 114 | | h :: t -> (Some h, List.rev t) 115 | 116 | let rec concat_rev l_rev r = 117 | match l_rev with 118 | | [] -> r 119 | | h :: t -> concat_rev t (h :: r) 120 | 121 | (* APIs *) 122 | 123 | let of_l (value : 'a l) = 124 | { value 125 | ; ppath = None 126 | ; left = [] 127 | ; right = [] 128 | ; pnodes = [] 129 | ; changed = false 130 | ; end' = false 131 | } 132 | 133 | let of_list l = 134 | let value = branch @@ List.map (fun e -> leaf e) l in 135 | of_l value 136 | 137 | let node t = t.value 138 | 139 | let is_branch t = 140 | match node t with 141 | | Branch _ -> true 142 | | Leaf _ -> false 143 | 144 | let children t = 145 | if is_branch t then 146 | match node t with 147 | | Branch l -> Some l 148 | | Leaf _ -> failwith "unreachable" 149 | else 150 | None 151 | 152 | let children_exn t = 153 | match children t with 154 | | Some v -> v 155 | | None -> failwith "called children on a leaf node" 156 | 157 | let path t = t.pnodes 158 | 159 | let lefts t = t.left 160 | 161 | let rights t = t.right 162 | 163 | let down t = 164 | bool_to_option (not t.end') >>= fun () -> 165 | bool_to_option (is_branch t) >>= fun () -> 166 | let node = node t in 167 | let cs = get (children t) in 168 | match cs with 169 | | c :: cnext -> 170 | let value = c in 171 | let left = [] in 172 | let right = cnext in 173 | let pnodes = node :: t.pnodes in 174 | let ppath' = 175 | { left = t.left 176 | ; right = t.right 177 | ; pnodes = t.pnodes 178 | ; changed = t.changed 179 | ; ppath = t.ppath 180 | } 181 | in 182 | Some 183 | { value 184 | ; left 185 | ; right 186 | ; pnodes 187 | ; changed = false 188 | ; ppath = Some ppath' 189 | ; end' = false 190 | } 191 | | [] -> None 192 | 193 | let up t = 194 | bool_to_option (not t.end') >>= fun () -> 195 | list_to_option t.pnodes >>= fun (hnode, _) -> 196 | let left = map_default (fun (ppath : 'a ppath) -> ppath.left) [] t.ppath in 197 | let right = 198 | map_default (fun (ppath : 'a ppath) -> ppath.right) [] t.ppath 199 | in 200 | let pnodes = 201 | map_default (fun (ppath : 'a ppath) -> ppath.pnodes) [] t.ppath 202 | in 203 | let ppath = 204 | map_default (fun (ppath : 'a ppath) -> ppath.ppath) None t.ppath 205 | in 206 | if t.changed then 207 | let value = 208 | branch @@ List.concat [ List.rev t.left; t.value :: t.right ] 209 | in 210 | let changed = t.changed in 211 | Some { value; left; right; pnodes; changed; ppath; end' = false } 212 | else 213 | let value = hnode in 214 | let changed = 215 | map_default (fun (ppath : 'a ppath) -> ppath.changed) false t.ppath 216 | in 217 | Some { value; left; right; pnodes; changed; ppath; end' = false } 218 | 219 | let rec root t = 220 | if t.end' then 221 | node t 222 | else 223 | match up t with 224 | | Some up_t -> root up_t 225 | | None -> node t 226 | 227 | let right t = 228 | bool_to_option (not t.end') >>= fun () -> 229 | list_to_option t.right >>= fun (r, rs) -> 230 | let left = t.value :: t.left in 231 | let value = r in 232 | let right = rs in 233 | Some { t with value; left; right } 234 | 235 | (** Returns the loc of the rightmost sibling of the node at this loc, or self *) 236 | let rightmost t = 237 | let last, butlast = butlast t.right in 238 | match last with 239 | | None -> t 240 | | Some last' -> 241 | let value = last' in 242 | let left = concat_rev butlast (t.value :: t.left) in 243 | let right = [] in 244 | { t with value; left; right } 245 | 246 | let left t = 247 | bool_to_option (not t.end') >>= fun () -> 248 | list_to_option t.left >>= fun (l, ls) -> 249 | let left = ls in 250 | let value = l in 251 | let right = t.value :: t.right in 252 | Some { t with value; left; right } 253 | 254 | (** Returns the loc of the leftmost sibling of the node at this loc, or self *) 255 | let leftmost t = 256 | let last, butlast = butlast t.left in 257 | match last with 258 | | None -> t 259 | | Some last' -> 260 | let value = last' in 261 | let left = [] in 262 | let right = concat_rev butlast (t.value :: t.right) in 263 | { t with value; left; right } 264 | 265 | let insert_left t ~item = 266 | bool_to_option (not t.end') >>= fun () -> 267 | list_to_option t.pnodes >>= fun _ -> 268 | let left = item :: t.left in 269 | Some { t with left; changed = true } 270 | 271 | let insert_right t ~item = 272 | bool_to_option (not t.end') >>= fun () -> 273 | list_to_option t.pnodes >>= fun _ -> 274 | let right = item :: t.right in 275 | Some { t with right; changed = true } 276 | 277 | (** insert_lefts t [a;b;c] -> 278 | [t.lefts;c;b;a,;t.rights] *) 279 | let insert_lefts t ~items = 280 | bool_to_option (not t.end') >>= fun () -> 281 | list_to_option t.pnodes >>= fun _ -> 282 | let left = items @ t.left in 283 | Some { t with left; changed = true } 284 | 285 | (* insert_rights t [a;b;c] -> 286 | [t.lefts;;a;b;c;t.rights] *) 287 | let insert_rights t ~items = 288 | bool_to_option (not t.end') >>= fun () -> 289 | list_to_option t.pnodes >>= fun _ -> 290 | let right = items @ t.right in 291 | Some { t with right; changed = true } 292 | 293 | let replace t ~item = { t with value = item; changed = true } 294 | 295 | let edit t ~f = replace t ~item:(f (node t)) 296 | 297 | (** Inserts the item as the leftmost child of the node at this loc, without moving *) 298 | let insert_child t ~item = 299 | children t >>= fun children -> 300 | some @@ replace t ~item:(branch (item :: children)) 301 | 302 | (** Inserts the item as the rightmost child of the node at this loc, without moving *) 303 | let append_child t ~item = 304 | children t >>= fun children -> 305 | some @@ replace t ~item:(branch (List.append children [ item ])) 306 | 307 | let rec next_up_aux t = 308 | match up t with 309 | | Some t' -> ( 310 | match right t' with 311 | | Some t'' -> t'' 312 | | None -> next_up_aux t') 313 | | None -> 314 | { value = node t 315 | ; ppath = None 316 | ; left = [] 317 | ; right = [] 318 | ; pnodes = [] 319 | ; changed = false 320 | ; end' = true 321 | } 322 | 323 | let next t = 324 | if t.end' then 325 | t 326 | else 327 | match down t with 328 | | Some t' -> t' 329 | | None -> ( 330 | match right t with 331 | | Some t' -> t' 332 | | None -> next_up_aux t) 333 | 334 | let rec prev_aux t = 335 | match down t with 336 | | Some t' -> prev_aux (rightmost t') 337 | | None -> t 338 | 339 | let prev t = 340 | match left t with 341 | | Some t' -> some @@ prev_aux t' 342 | | None -> up t 343 | 344 | let is_end t = t.end' 345 | 346 | (** Removes the node at loc, returning the loc that would have preceded it in a depth-first walk. *) 347 | let remove t = 348 | (* not at top level *) 349 | list_to_option t.pnodes >>= fun _ -> 350 | t.ppath >>= fun ppath -> 351 | match t.left with 352 | | l :: ls -> 353 | let left = ls in 354 | let value = l in 355 | let changed = true in 356 | some @@ prev_aux { t with left; value; changed } 357 | | [] -> 358 | let value = branch t.right in 359 | let changed = true in 360 | let left = ppath.left in 361 | let right = ppath.right in 362 | let ppath' = ppath.ppath in 363 | let pnodes = ppath.pnodes in 364 | some @@ { t with value; left; right; changed; pnodes; ppath = ppath' } 365 | end 366 | 367 | include Zipper 368 | -------------------------------------------------------------------------------- /js/lib.ml: -------------------------------------------------------------------------------- 1 | open Mldoc 2 | open Mldoc.Parser 3 | open Angstrom 4 | open Js_of_ocaml 5 | open! Prelude 6 | 7 | let ast_to_json ast = Type.blocks_to_yojson ast |> Yojson.Safe.to_string 8 | 9 | let ast_with_content_to_json ast = 10 | Opml_parser.headers_and_blocks_to_yojson ast |> Yojson.Safe.to_string 11 | 12 | let generate backend ?refs config doc output = 13 | let export = Exporters.find backend in 14 | Exporters.run export ~refs config doc output 15 | 16 | let mldoc_object = 17 | object%js 18 | method parseJson input config_json = 19 | let config_json = Js.to_string config_json in 20 | let config_json = Yojson.Safe.from_string config_json in 21 | match Conf.of_yojson config_json with 22 | | Ok config -> ( 23 | try 24 | let str = Js.to_string input in 25 | parse config str |> ast_to_json |> Js.string 26 | with error -> 27 | print_endline (Printexc.to_string error); 28 | input) 29 | | Error e -> Js_of_ocaml.Js.string ("Config error: " ^ e) 30 | 31 | method parseInlineJson input config_json = 32 | let config_json = Js.to_string config_json in 33 | let config_json = Yojson.Safe.from_string config_json in 34 | match Conf.of_yojson config_json with 35 | | Ok config -> ( 36 | let str = Js.to_string input in 37 | match parse_string ~consume:All (Mldoc.Inline.parse config) str with 38 | | Ok result -> 39 | Mldoc.Type.inline_list_to_yojson result 40 | |> Yojson.Safe.to_string |> Js.string 41 | | Error e -> 42 | print_endline e; 43 | input) 44 | | Error e -> Js_of_ocaml.Js.string ("Config error: " ^ e) 45 | 46 | method parseOPML input = 47 | let str = Js.to_string input in 48 | try Opml_parser.parse str |> ast_with_content_to_json |> Js.string 49 | with error -> 50 | print_endline (Printexc.to_string error); 51 | input 52 | 53 | method getReferences input config_json = 54 | let str = Js.to_string input in 55 | let config_json = Js.to_string config_json in 56 | let config_json = Yojson.Safe.from_string config_json in 57 | match Conf.of_yojson config_json with 58 | | Ok config -> ( 59 | let result = Mldoc.Property.property_references config str in 60 | Mldoc.Type.inline_list_no_pos_to_yojson result |> Yojson.Safe.to_string |> Js.string) 61 | | Error e -> 62 | Js_of_ocaml.Js.string ("Config error: " ^ e) 63 | 64 | method export to_format input config_json references = 65 | let to_format = Js.to_string to_format in 66 | let str = Js.to_string input in 67 | let config_json = Js.to_string config_json in 68 | let references_json = 69 | Js.to_string references |> Yojson.Safe.from_string 70 | in 71 | let buffer = Buffer.create 1024 in 72 | let config_json = Yojson.Safe.from_string config_json in 73 | match 74 | (Conf.of_yojson config_json, Reference.of_yojson references_json) 75 | with 76 | | Ok config, references -> 77 | let embed_blocks, embed_pages = 78 | match references with 79 | | Ok references -> (references.embed_blocks, references.embed_pages) 80 | | Error _ -> ([], []) 81 | in 82 | let ast = parse config str in 83 | let parsed_embed_blocks = 84 | List.map 85 | (fun (k, (content_include_children, content)) -> 86 | ( k 87 | , ( fst @@ unzip @@ parse config content_include_children 88 | , fst @@ unzip @@ parse config content ) )) 89 | embed_blocks 90 | in 91 | let parsed_embed_pages = 92 | List.map 93 | (fun (k, v) -> (k, fst @@ unzip @@ parse config v)) 94 | embed_pages 95 | in 96 | let refs : Reference.parsed_t = 97 | { parsed_embed_blocks; parsed_embed_pages } 98 | in 99 | let document = Document.from_ast None ast in 100 | let _ = 101 | Sys_js.set_channel_flusher stdout (fun s -> 102 | Buffer.add_string buffer s) 103 | in 104 | generate to_format ~refs config document stdout; 105 | flush stdout; 106 | Js_of_ocaml.Js.string (Buffer.contents buffer) 107 | | Error error, _ -> Js_of_ocaml.Js.string error 108 | 109 | method parseAndExportMarkdown input config_json references = 110 | let str = Js.to_string input in 111 | let config_json = Js.to_string config_json in 112 | let references_json = 113 | Js.to_string references |> Yojson.Safe.from_string 114 | in 115 | let buffer = Buffer.create 1024 in 116 | let config_json = Yojson.Safe.from_string config_json in 117 | match 118 | (Conf.of_yojson config_json, Reference.of_yojson references_json) 119 | with 120 | | Ok config, Ok references -> 121 | let ast = parse config str in 122 | let parsed_embed_blocks = 123 | List.map 124 | (fun (k, (content_include_children, content)) -> 125 | ( k 126 | , ( fst @@ unzip @@ parse config content_include_children 127 | , fst @@ unzip @@ parse config content ) )) 128 | references.embed_blocks 129 | in 130 | let parsed_embed_pages = 131 | List.map 132 | (fun (k, v) -> (k, fst @@ unzip @@ parse config v)) 133 | references.embed_pages 134 | in 135 | let refs : Reference.parsed_t = 136 | { parsed_embed_blocks; parsed_embed_pages } 137 | in 138 | let document = Document.from_ast None ast in 139 | let _ = 140 | Sys_js.set_channel_flusher stdout (fun s -> 141 | Buffer.add_string buffer s) 142 | in 143 | generate "markdown" ~refs config document stdout; 144 | flush stdout; 145 | Js_of_ocaml.Js.string (Buffer.contents buffer) 146 | | Error error, _ -> Js_of_ocaml.Js.string error 147 | | _, Error error -> Js_of_ocaml.Js.string error 148 | 149 | method parseAndExportOPML input config_json title references = 150 | let str = Js.to_string input in 151 | let config_json = Js.to_string config_json in 152 | let config_json = Yojson.Safe.from_string config_json in 153 | let title = Js.to_string title in 154 | let references_json = 155 | Js.to_string references |> Yojson.Safe.from_string 156 | in 157 | let buffer = Buffer.create 1024 in 158 | match 159 | (Conf.of_yojson config_json, Reference.of_yojson references_json) 160 | with 161 | | Ok config, Ok references -> 162 | let ast = parse config str in 163 | let document = Document.from_ast (Some title) ast in 164 | let parsed_embed_blocks = 165 | List.map 166 | (fun (k, (content_include_children, content)) -> 167 | ( k 168 | , ( fst @@ unzip @@ parse config content_include_children 169 | , fst @@ unzip @@ parse config content ) )) 170 | references.embed_blocks 171 | in 172 | let parsed_embed_pages = 173 | List.map 174 | (fun (k, v) -> (k, fst @@ unzip @@ parse config v)) 175 | references.embed_pages 176 | in 177 | let refs : Reference.parsed_t = 178 | { parsed_embed_blocks; parsed_embed_pages } 179 | in 180 | let _ = 181 | Sys_js.set_channel_flusher stdout (fun s -> 182 | Buffer.add_string buffer s) 183 | in 184 | generate "opml" ~refs config document stdout; 185 | flush stdout; 186 | Js.string (Buffer.contents buffer) 187 | | Error error, _ -> Js.string ("json->config err: " ^ error) 188 | | _, Error error -> Js.string ("json->refs err: " ^ error) 189 | 190 | method astExportMarkdown ast config_json references = 191 | let ast = Js.to_string ast |> Yojson.Safe.from_string in 192 | let config_json = Js.to_string config_json |> Yojson.Safe.from_string in 193 | let references_json = 194 | Js.to_string references |> Yojson.Safe.from_string 195 | in 196 | let buffer = Buffer.create 1024 in 197 | match 198 | ( Conf.of_yojson config_json 199 | , Reference.of_yojson references_json 200 | , Type.blocks_of_yojson ast ) 201 | with 202 | | Ok config, Ok references, Ok ast -> 203 | let parsed_embed_blocks = 204 | List.map 205 | (fun (k, (content_include_children, content)) -> 206 | ( k 207 | , ( fst @@ unzip @@ parse config content_include_children 208 | , fst @@ unzip @@ parse config content ) )) 209 | references.embed_blocks 210 | in 211 | let parsed_embed_pages = 212 | List.map 213 | (fun (k, v) -> (k, fst @@ unzip @@ parse config v)) 214 | references.embed_pages 215 | in 216 | let refs : Reference.parsed_t = 217 | { parsed_embed_blocks; parsed_embed_pages } 218 | in 219 | let document = Document.from_ast None ast in 220 | let _ = 221 | Sys_js.set_channel_flusher stdout (fun s -> 222 | Buffer.add_string buffer s) 223 | in 224 | generate "markdown" ~refs config document stdout; 225 | flush stdout; 226 | Js_of_ocaml.Js.string (Buffer.contents buffer) 227 | | Error error, _, _ -> Js_of_ocaml.Js.string ("json->config err: " ^ error) 228 | | _, Error error, _ -> 229 | Js_of_ocaml.Js.string ("json->references err: " ^ error) 230 | | _, _, Error error -> Js_of_ocaml.Js.string ("json->ast err: " ^ error) 231 | 232 | method anchorLink s = 233 | let s = Js.to_string s in 234 | Js_of_ocaml.Js.string (Type_parser.Heading.anchor_link s) 235 | 236 | method timestampToString input = 237 | let str = Js.to_string input in 238 | let json = Yojson.Safe.from_string str in 239 | match Timestamp.of_yojson json with 240 | | Ok t -> Timestamp.to_string t |> Js.string 241 | | Error error -> Js_of_ocaml.Js.string error 242 | 243 | method rangeToString input = 244 | let str = Js.to_string input in 245 | let json = Yojson.Safe.from_string str in 246 | match Range.of_yojson json with 247 | | Ok t -> Range.to_string t |> Js.string 248 | | Error error -> Js_of_ocaml.Js.string error 249 | end 250 | 251 | let _ = Js.export "Mldoc" mldoc_object 252 | -------------------------------------------------------------------------------- /js/package/yarn.lock: -------------------------------------------------------------------------------- 1 | # THIS IS AN AUTOGENERATED FILE. DO NOT EDIT THIS FILE DIRECTLY. 2 | # yarn lockfile v1 3 | 4 | 5 | ansi-regex@^2.0.0: 6 | version "2.1.1" 7 | resolved "https://registry.yarnpkg.com/ansi-regex/-/ansi-regex-2.1.1.tgz#c3b33ab5ee360d86e0e628f0468ae7ef27d654df" 8 | 9 | ansi-regex@^3.0.0: 10 | version "3.0.0" 11 | resolved "https://registry.yarnpkg.com/ansi-regex/-/ansi-regex-3.0.0.tgz#ed0317c322064f79466c02966bddb605ab37d998" 12 | 13 | camelcase@^5.0.0: 14 | version "5.0.0" 15 | resolved "https://registry.yarnpkg.com/camelcase/-/camelcase-5.0.0.tgz#03295527d58bd3cd4aa75363f35b2e8d97be2f42" 16 | 17 | cliui@^4.0.0: 18 | version "4.1.0" 19 | resolved "https://registry.yarnpkg.com/cliui/-/cliui-4.1.0.tgz#348422dbe82d800b3022eef4f6ac10bf2e4d1b49" 20 | dependencies: 21 | string-width "^2.1.1" 22 | strip-ansi "^4.0.0" 23 | wrap-ansi "^2.0.0" 24 | 25 | code-point-at@^1.0.0: 26 | version "1.1.0" 27 | resolved "https://registry.yarnpkg.com/code-point-at/-/code-point-at-1.1.0.tgz#0d070b4d043a5bea33a2f1a40e2edb3d9a4ccf77" 28 | 29 | cross-spawn@^6.0.0: 30 | version "6.0.5" 31 | resolved "https://registry.yarnpkg.com/cross-spawn/-/cross-spawn-6.0.5.tgz#4a5ec7c64dfae22c3a14124dbacdee846d80cbc4" 32 | dependencies: 33 | nice-try "^1.0.4" 34 | path-key "^2.0.1" 35 | semver "^5.5.0" 36 | shebang-command "^1.2.0" 37 | which "^1.2.9" 38 | 39 | decamelize@^1.2.0: 40 | version "1.2.0" 41 | resolved "https://registry.yarnpkg.com/decamelize/-/decamelize-1.2.0.tgz#f6534d15148269b20352e7bee26f501f9a191290" 42 | 43 | execa@^0.10.0: 44 | version "0.10.0" 45 | resolved "https://registry.yarnpkg.com/execa/-/execa-0.10.0.tgz#ff456a8f53f90f8eccc71a96d11bdfc7f082cb50" 46 | dependencies: 47 | cross-spawn "^6.0.0" 48 | get-stream "^3.0.0" 49 | is-stream "^1.1.0" 50 | npm-run-path "^2.0.0" 51 | p-finally "^1.0.0" 52 | signal-exit "^3.0.0" 53 | strip-eof "^1.0.0" 54 | 55 | find-up@^3.0.0: 56 | version "3.0.0" 57 | resolved "https://registry.yarnpkg.com/find-up/-/find-up-3.0.0.tgz#49169f1d7993430646da61ecc5ae355c21c97b73" 58 | dependencies: 59 | locate-path "^3.0.0" 60 | 61 | get-caller-file@^1.0.1: 62 | version "1.0.3" 63 | resolved "https://registry.yarnpkg.com/get-caller-file/-/get-caller-file-1.0.3.tgz#f978fa4c90d1dfe7ff2d6beda2a515e713bdcf4a" 64 | 65 | get-stream@^3.0.0: 66 | version "3.0.0" 67 | resolved "http://registry.npmjs.org/get-stream/-/get-stream-3.0.0.tgz#8e943d1358dc37555054ecbe2edb05aa174ede14" 68 | 69 | invert-kv@^2.0.0: 70 | version "2.0.0" 71 | resolved "https://registry.yarnpkg.com/invert-kv/-/invert-kv-2.0.0.tgz#7393f5afa59ec9ff5f67a27620d11c226e3eec02" 72 | 73 | is-fullwidth-code-point@^1.0.0: 74 | version "1.0.0" 75 | resolved "https://registry.yarnpkg.com/is-fullwidth-code-point/-/is-fullwidth-code-point-1.0.0.tgz#ef9e31386f031a7f0d643af82fde50c457ef00cb" 76 | dependencies: 77 | number-is-nan "^1.0.0" 78 | 79 | is-fullwidth-code-point@^2.0.0: 80 | version "2.0.0" 81 | resolved "https://registry.yarnpkg.com/is-fullwidth-code-point/-/is-fullwidth-code-point-2.0.0.tgz#a3b30a5c4f199183167aaab93beefae3ddfb654f" 82 | 83 | is-stream@^1.1.0: 84 | version "1.1.0" 85 | resolved "https://registry.yarnpkg.com/is-stream/-/is-stream-1.1.0.tgz#12d4a3dd4e68e0b79ceb8dbc84173ae80d91ca44" 86 | 87 | isexe@^2.0.0: 88 | version "2.0.0" 89 | resolved "https://registry.yarnpkg.com/isexe/-/isexe-2.0.0.tgz#e8fbf374dc556ff8947a10dcb0572d633f2cfa10" 90 | 91 | lcid@^2.0.0: 92 | version "2.0.0" 93 | resolved "https://registry.yarnpkg.com/lcid/-/lcid-2.0.0.tgz#6ef5d2df60e52f82eb228a4c373e8d1f397253cf" 94 | dependencies: 95 | invert-kv "^2.0.0" 96 | 97 | locate-path@^3.0.0: 98 | version "3.0.0" 99 | resolved "https://registry.yarnpkg.com/locate-path/-/locate-path-3.0.0.tgz#dbec3b3ab759758071b58fe59fc41871af21400e" 100 | dependencies: 101 | p-locate "^3.0.0" 102 | path-exists "^3.0.0" 103 | 104 | map-age-cleaner@^0.1.1: 105 | version "0.1.3" 106 | resolved "https://registry.yarnpkg.com/map-age-cleaner/-/map-age-cleaner-0.1.3.tgz#7d583a7306434c055fe474b0f45078e6e1b4b92a" 107 | dependencies: 108 | p-defer "^1.0.0" 109 | 110 | mem@^4.0.0: 111 | version "4.0.0" 112 | resolved "https://registry.yarnpkg.com/mem/-/mem-4.0.0.tgz#6437690d9471678f6cc83659c00cbafcd6b0cdaf" 113 | dependencies: 114 | map-age-cleaner "^0.1.1" 115 | mimic-fn "^1.0.0" 116 | p-is-promise "^1.1.0" 117 | 118 | mimic-fn@^1.0.0: 119 | version "1.2.0" 120 | resolved "https://registry.yarnpkg.com/mimic-fn/-/mimic-fn-1.2.0.tgz#820c86a39334640e99516928bd03fca88057d022" 121 | 122 | nice-try@^1.0.4: 123 | version "1.0.5" 124 | resolved "https://registry.yarnpkg.com/nice-try/-/nice-try-1.0.5.tgz#a3378a7696ce7d223e88fc9b764bd7ef1089e366" 125 | 126 | npm-run-path@^2.0.0: 127 | version "2.0.2" 128 | resolved "https://registry.yarnpkg.com/npm-run-path/-/npm-run-path-2.0.2.tgz#35a9232dfa35d7067b4cb2ddf2357b1871536c5f" 129 | dependencies: 130 | path-key "^2.0.0" 131 | 132 | number-is-nan@^1.0.0: 133 | version "1.0.1" 134 | resolved "https://registry.yarnpkg.com/number-is-nan/-/number-is-nan-1.0.1.tgz#097b602b53422a522c1afb8790318336941a011d" 135 | 136 | os-locale@^3.0.0: 137 | version "3.0.1" 138 | resolved "https://registry.yarnpkg.com/os-locale/-/os-locale-3.0.1.tgz#3b014fbf01d87f60a1e5348d80fe870dc82c4620" 139 | dependencies: 140 | execa "^0.10.0" 141 | lcid "^2.0.0" 142 | mem "^4.0.0" 143 | 144 | p-defer@^1.0.0: 145 | version "1.0.0" 146 | resolved "https://registry.yarnpkg.com/p-defer/-/p-defer-1.0.0.tgz#9f6eb182f6c9aa8cd743004a7d4f96b196b0fb0c" 147 | 148 | p-finally@^1.0.0: 149 | version "1.0.0" 150 | resolved "https://registry.yarnpkg.com/p-finally/-/p-finally-1.0.0.tgz#3fbcfb15b899a44123b34b6dcc18b724336a2cae" 151 | 152 | p-is-promise@^1.1.0: 153 | version "1.1.0" 154 | resolved "http://registry.npmjs.org/p-is-promise/-/p-is-promise-1.1.0.tgz#9c9456989e9f6588017b0434d56097675c3da05e" 155 | 156 | p-limit@^2.0.0: 157 | version "2.0.0" 158 | resolved "https://registry.yarnpkg.com/p-limit/-/p-limit-2.0.0.tgz#e624ed54ee8c460a778b3c9f3670496ff8a57aec" 159 | dependencies: 160 | p-try "^2.0.0" 161 | 162 | p-locate@^3.0.0: 163 | version "3.0.0" 164 | resolved "https://registry.yarnpkg.com/p-locate/-/p-locate-3.0.0.tgz#322d69a05c0264b25997d9f40cd8a891ab0064a4" 165 | dependencies: 166 | p-limit "^2.0.0" 167 | 168 | p-try@^2.0.0: 169 | version "2.0.0" 170 | resolved "https://registry.yarnpkg.com/p-try/-/p-try-2.0.0.tgz#85080bb87c64688fa47996fe8f7dfbe8211760b1" 171 | 172 | path-exists@^3.0.0: 173 | version "3.0.0" 174 | resolved "https://registry.yarnpkg.com/path-exists/-/path-exists-3.0.0.tgz#ce0ebeaa5f78cb18925ea7d810d7b59b010fd515" 175 | 176 | path-key@^2.0.0, path-key@^2.0.1: 177 | version "2.0.1" 178 | resolved "https://registry.yarnpkg.com/path-key/-/path-key-2.0.1.tgz#411cadb574c5a140d3a4b1910d40d80cc9f40b40" 179 | 180 | require-directory@^2.1.1: 181 | version "2.1.1" 182 | resolved "https://registry.yarnpkg.com/require-directory/-/require-directory-2.1.1.tgz#8c64ad5fd30dab1c976e2344ffe7f792a6a6df42" 183 | 184 | require-main-filename@^1.0.1: 185 | version "1.0.1" 186 | resolved "https://registry.yarnpkg.com/require-main-filename/-/require-main-filename-1.0.1.tgz#97f717b69d48784f5f526a6c5aa8ffdda055a4d1" 187 | 188 | semver@^5.5.0: 189 | version "5.6.0" 190 | resolved "https://registry.yarnpkg.com/semver/-/semver-5.6.0.tgz#7e74256fbaa49c75aa7c7a205cc22799cac80004" 191 | 192 | set-blocking@^2.0.0: 193 | version "2.0.0" 194 | resolved "https://registry.yarnpkg.com/set-blocking/-/set-blocking-2.0.0.tgz#045f9782d011ae9a6803ddd382b24392b3d890f7" 195 | 196 | shebang-command@^1.2.0: 197 | version "1.2.0" 198 | resolved "https://registry.yarnpkg.com/shebang-command/-/shebang-command-1.2.0.tgz#44aac65b695b03398968c39f363fee5deafdf1ea" 199 | dependencies: 200 | shebang-regex "^1.0.0" 201 | 202 | shebang-regex@^1.0.0: 203 | version "1.0.0" 204 | resolved "https://registry.yarnpkg.com/shebang-regex/-/shebang-regex-1.0.0.tgz#da42f49740c0b42db2ca9728571cb190c98efea3" 205 | 206 | signal-exit@^3.0.0: 207 | version "3.0.2" 208 | resolved "https://registry.yarnpkg.com/signal-exit/-/signal-exit-3.0.2.tgz#b5fdc08f1287ea1178628e415e25132b73646c6d" 209 | 210 | string-width@^1.0.1: 211 | version "1.0.2" 212 | resolved "https://registry.yarnpkg.com/string-width/-/string-width-1.0.2.tgz#118bdf5b8cdc51a2a7e70d211e07e2b0b9b107d3" 213 | dependencies: 214 | code-point-at "^1.0.0" 215 | is-fullwidth-code-point "^1.0.0" 216 | strip-ansi "^3.0.0" 217 | 218 | string-width@^2.0.0, string-width@^2.1.1: 219 | version "2.1.1" 220 | resolved "https://registry.yarnpkg.com/string-width/-/string-width-2.1.1.tgz#ab93f27a8dc13d28cac815c462143a6d9012ae9e" 221 | dependencies: 222 | is-fullwidth-code-point "^2.0.0" 223 | strip-ansi "^4.0.0" 224 | 225 | strip-ansi@^3.0.0, strip-ansi@^3.0.1: 226 | version "3.0.1" 227 | resolved "http://registry.npmjs.org/strip-ansi/-/strip-ansi-3.0.1.tgz#6a385fb8853d952d5ff05d0e8aaf94278dc63dcf" 228 | dependencies: 229 | ansi-regex "^2.0.0" 230 | 231 | strip-ansi@^4.0.0: 232 | version "4.0.0" 233 | resolved "https://registry.yarnpkg.com/strip-ansi/-/strip-ansi-4.0.0.tgz#a8479022eb1ac368a871389b635262c505ee368f" 234 | dependencies: 235 | ansi-regex "^3.0.0" 236 | 237 | strip-eof@^1.0.0: 238 | version "1.0.0" 239 | resolved "http://registry.npmjs.org/strip-eof/-/strip-eof-1.0.0.tgz#bb43ff5598a6eb05d89b59fcd129c983313606bf" 240 | 241 | which-module@^2.0.0: 242 | version "2.0.0" 243 | resolved "https://registry.yarnpkg.com/which-module/-/which-module-2.0.0.tgz#d9ef07dce77b9902b8a3a8fa4b31c3e3f7e6e87a" 244 | 245 | which@^1.2.9: 246 | version "1.3.1" 247 | resolved "https://registry.yarnpkg.com/which/-/which-1.3.1.tgz#a45043d54f5805316da8d62f9f50918d3da70b0a" 248 | dependencies: 249 | isexe "^2.0.0" 250 | 251 | wrap-ansi@^2.0.0: 252 | version "2.1.0" 253 | resolved "http://registry.npmjs.org/wrap-ansi/-/wrap-ansi-2.1.0.tgz#d8fc3d284dd05794fe84973caecdd1cf824fdd85" 254 | dependencies: 255 | string-width "^1.0.1" 256 | strip-ansi "^3.0.1" 257 | 258 | "y18n@^3.2.1 || ^4.0.0": 259 | version "4.0.0" 260 | resolved "https://registry.yarnpkg.com/y18n/-/y18n-4.0.0.tgz#95ef94f85ecc81d007c264e190a120f0a3c8566b" 261 | 262 | yargs-parser@^11.1.0: 263 | version "11.1.0" 264 | resolved "https://registry.yarnpkg.com/yargs-parser/-/yargs-parser-11.1.0.tgz#0b8104116367bf663089b24e5801438ab50396a3" 265 | dependencies: 266 | camelcase "^5.0.0" 267 | decamelize "^1.2.0" 268 | 269 | yargs@^12.0.2: 270 | version "12.0.4" 271 | resolved "https://registry.yarnpkg.com/yargs/-/yargs-12.0.4.tgz#5ea307c6f11f11881c3bc375f9c939194e8cf4bc" 272 | dependencies: 273 | cliui "^4.0.0" 274 | decamelize "^1.2.0" 275 | find-up "^3.0.0" 276 | get-caller-file "^1.0.1" 277 | os-locale "^3.0.0" 278 | require-directory "^2.1.1" 279 | require-main-filename "^1.0.1" 280 | set-blocking "^2.0.0" 281 | string-width "^2.0.0" 282 | which-module "^2.0.0" 283 | y18n "^3.2.1 || ^4.0.0" 284 | yargs-parser "^11.1.0" 285 | -------------------------------------------------------------------------------- /test/test_org.ml: -------------------------------------------------------------------------------- 1 | let default_config : Conf.t = 2 | { toc = true 3 | ; parse_outline_only = false 4 | ; heading_number = true 5 | ; keep_line_break = false 6 | ; format = Conf.Org 7 | ; heading_to_list = false 8 | ; exporting_keep_properties = false 9 | ; inline_type_with_pos = false 10 | ; inline_skip_macro = false 11 | ; export_md_indent_style = Conf.Dashes 12 | ; export_md_remove_options = [] 13 | ; hiccup_in_block = true 14 | ; enable_drawers = true 15 | ; parse_marker = true 16 | ; parse_priority = true 17 | } 18 | 19 | let check_mldoc_type = 20 | Alcotest.check (Alcotest.testable Type.pp ( = )) "check mldoc type" 21 | 22 | let check_aux source expect = 23 | let result = Mldoc.Parser.parse default_config source |> List.hd |> fst in 24 | fun _ -> check_mldoc_type expect result 25 | 26 | let testcases = 27 | List.map (fun (case, level, f) -> Alcotest.test_case case level f) 28 | 29 | let paragraph l = Type.Paragraph (Type_op.inline_list_with_none_pos l) 30 | 31 | let footnote_definition (s, l) = 32 | Type.Footnote_Definition (s, Type_op.inline_list_with_none_pos l) 33 | 34 | let inline = 35 | let module I = Inline in 36 | [ ( "emphasis" 37 | , testcases 38 | [ ( "normal bold" 39 | , `Quick 40 | , check_aux "*a b c*" 41 | (paragraph [ I.Emphasis (`Bold, [ I.Plain "a b c" ]) ]) ) 42 | ; ( "normal bold(2)" 43 | , `Quick 44 | , check_aux "a*b*c" 45 | (paragraph 46 | [ I.Plain "a" 47 | ; I.Emphasis (`Bold, [ I.Plain "b" ]) 48 | ; I.Plain "c" 49 | ]) ) 50 | ; ( "normal italic" 51 | , `Quick 52 | , check_aux "/a b c/" 53 | (paragraph [ I.Emphasis (`Italic, [ I.Plain "a b c" ]) ]) ) 54 | ; ( "normal underline" 55 | , `Quick 56 | , check_aux "_a b c_" 57 | (paragraph [ I.Emphasis (`Underline, [ I.Plain "a b c" ]) ]) ) 58 | ; ( "not emphasis (1)" 59 | , `Quick 60 | , check_aux "a * b*" (paragraph [ I.Plain "a * b*" ]) ) 61 | ; ( "not emphasis (2)" 62 | , `Quick 63 | , check_aux "a_b_c" 64 | (paragraph [ I.Plain "a"; I.Subscript [ I.Plain "b_c" ] ]) ) 65 | ; ( "contains underline" 66 | , `Quick 67 | , check_aux "_a _ a_" 68 | (paragraph [ I.Emphasis (`Underline, [ I.Plain "a _ a" ]) ]) ) 69 | ; ( "contains star" 70 | , `Quick 71 | , check_aux "*a * a*" 72 | (paragraph [ I.Emphasis (`Bold, [ I.Plain "a * a" ]) ]) ) 73 | ; ( "left flanking delimiter" 74 | , `Quick 75 | , check_aux "hello_world_" 76 | (paragraph [ I.Plain "hello"; I.Subscript [ I.Plain "world_" ] ]) 77 | ) 78 | ; ( "left flanking delimiter (2)" 79 | , `Quick 80 | , check_aux "hello,_world_" 81 | (paragraph 82 | [ I.Plain "hello," 83 | ; I.Emphasis (`Underline, [ I.Plain "world" ]) 84 | ]) ) 85 | ] ) 86 | ; ( "inline-link" 87 | , testcases 88 | [ ( "normal" 89 | , `Quick 90 | , check_aux "[[http://example.com][[example] website]]" 91 | (paragraph 92 | [ I.Link 93 | { url = 94 | I.Complex { protocol = "http"; link = "example.com" } 95 | ; label = [ I.Plain "[example] website" ] 96 | ; title = None 97 | ; full_text = "[[http://example.com][[example] website]]" 98 | ; metadata = "" 99 | } 100 | ]) ) 101 | ; ( "normal (2)" 102 | , `Quick 103 | , check_aux "[[http://example.com][[[example]] website]]" 104 | (paragraph 105 | [ I.Link 106 | { url = 107 | I.Complex { protocol = "http"; link = "example.com" } 108 | ; label = [ I.Plain "[[example]] website" ] 109 | ; title = None 110 | ; full_text = "[[http://example.com][[[example]] website]]" 111 | ; metadata = "" 112 | } 113 | ]) ) 114 | ; ( "normal (3)" 115 | , `Quick 116 | , check_aux "[[http://example.com]]" 117 | (paragraph 118 | [ I.Link 119 | { url = 120 | I.Complex { protocol = "http"; link = "example.com" } 121 | ; label = [ I.Plain "http://example.com" ] 122 | ; title = None 123 | ; full_text = "[[http://example.com]]" 124 | ; metadata = "" 125 | } 126 | ]) ) 127 | ; ( "normal (4)" 128 | , `Quick 129 | , check_aux "[[example]]" 130 | (paragraph 131 | [ I.Link 132 | { url = I.Page_ref "example" 133 | ; label = [ I.Plain "" ] 134 | ; title = None 135 | ; full_text = "[[example]]" 136 | ; metadata = "" 137 | } 138 | ]) ) 139 | ; ( "normal (5)" 140 | , `Quick 141 | , check_aux "[[exam:ple]]" 142 | (paragraph 143 | [ I.Link 144 | { url = I.Page_ref "exam:ple" 145 | ; label = [ I.Plain "" ] 146 | ; title = None 147 | ; full_text = "[[exam:ple]]" 148 | ; metadata = "" 149 | } 150 | ]) ) 151 | ; ( "normal (6)" 152 | , `Quick 153 | , check_aux "[[exam:ple][label]]" 154 | (paragraph 155 | [ I.Link 156 | { url = I.Complex { protocol = "exam"; link = "ple" } 157 | ; label = [ I.Plain "label" ] 158 | ; title = None 159 | ; full_text = "[[exam:ple][label]]" 160 | ; metadata = "" 161 | } 162 | ]) ) 163 | ] ) 164 | ] 165 | 166 | let block = 167 | let open Type in 168 | let module I = Inline in 169 | [ ( "footnote-definition" 170 | , testcases 171 | [ ( "normal" 172 | , `Quick 173 | , check_aux "[fn:abc] 中文" 174 | (footnote_definition ("abc", [ I.Plain "中文" ])) ) 175 | ] ) 176 | ; ( "quote" 177 | , testcases 178 | [ ( "multi lines" 179 | , `Quick 180 | , check_aux "#+BEGIN_QUOTE\nfoo\nbar\n#+END_QUOTE" 181 | (Quote 182 | [ paragraph 183 | [ I.Plain "foo" 184 | ; I.Break_Line 185 | ; I.Plain "bar" 186 | ; I.Break_Line 187 | ] 188 | ]) ) 189 | ; ( "multi lines(2) issue: https://github.com/logseq/logseq/issues/4879" 190 | , `Quick 191 | , check_aux "#+BEGIN_QUOTE\n aaa\nbbb\n#+END_QUOTE" 192 | (Quote 193 | [ paragraph 194 | [ I.Plain "aaa" 195 | ; I.Break_Line 196 | ; I.Plain "bbb" 197 | ; I.Break_Line 198 | ] 199 | ]) ) 200 | ] ) 201 | ; ( "example" 202 | , testcases 203 | [ ( "multi lines" 204 | , `Quick 205 | , check_aux "#+BEGIN_EXAMPLE\nfoo\nbar\n#+END_EXAMPLE" 206 | (Example [ "foo"; "\n"; "bar"; "\n" ]) ) 207 | ] ) 208 | ; ( "drawer" 209 | , testcases 210 | [ ( "properties" 211 | , `Quick 212 | , check_aux 213 | ":PROPERTIES:\n:XXX: 1\n:yyy: 2\n:END:\n#+ZZZ: 3\n#+UUU: 4" 214 | (Property_Drawer 215 | [ ("XXX", "1", []) 216 | ; ("yyy", "2", []) 217 | ; ("ZZZ", "3", []) 218 | ; ("UUU", "4", []) 219 | ]) ) 220 | ; ( "no drawer in quote" 221 | , `Quick 222 | , check_aux "#+BEGIN_QUOTE\na:: b\n#+END_QUOTE" 223 | (Quote [ paragraph [ I.Plain "a:: b"; I.Break_Line ] ]) ) 224 | ] ) 225 | ; ( "src" 226 | , testcases 227 | [ ( "src with header arguments" 228 | , `Quick 229 | , check_aux 230 | "#+BEGIN_SRC haskell :results silent :exports code :var n=0\n\ 231 | \ fac 0 = 1\n\ 232 | \ fac n = n * fac (n-1)\n\ 233 | #+END_SRC" 234 | (Type.Src 235 | { lines = [ "fac 0 = 1"; "\n"; "fac n = n * fac (n-1)"; "\n" ] 236 | ; language = Some "haskell" 237 | ; options = 238 | Some 239 | [ ":results" 240 | ; "silent" 241 | ; ":exports" 242 | ; "code" 243 | ; ":var" 244 | ; "n=0" 245 | ] 246 | ; pos_meta = { start_pos = 59; end_pos = 95 } 247 | }) ) 248 | ] ) 249 | ; ( "Headline with tags" 250 | , testcases 251 | [ ( "(1)" 252 | , `Quick 253 | , check_aux "* aaa :bb:cc:" 254 | (Type.Heading 255 | { title = [ (I.Plain "aaa ", None) ] 256 | ; tags = [ "bb"; "cc" ] 257 | ; marker = None 258 | ; level = 1 259 | ; numbering = None 260 | ; priority = None 261 | ; anchor = "aaa" 262 | ; meta = { Type.timestamps = []; properties = [] } 263 | ; unordered = true 264 | ; size = None 265 | }) ) 266 | ; ( "(2)" 267 | , `Quick 268 | , check_aux "* aaa [[link][label]] :bb:cc:" 269 | (Type.Heading 270 | { title = 271 | [ (I.Plain "aaa ", None) 272 | ; ( I.Link 273 | { I.url = I.Search "link" 274 | ; label = [ I.Plain "label" ] 275 | ; title = None 276 | ; full_text = "[[link][label]]" 277 | ; metadata = "" 278 | } 279 | , None ) 280 | ] 281 | ; tags = [ "bb"; "cc" ] 282 | ; marker = None 283 | ; level = 1 284 | ; numbering = None 285 | ; priority = None 286 | ; anchor = "aaa_label" 287 | ; meta = { Type.timestamps = []; properties = [] } 288 | ; unordered = true 289 | ; size = None 290 | }) ) 291 | ] ) 292 | ] 293 | 294 | let () = Alcotest.run "mldoc" @@ List.concat [ block; inline ] 295 | --------------------------------------------------------------------------------