lambcmd_extcombine.ml

(* combine multiple lambdoc extensions, UNTESTED *)

module type Ext = sig
  module Monad : Lambdoc_reader.Extension.MONAD
  type linkdata_t
  type imagedata_t
  type extinldata_t
  type extblkdata_t
  include Lambdoc_reader.Extension.S with module Monad := Monad and
  type linkdata_t := linkdata_t and
  type imagedata_t := imagedata_t and
  type extinldata_t := extinldata_t and
  type extblkdata_t := extblkdata_t
  include Lambdoc_writer.Extension.S with module Monad := Monad and
  type linkdata_t := linkdata_t and
  type imagedata_t := imagedata_t and
  type extinldata_t := extinldata_t and
  type extblkdata_t := extblkdata_t
end

module Combine(E1: Ext)(E2: Ext with type rconfig_t = E1.rconfig_t and
                             type wconfig_t = E1.wconfig_t and
                             module Monad = E1.Monad) : Ext = struct
  type linkdata_t = E1.linkdata_t * E2.linkdata_t
  type imagedata_t = E1.imagedata_t * E2.imagedata_t
  type extinldata_t = E1.extinldata_t * E2.extinldata_t
  type extblkdata_t = E1.extblkdata_t * E2.extblkdata_t
  type rconfig_t = E1.rconfig_t
  type wconfig_t = E1.wconfig_t
  module Monad = E1.Monad
  open Monad

  let bind_okay a f =
    bind a (function | `Okay v -> f v | `Error _ as e -> return e)

  let combine a b =
    bind_okay a (fun l1 ->
        bind_okay b (fun l2 -> return (`Okay (l1, l2))))

  let extinldefs = BatList.append E1.extinldefs E2.extinldefs
  let extblkdefs = BatList.append E1.extblkdefs E2.extblkdefs
  let read_link ?rconfig href =
    combine (E1.read_link ?rconfig href) (E2.read_link ?rconfig href)
  let read_image ?rconfig href =
    combine (E1.read_image ?rconfig href) (E2.read_image ?rconfig href)
  let read_extinl ?rconfig ident inl =
    combine (E1.read_extinl ?rconfig ident inl)
      (E2.read_extinl ?rconfig ident inl)
  let read_extblk ?rconfig ident block =
    combine (E1.read_extblk ?rconfig ident block)
      (E2.read_extblk ?rconfig ident block)
  let write_link ?wconfig href (link1, link2) =
    bind (E1.write_link ?wconfig href link1) (function
        | (h, None) when h = href ->
          E2.write_link ?wconfig href link2
        | r -> return r)

  let write_image ?wconfig href (img1, img2) =
    bind (E1.write_image ?wconfig href img1) (function
        | h when h = href ->
          E2.write_image ?wconfig href img2
        | r -> return r)
  let write_extinl ?wconfig ident inl (data1,data2) =
    if List.exists (fun (i, _) -> i = ident) E1.extinldefs then
      E1.write_extinl ?wconfig ident inl data1
    else
      E2.write_extinl ?wconfig ident inl data2
  let write_extblk ?wconfig ident blk (data1,data2) =
    if List.exists (fun (i, _) -> i = ident) E1.extblkdefs then
      E1.write_extblk ?wconfig ident blk data1
    else
      E2.write_extblk ?wconfig ident blk data2
end

lambcmd_extcombine_multi.ml

(* combine multiple lambdoc extensions, UNTESTED *)
open Lambdoc_reader.Extension
module type Ext = sig
  module Monad : MONAD
  type linkdata_t
  type imagedata_t
  type extinldata_t
  type extblkdata_t
  include S with module Monad := Monad and
  type linkdata_t := linkdata_t and
  type imagedata_t := imagedata_t and
  type extinldata_t := extinldata_t and
  type extblkdata_t := extblkdata_t
  include Lambdoc_writer.Extension.S with module Monad := Monad and
  type linkdata_t := linkdata_t and
  type imagedata_t := imagedata_t and
  type extinldata_t := extinldata_t and
  type extblkdata_t := extblkdata_t
end

open Lambdoc_core
open Basic
module ExtMonad : MONAD = struct
  include Lwt
  let iter = Lwt_list.iter_p
end
module type LinkExt = sig
  type linkdata_t
  val read_link: Href.t -> linkdata_t result_t ExtMonad.t
  val write_link: Href.t -> linkdata_t -> (Href.t * Inline.seq_t option) ExtMonad.t
end

module type ImageExt = sig
  type imagedata_t
  val read_image: Href.t -> imagedata_t result_t ExtMonad.t
  val write_image: Href.t -> imagedata_t -> Href.t ExtMonad.t
end

module type InlineExt = sig
  type extinldata_t
  val def : Extcomm.syninl_t * bool
  val read_extinl : Extcomm.extinl_t -> extinldata_t result_t ExtMonad.t
  val write_extinl : Extcomm.extinl_t -> extinldata_t -> Inline.seq_t ExtMonad.t
end

module type BlockExt = sig
  type extblkdata_t
  val def : Extcomm.synblk_t * Blkcat.t list
  val read_extblk : Extcomm.extblk_t -> extblkdata_t result_t ExtMonad.t
  val write_extblk : Extcomm.extblk_t -> extblkdata_t -> Block.frag_t ExtMonad.t
end

let combine extimages extlinks
    extinlines
    extblocks =
  let merge assoclst =
    List.fold_left (fun accum (k, v) ->
        match BatMap.add_carry k v accum with
        | _, Some _ ->
          failwith ("Extension already registered for " ^ k)
        | map, None -> map) BatMap.empty assoclst in
  let ext_inlines = merge extinlines
  and ext_blocks = merge extblocks in
  (module struct
     type linkdata_t = Lambdoc_core.Basic.Href.t * Lambdoc_core.Inline.seq_t option
     type imagedata_t = Href.t
     type extinldata_t = Inline.seq_t
     type extblkdata_t = Block.frag_t
     type rconfig_t
     type wconfig_t
     module Monad = ExtMonad

     let result_of f v = Monad.bind (f v) (fun r -> Monad.return (`Okay r))
     let bind_ok a f =
       Monad.bind a (function
           | `Okay v -> f v
           | `Error _ as e -> Monad.return e)
     let bind_okay a f =
       bind_ok a (result_of f)

     let extinldefs = BatList.map (fun (k, m) ->
         let module I = (val m : InlineExt) in
         k, I.def) (BatMap.bindings ext_inlines)

     let read_extinl ?rconfig ident inl =
       let module M = (val BatMap.find ident ext_inlines : InlineExt) in
       bind_okay (M.read_extinl inl) (M.write_extinl inl)

     let write_extinl ?wconfig _ _ v = Monad.return v

     let extblkdefs = BatList.map (fun (k, m) ->
         let module I = (val m : BlockExt) in
         k, I.def) (BatMap.bindings ext_blocks)

     let read_extblk ?rconfig ident blk =
       let module M = (val BatMap.find ident ext_blocks : BlockExt) in
       bind_okay (M.read_extblk blk) (M.write_extblk blk)

     let write_extblk ?wconfig _ _ v = Monad.return v

     let read_image ?rconfig href =
       let f m href =
         let module M = (val m : ImageExt) in
         bind_okay (M.read_image href) (M.write_image href)
       in
       List.fold_left (fun accum m ->
           bind_ok accum (f m)) (Monad.return (`Okay href)) extimages

     let write_image ?wconfig _ img = Monad.return img

     let read_link ?rconfig href =
       let f m (href,desc) =
         match desc with
         | Some _ -> Monad.return (`Okay (href, desc))
         | None ->
           let module M = (val m : LinkExt) in
           bind_okay (M.read_link href) (M.write_link href)
       in
       List.fold_left (fun accum m ->
           bind_ok accum (f m)) (Monad.return (`Okay (href, None))) extlinks

     let write_link ?wconfig _ link = Monad.return link
   end : Ext)

lambcmd_orgtable.ml

open Extcomm
open Mlorg.Inline
let (%>) = BatPervasives.(%>)

let image_extensions = [".png"; ".jpg"; ".jpeg"; ".gif"; ".bmp"]

let lamb_of_org_inline = object(self)
  inherit [Inline.seq_t] Mlorg.Inline.bottomUp as super
  method bot = []
  method combine = BatList.concat
  method! inline = function
    | Emphasis (`Bold, l) ->
      [ Inline.bold (self#inlines l) ]
    | Emphasis ((`Italic | `Underline), l) ->
      [ Inline.emph (self#inlines l) ]
    | Entity e ->
      [ Inline.entity e.Mlorg.Entity.unicode ]
    | Break_Line ->
      [ Inline.linebreak () ]
    | Link link ->
      let href = string_of_url link.url in
      (* TODO: Search _ *)
      if List.exists (String.ends_with href)
          (image_extensions) then
        [ Inline.glyph href (asciis link.label)]
      else
        [ Inline.link href (Some (self#inlines link.label)) ]
    | Plain str -> [ Inline.plain str ]
    | i -> super#inline i
end

open Mlorg.Block
let lamb_of_org_block = object(self)
  inherit [Block.frag_t] Mlorg.Block.bottomUp as super

  method bot = []
  method combine = BatList.concat

  method! inline i = [ Block.paragraph (lamb_of_org_inline#inline i) ]
  method! inlines l = [ Block.paragraph (lamb_of_org_inline#inlines l)]

  method! block = function
    | Paragraph il -> self#inlines il
    | Heading h ->
      let level = Basic.Level.section h.level in
      let order = failwith "TODO" in
      [lamb_of_org_inline#inlines h.title |>
       Heading.section (Label.Auto "") order Heading.Mainbody level |>
       Block.heading ]
    | Table t ->
      let rows = t.rows in
      let colspec = Array.map (fun _ -> Tabular.Center, Tabular.Normal) rows.(0).(0) in
      (* TODO: alignment *)
      let map f a = Array.to_list (Array.map f a) in
      let map_cell l =
        Tabular.make_cell None (Some (lamb_of_org_inline#inlines l)) in
      [match map (map (map map_cell %> Tabular.make_row) %> Tabular.make_group) rows with
       | thead :: body ->
         Tabular.make colspec ~thead body |> Block.tabular
       | [] -> Tabular.make colspec [] |> Block.tabular
      ]
    | b -> super#block b
end

module Monad = struct
  type 'a t = 'a
  let return x = x
  let fail exc = raise exc
  let bind t f = f t
  let catch f g = try f () with exc -> g exc
  let iter = List.iter
end

type linkdata_t = unit
type imagedata_t = unit
type extinldata_t = unit
type extblkdata_t = [ `Org of Mlorg.Block.t list ]
type rconfig_t = unit
type wconfig_t = unit

let find_user name =
  (* Insert code to check if user actually exists in the system *)
  `Okay (`User name)

let linkify_user name =
  (* Insert code to create a link to the user's home page *)
  name

let extinldefs = []	(* We do not define any custom inline commands *)

let extblkdefs =
  [
    ("org", (`Synblk_simraw, [`Embeddable_blk; `Figure_blk]));
  ]

let read_link ?rconfig href = (`Okay ())

let read_image ?rconfig href = (`Okay ())

let read_extinl ?rconfig tag extcomm =
  assert false	(* This should never be called, because we haven't defined any custom inline commands *)

let read_extblk ?rconfig tag extcomm = match (tag, extcomm) with
  | ("org", Extblk_simraw txt) ->
    let _, blocks = BatIO.lines_of (BatIO.input_string txt) |>
                    Mlorg.Syntaxes.Org.Parser.parse in
    `Okay (`Org blocks)
  | _ ->
    assert false	(* This should never be called *)

let write_link ?wconfig href _ = (href, None)

let write_image ?wconfig href _ = href

let write_extinl ?wconfig tag extinl data =
  assert false	(* This should never be called, because we haven't defined any custom inline commands *)

let write_extblk ?wconfig tag extblk data = match (tag, extblk, data) with
  | ("org", _, `Org blocks) ->
    (lamb_of_org_block#blocks blocks)
  | _				-> assert false