Skip to content

Instantly share code, notes, and snippets.

@lubegasimon

lubegasimon/.ocamlformat

Last active November 3, 2021 13:15
Show Gist options
  • Save lubegasimon/4079b391b6e13de293877079ae5dbdcf to your computer and use it in GitHub Desktop.
Save lubegasimon/4079b391b6e13de293877079ae5dbdcf to your computer and use it in GitHub Desktop.
Download ZIP
Bootstrap Mdx
Raw
dune
(library
(name markdown)
(public_name markdown))
(mdx
(packages markdown))
Raw
dune-project
(lang dune 2.9)
(using mdx 0.1)
Raw
markdown.ml
module Markup : sig
(** The goal of this module is to allow to describe a markdown document and
to print it.
A markdown document is composed of [blocks]. *)
type inlines
(** Inlines elements are rendered one after the other, separated by spaces,
but not by empty line. *)
val ( ++ ) : inlines -> inlines -> inlines
(** Combine inlines. *)
val join : inlines -> inlines -> inlines
type blocks
(** A block is composed of [inlines]. Blocks are separated by an empty line. *)
val ordered_list : blocks list -> blocks
val unordered_list : blocks list -> blocks
val blocks : blocks -> blocks -> blocks
(** Combine blocks. *)
val block_separator : blocks
(** A horizontal line between a heading and the body. *)
val text : string -> inlines
(** Some inline elements *)
val line_break : inlines
val nbsp : inlines
val bold : inlines -> inlines
val italic : inlines -> inlines
val superscript : inlines -> inlines
val subscript : inlines -> inlines
val link : href:string -> inlines -> inlines
(** Arbitrary link. *)
val anchor : string -> inlines
val raw_markup : string -> blocks
val code_span : string -> inlines
val paragraph : inlines -> blocks
val code_block : string -> blocks
val heading : int -> inlines -> blocks
val pp_inlines : Format.formatter -> inlines -> unit
val pp_blocks : Format.formatter -> blocks -> unit
(** Renders a markdown document. *)
end = struct
(* What we need in the markdown generator:
Special syntaxes:
- Pandoc's heading attributes
*)
type inlines =
| String of string
| ConcatI of inlines * inlines
| Join of inlines * inlines
(** [Join] constructor is for joining [inlines] without spaces between them. *)
| Link of string * inlines
| Anchor of string
| Linebreak
| Nbsp
and blocks =
| ConcatB of blocks * blocks
| Block of inlines
| CodeBlock of string
| List of list_type * blocks list
| Raw_markup of string
| Block_separator
and list_type = Ordered | Unordered
let ordered_list bs = List (Ordered, bs)
let unordered_list bs = List (Unordered, bs)
let ( ++ ) left right = ConcatI (left, right)
let join left right = Join (left, right)
(*TODO: Can we find a better name for this, like it is for combining inlines? *)
let blocks above below = ConcatB (above, below)
let block_separator = Block_separator
let text s = String s
let line_break = Linebreak
let nbsp = Nbsp
let bold i = Join (String "**", Join (i, String "**"))
let italic i = Join (String "_", Join (i, String "_"))
let subscript i = Join (String "<sub>", Join (i, String "</sub>"))
let superscript i = Join (String "<sup>", Join (i, String "</sup>"))
let code_span s =
if String.contains s '`' then
Join (String "``", Join (String s, String "``"))
else Join (String "`", Join (String s, String "`"))
let link ~href i = Link (href, i)
let anchor i = Anchor i
let raw_markup s = Raw_markup s
let paragraph i = Block i
let code_block s = CodeBlock s
let heading level i =
let make_hashes n = String.make n '#' in
let hashes = make_hashes level in
Block (String hashes ++ i)
let pp_list_item fmt list_type (b : blocks) n pp_blocks =
match list_type with
| Unordered -> Format.fprintf fmt "- @[%a@]" pp_blocks b
| Ordered -> Format.fprintf fmt "%d. @[%a@]" (n + 1) pp_blocks b
let rec pp_inlines fmt i =
match i with
| String s -> Format.fprintf fmt "%s" s
| ConcatI (left, right) ->
Format.fprintf fmt "%a %a" pp_inlines left pp_inlines right
| Join (left, right) ->
Format.fprintf fmt "%a%a" pp_inlines left pp_inlines right
| Link (href, i) -> Format.fprintf fmt "[%a](%s)" pp_inlines i href
| Anchor s -> Format.fprintf fmt "<a id=\"%s\"></a>" s
| Linebreak -> Format.fprintf fmt "@\n"
| Nbsp -> Format.fprintf fmt "\u{00A0}"
let rec pp_blocks fmt b =
match b with
| ConcatB (above, below) ->
Format.fprintf fmt "%a@\n@\n%a" pp_blocks above pp_blocks below
| Block i -> pp_inlines fmt i
| CodeBlock s -> Format.fprintf fmt "```@\n%s@\n```" s
| Block_separator -> Format.fprintf fmt "---"
| List (list_type, l) ->
let rec pp_list n l =
match l with
| [] -> ()
| [ x ] -> pp_list_item fmt list_type x n pp_blocks
| x :: rest ->
pp_list_item fmt list_type x n pp_blocks;
Format.fprintf fmt "@\n@\n";
pp_list (n + 1) rest
in
pp_list 0 l
| Raw_markup s -> Format.fprintf fmt "%s" s
end
Raw
markup.md

Testing the Markup module

(* *)
#require "markdown";;
open Markdown.Markup

let test_inlines test_case =
  Format.printf "%a@\n%!" pp_inlines test_case

let test_blocks test_case =
  Format.printf "%a@\n%!" pp_blocks test_case

(** Add artificial indentation to the output to avoid messing with Mdx's format. *)
let test_blocks_indented test_case =
  Format.printf "  @[%a@]@\n%!" pp_blocks test_case

Inlines

Combining:

# test_inlines
  ((++)
    (text "text one")
    (text "text two"));;
text one text two
- : unit = ()

# test_inlines
  ((text "abc" ++ text "def")
   ++ (text "xyz" ++ text "tuv"));;
abc def xyz tuv
- : unit = ()

# test_inlines
  ((++)
    (bold (text "This should be marked as bold"))
    (italic (text "This should be italic")));;
**This should be marked as bold** _This should be italic_
- : unit = ()

# test_inlines
  (bold
    (text "This is bold"
     ++ italic (text "and this is italic in bold")
     ++ text "."));;
**This is bold _and this is italic in bold_ .**
- : unit = ()

# test_inlines
  (superscript (text "This superscript")
   ++ subscript (text "This is subscript"));;
<sup>This superscript</sup> <sub>This is subscript</sub>
- : unit = ()

# test_inlines
  (anchor "value to id attribute");;
<a id="value to id attribute"></a>
- : unit = ()

Elements:

# test_inlines
    (code_span "type t");;
`type t`
- : unit = ()

# test_inlines
    (code_span "Some `t");;
``Some `t``
- : unit = ()

# test_inlines
    (link ~href: "google.com" (text "Google"));;
[Google](google.com)
- : unit = ()

Blocks

Combining:

# test_blocks
    (blocks
        (paragraph (text "abc"))
        (paragraph (text "def")));;
abc

def
- : unit = ()
# test_blocks
  (blocks
   (blocks (paragraph (text "abc")) (paragraph (text "def")))
   (blocks (paragraph (text "xyz")) (paragraph (text "tuv"))));;
abc

def

xyz

tuv
- : unit = ()

Headings:

# test_blocks_indented
    (heading 1 (text "A simple heading"));;
  # A simple heading
- : unit = ()

# test_blocks_indented
    (heading 3 (text "A" ++ bold (text "complicated") ++ text "heading"));;
  ### A **complicated** heading
- : unit = ()

# test_blocks_indented 
    (heading 3
      ((join 
          (join nbsp nbsp)
          (text "A heading with nbsps"))));;
  ###   A heading with nbsps
- : unit = ()

Code blocks:

# (* Add some indentation to avoid interfering with Mdx syntax. *)
  Format.printf "@[<2>  %a@]@\n%!" pp_blocks
    (code_block "some code block");;

some code block

- : unit = ()

Lists:

# test_blocks
   (* list items with several blocks. *)
    (unordered_list
      [(blocks (paragraph (text "Monday"))
                (paragraph (text "is the first day of the week.")));
        (blocks (paragraph (text "Tuesday"))
                (paragraph (text "is the second day of the week.")))]);;
- Monday

  is the first day of the week.

- Tuesday

  is the second day of the week.
- : unit = ()

# test_blocks
    (ordered_list
      [(blocks
          (paragraph (text "One"))
          (paragraph (text "First digit.")));
      (blocks
          (paragraph (text "Two"))
          (paragraph (text "Second digit.")))]);;
1. One

   First digit.

2. Two

   Second digit.
- : unit = ()

# test_blocks
  (* test for a nested list function. *)
  (ordered_list
    [(blocks
        (paragraph (text "Outer item"))
        (ordered_list [(paragraph (text "This is an inner item"))]))]);;
1. Outer item

   1. This is an inner item
- : unit = ()

# test_blocks
     (ordered_list
        [(blocks
            (paragraph (text "Outer ordered list item"))
            (unordered_list
                [(paragraph (text "This is an inner unordered list item"))]))]);;
1. Outer ordered list item

   - This is an inner unordered list item
- : unit = ()

# test_blocks
    (raw_markup "<span> ... </span>");;
<span> ... </span>
- : unit = ()
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment