commit a89e7dbb3b946b60f2fea1089af7ac8d908af0e8
Author: Simon Cruanes <simon.cruanes.2007@m4x.org>
Date:   Tue Feb 9 10:40:37 2021 -0500

    initial import

diff --git a/.gitignore b/.gitignore
new file mode 100644
index 00000000..607c18c6
--- /dev/null
+++ b/.gitignore
@@ -0,0 +1,5 @@
+_build
+.merlin
+*.install
+target
+*.so
diff --git a/Makefile b/Makefile
new file mode 100644
index 00000000..aa48164d
--- /dev/null
+++ b/Makefile
@@ -0,0 +1,14 @@
+all:
+	@dune build @all
+
+watch:
+	@dune build @all -w
+
+test:
+	@dune runtest --force --no-buffer
+
+clean:
+	@dune clean
+
+doc:
+	@dune build @doc
diff --git a/dune-project b/dune-project
new file mode 100644
index 00000000..ae5efa96
--- /dev/null
+++ b/dune-project
@@ -0,0 +1,2 @@
+(lang dune 2.0)
+(using menhir 2.0)
diff --git a/linol.opam b/linol.opam
new file mode 100644
index 00000000..28624e7d
--- /dev/null
+++ b/linol.opam
@@ -0,0 +1,24 @@
+opam-version: "2.0"
+version: "0.1"
+maintainer: "simon.cruanes.2007@m4x.org"
+author: "Simon Cruanes"
+homepage: "https://github.com/c-cube/linol"
+synopsis: "LSP server library"
+build: [
+  ["dune" "build" "@install" "-p" name "-j" jobs]
+  ["dune" "build" "@runtest" "-p" name "-j" jobs] {with-test}
+  ["dune" "build" "@doc" "-p" name "-j" jobs] {with-doc}
+]
+depends: [
+  "dune" { >= "1.0" }
+  "containers" { >= "3.0" & < "4.0" }
+  "lsp" { >= "1.4" & < "1.5" }
+  "lwt" { >= "5.1" & < "6.0" }
+  "ocaml" { >= "4.08" }
+  "odoc" { with-doc }
+]
+tags: [ "lsp" "server" "lwt" ]
+bug-reports: "https://github.com/c-cube/linol/issues"
+dev-repo: "git+https://github.com/c-cube/linol.git"
+
+
diff --git a/src/dune b/src/dune
new file mode 100644
index 00000000..d0cd19b3
--- /dev/null
+++ b/src/dune
@@ -0,0 +1,6 @@
+
+(library
+  (name linol)
+  (public_name linol)
+  (flags :standard -warn-error -a+8)
+  (libraries containers lwt lwt.unix lsp))
diff --git a/src/jsonrpc2.ml b/src/jsonrpc2.ml
new file mode 100644
index 00000000..6aa79245
--- /dev/null
+++ b/src/jsonrpc2.ml
@@ -0,0 +1,218 @@
+
+(** {1 Simple JSON-RPC2 implementation}
+    See {{: https://www.jsonrpc.org/specification} the spec} *)
+
+module Fmt = CCFormat
+module J = Yojson.Safe
+module Err = Jsonrpc.Response.Error
+open Task.Infix
+
+module IO = struct
+  type 'a t = 'a Lwt.t
+  let (let+) = Lwt.(>|=)
+  let (let*) = Lwt.(>>=)
+  let (and+) a b =
+    let open Lwt in
+    a >>= fun x -> b >|= fun y -> x,y
+  let return = Lwt.return
+  let failwith = Lwt.fail_with
+  type in_channel = Lwt_io.input Lwt_io.channel
+  type out_channel = Lwt_io.output Lwt_io.channel
+end
+
+include Lsp_server.Make(IO)
+
+type json = J.t
+type 'a m = 'a Task.m
+
+let spf = Printf.sprintf
+
+module ErrorCode = Lsp.Types.ErrorCodes
+(*
+module Err = struct
+  type code = int
+  let code_parse_error : code = (-32700)
+  let code_invalid_request : code = (-32600)
+  let code_method_not_found : code = (-32601)
+  let code_invalid_param : code = (-32602)
+  let code_internal_error : code = (-32603)
+end
+
+               *)
+exception E of ErrorCode.t * string
+
+type t = {
+  ic: Lwt_io.input Lwt_io.channel;
+  oc: Lwt_io.output Lwt_io.channel;
+  s: server;
+}
+
+let create ~ic ~oc server : t = {ic; oc; s=server}
+
+let create_stdio server : t =
+  create ~ic:Lwt_io.stdin ~oc:Lwt_io.stdout server
+
+(* bind on IO+result *)
+let ( let*? ) x f =
+  let open Lwt.Infix in
+  x >>= function
+  | Error _ as err -> Lwt.return err
+  | Ok x -> f x
+
+(* send a single message *)
+let send_json_ (self:t) (j:json) : unit m =
+  let json = J.to_string j in
+  let full_s =
+    Printf.sprintf "Content-Length: %d\r\n\r\n%s"
+      (String.length json) json
+  in
+  Lwt_io.write self.oc full_s
+
+let send_response (self:t) (m:Jsonrpc.Response.t) : unit m =
+  let json = Jsonrpc.Response.yojson_of_t m in
+  send_json_ self json
+
+let send_server_notif (self:t) (m:Jsonrpc.Message.notification) : unit m =
+  let json = Jsonrpc.Message.yojson_of_notification m in
+  send_json_ self json
+
+let try_ f =
+  Lwt.catch
+    (fun () -> let+ x = f() in Ok x)
+    (fun e -> Lwt.return (Error e))
+
+let log_lsp_ msg =
+  Fmt.kasprintf
+    (fun s ->
+      Lsp.Logger.log ~title:Lsp.Logger.Title.Debug ~section:"jsonrpc2"
+      "%s" s)
+    msg
+
+(* read a full message *)
+let read_msg (self:t) : (Jsonrpc.Message.either, exn) result m =
+  let rec read_headers acc =
+    let*? line =
+      try_ @@ fun () -> Lwt_io.read_line self.ic
+    in
+    match String.trim line with
+    | "" -> Lwt.return (Ok acc) (* last separator *)
+    | line ->
+      begin match
+          let i = String.index line ':' in
+          if i<0 || String.get line (i+1) <> ' ' then raise Not_found;
+          let key = String.lowercase_ascii @@ String.sub line 0 i in
+          let v =
+            String.lowercase_ascii @@
+            String.trim (String.sub line (i+1) (String.length line-i-1))
+          in
+          key, v
+        with
+        | pair -> read_headers (pair :: acc)
+        | exception _ ->
+          Lwt.return (Error (E(ErrorCode.ParseError, spf "invalid header: %S" line)))
+      end
+  in
+  let*? headers = read_headers [] in
+  log_lsp_ "headers: %a" Fmt.Dump.(list @@ pair string string) headers;
+  let ok = match List.assoc "content-type" headers with
+    | "utf8" | "utf-8" -> true
+    | _ -> false
+    | exception Not_found -> true
+  in
+  if ok then (
+    match int_of_string (List.assoc "content-length" headers) with
+    | n ->
+      log_lsp_ "read %d bytes..." n;
+      let buf = Bytes.make n '\000' in
+      let*? () =
+        try_ @@ fun () -> Lwt_io.read_into_exactly self.ic buf 0 n
+      in
+      (* log_lsp_ "got bytes %S" (Bytes.unsafe_to_string buf); *)
+      let*? j =
+        try_ @@ fun () ->
+        Lwt.return @@ J.from_string (Bytes.unsafe_to_string buf)
+      in
+      begin match Jsonrpc.Message.either_of_yojson j with
+        | m -> Lwt.return @@ Ok m
+        | exception _ ->
+          Lwt.return (Error (E(ErrorCode.ParseError, "cannot decode json")))
+      end
+    | exception _ ->
+      Lwt.return @@
+      Error (E(ErrorCode.ParseError, "missing content-length' header"))
+  ) else (
+    Lwt.return @@
+    Error (E(ErrorCode.InvalidRequest, "content-type must be 'utf-8'"))
+  )
+
+let run (self:t) (task:_ Task.t) : unit m =
+  let process_msg r =
+    let module M = Jsonrpc.Message in
+    let protect ~id f =
+      Lwt.catch f
+        (fun e ->
+           let r = Jsonrpc.Response.error id
+             (Jsonrpc.Response.Error.make
+               ~code:Jsonrpc.Response.Error.Code.InternalError
+               ~message:(Printexc.to_string e) ())
+          in
+          send_response self r)
+    in
+    match r.M.id with
+    | None ->
+      (* notification *)
+      begin match Lsp.Client_notification.of_jsonrpc {r with M.id=()} with
+        | Ok n ->
+          Lwt.catch
+            (fun () ->
+              (self.s)#on_notification n
+                ~notify_back:(fun n ->
+                    let msg = Lsp.Server_notification.to_jsonrpc n in
+                    send_server_notif self msg))
+            (fun e ->
+               let msg =
+                 Lsp.Types.ShowMessageParams.create ~type_:Lsp.Types.MessageType.Error
+                   ~message:(Printexc.to_string e)
+               in
+               let msg =
+                 Lsp.Server_notification.LogMessage msg
+                 |> Lsp.Server_notification.to_jsonrpc
+               in
+               send_server_notif self msg)
+        | Error e ->
+          Lwt.fail_with (spf "cannot decode notification: %s" e)
+      end
+    | Some id ->
+      (* request, so we need to reply *)
+      Lwt.catch
+        (fun () ->
+          begin match Lsp.Client_request.of_jsonrpc {r with M.id} with
+            | Ok (Lsp.Client_request.E r) ->
+              protect ~id (fun () ->
+                let* reply = self.s#on_request r in
+                let reply_json = Lsp.Client_request.yojson_of_result r reply in
+                let response = Jsonrpc.Response.ok id reply_json in
+                send_response self response
+              )
+            | Error e ->
+              Lwt.fail_with (spf "cannot decode request: %s" e)
+          end)
+        (fun e ->
+          let r =
+            Jsonrpc.Response.error id
+            (Jsonrpc.Response.Error.make
+              ~code:Jsonrpc.Response.Error.Code.InternalError
+              ~message:(Printexc.to_string e) ())
+          in
+          send_response self r)
+  in
+  let rec loop () =
+    if Task.is_cancelled task then Lwt.return ()
+    else (
+      let* r = read_msg self >>= Task.unwrap in
+      Lwt.async (fun () -> process_msg r);
+      loop()
+    )
+  in
+  loop()
+
diff --git a/src/jsonrpc2.mli b/src/jsonrpc2.mli
new file mode 100644
index 00000000..0be3aa49
--- /dev/null
+++ b/src/jsonrpc2.mli
@@ -0,0 +1,24 @@
+
+module IO : Lsp_server.IO
+  with type 'a t = 'a Task.m
+   and type in_channel = Lwt_io.input Lwt_io.channel
+   and type out_channel = Lwt_io.output Lwt_io.channel
+
+type json = Yojson.Safe.t
+
+type t
+(** A jsonrpc2 connection. *)
+
+include module type of Lsp_server.Make(IO)
+
+val create :
+  ic:IO.in_channel ->
+  oc:IO.out_channel ->
+  server ->
+  t
+(** Create a connection from the pair of channels *)
+
+val create_stdio : server -> t
+
+val run : t -> unit Task.t -> unit Task.m
+(** Listen for incoming messages and responses *)
diff --git a/src/lsp_lwt.ml b/src/lsp_lwt.ml
new file mode 100644
index 00000000..33acb688
--- /dev/null
+++ b/src/lsp_lwt.ml
@@ -0,0 +1,8 @@
+
+module type IO = Lsp_server.IO
+module Make = Lsp_server.Make
+module Jsonrpc2 = Jsonrpc2
+module Task = Task
+
+include Lsp.Types
+type doc_state = Jsonrpc2.doc_state
diff --git a/src/lsp_server.ml b/src/lsp_server.ml
new file mode 100644
index 00000000..addaf9c5
--- /dev/null
+++ b/src/lsp_server.ml
@@ -0,0 +1,228 @@
+
+module type IO = sig
+  type 'a t
+  val return : 'a -> 'a t
+  val failwith : string -> 'a t
+  val (let+) : 'a t -> ('a -> 'b) -> 'b t
+  val (let*) : 'a t -> ('a -> 'b t) -> 'b t
+  val (and+) : 'a t -> 'b t -> ('a * 'b) t
+  type in_channel
+  type out_channel
+end
+
+module Make(IO : IO) = struct
+  open Lsp.Types
+
+  module Position = Position
+  module Range = Range
+
+  (** The server baseclass *)
+  class virtual base_server = object
+    method virtual on_notification :
+      notify_back:(Lsp.Server_notification.t -> unit IO.t) ->
+      Lsp.Client_notification.t ->
+      unit IO.t
+
+    method virtual on_request : 'a.
+      'a Lsp.Client_request.t ->
+      'a IO.t
+
+    (** Set to true if the client requested to exit *)
+    method must_quit = false
+  end
+
+  (** A wrapper to more easily reply to notifications *)
+  class notify_back ~notify_back ?version ~(uri:DocumentUri.t) () = object
+    (** Send a log message to the editor *)
+    method send_log_msg ~type_ msg : unit IO.t =
+      let params = ShowMessageParams.create ~type_ ~message:msg in
+      notify_back (Lsp.Server_notification.LogMessage params)
+
+    (** Send diagnostics for the current document *)
+    method send_diagnostic (l:Diagnostic.t list) : unit IO.t =
+      let params = PublishDiagnosticsParams.create
+          ~uri ?version ~diagnostics:l () in
+      notify_back (Lsp.Server_notification.PublishDiagnostics params)
+
+    (** Send a notification (general purpose method) *)
+    method send_notification (n:Lsp.Server_notification.t) =
+      notify_back n
+  end
+
+  (** Current state of a document. *)
+  type doc_state = {
+    uri: DocumentUri.t;
+    languageId: string;
+    version: int;
+    content: string;
+  }
+
+  (** An easily overloadable class. Pick the methods you want to support.
+      The user must provide at least the callbacks for document lifecycle:
+      open, close, update. The most basic LSP server should check documents
+      when they're updated and report diagnostics back to the editor. *)
+  class virtual server = object(self)
+    inherit base_server
+    val mutable _quit = false
+    val docs : (DocumentUri.t, doc_state) Hashtbl.t = Hashtbl.create 16
+
+    method! must_quit = _quit
+
+    (** Find current state of the given document, if present. *)
+    method find_doc (uri:DocumentUri.t) : doc_state option =
+      try Some (Hashtbl.find docs uri)
+      with Not_found -> None
+
+    (** Overload to process other requests *)
+    method on_request_unhandled
+      : type r. r Lsp.Client_request.t -> r IO.t
+      = fun _r ->
+        IO.failwith "TODO: handle this request"
+
+    (** Parameter for how to synchronize content with the editor *)
+    method config_sync_opts : TextDocumentSyncOptions.t =
+      TextDocumentSyncOptions.create
+          ~change:TextDocumentSyncKind.Incremental ~willSave:false ()
+
+    method on_req_initialize (_i:InitializeParams.t) : InitializeResult.t IO.t =
+      let sync_opts = self#config_sync_opts in
+      let capabilities =
+        ServerCapabilities.create
+          ~textDocumentSync:(`TextDocumentSyncOptions sync_opts) () in
+      IO.return @@ InitializeResult.create ~capabilities ()
+
+    (** Called when the user hovers on some identifier in the document *)
+    method on_req_hover ~uri:_ ~pos:_ (_ : doc_state) : Hover.t option IO.t =
+      IO.return None
+
+    (** Called when the user requests completion in the document *)
+    method on_req_completion ~uri:_ ~pos:_ ~ctx:_
+        (_ : doc_state) :
+          [ `CompletionList of CompletionList.t
+          | `List of CompletionItem.t list ] option IO.t =
+      IO.return None
+
+    (** Called when the user wants to jump-to-definition  *)
+    method on_req_definition ~uri:_ ~pos:_ (_ : doc_state) : Locations.t option IO.t =
+      IO.return None
+
+    method on_request
+    : type r. r Lsp.Client_request.t -> r IO.t
+    = fun (r:_ Lsp.Client_request.t) ->
+      begin match r with
+        | Lsp.Client_request.Shutdown -> _quit <- true; IO.return ()
+        | Lsp.Client_request.Initialize i -> self#on_req_initialize i
+        | Lsp.Client_request.TextDocumentHover { textDocument; position } ->
+          let doc_st = Hashtbl.find docs textDocument.uri in
+          self#on_req_hover ~uri:textDocument.uri ~pos:position doc_st
+        | Lsp.Client_request.TextDocumentCompletion { textDocument; position; context } ->
+          let doc_st = Hashtbl.find docs textDocument.uri in
+          self#on_req_completion ~uri:textDocument.uri ~pos:position ~ctx:context doc_st
+        | Lsp.Client_request.TextDocumentDefinition { textDocument; position } ->
+          let doc_st = Hashtbl.find docs textDocument.uri in
+          self#on_req_definition ~uri:textDocument.uri ~pos:position doc_st
+        | Lsp.Client_request.TextDocumentDeclaration _
+        | Lsp.Client_request.TextDocumentTypeDefinition _
+        | Lsp.Client_request.TextDocumentCodeLens _
+        | Lsp.Client_request.TextDocumentCodeLensResolve _
+        | Lsp.Client_request.TextDocumentPrepareRename _
+        | Lsp.Client_request.TextDocumentRename _
+        | Lsp.Client_request.TextDocumentLink _
+        | Lsp.Client_request.TextDocumentLinkResolve _
+        | Lsp.Client_request.DocumentSymbol _
+        | Lsp.Client_request.WorkspaceSymbol _
+        | Lsp.Client_request.DebugEcho _
+        | Lsp.Client_request.DebugTextDocumentGet _
+        | Lsp.Client_request.TextDocumentReferences _
+        | Lsp.Client_request.TextDocumentHighlight _
+        | Lsp.Client_request.TextDocumentFoldingRange _
+        | Lsp.Client_request.SignatureHelp _
+        | Lsp.Client_request.CodeAction _
+        | Lsp.Client_request.CompletionItemResolve _
+        | Lsp.Client_request.WillSaveWaitUntilTextDocument _
+        | Lsp.Client_request.TextDocumentFormatting _
+        | Lsp.Client_request.TextDocumentOnTypeFormatting _
+        | Lsp.Client_request.TextDocumentColorPresentation _
+        | Lsp.Client_request.TextDocumentColor _
+        | Lsp.Client_request.SelectionRange _
+        | Lsp.Client_request.ExecuteCommand _
+        | Lsp.Client_request.UnknownRequest _ -> self#on_request_unhandled r
+      end
+
+    (** Called when a document is opened *)
+    method virtual on_notif_doc_did_open :
+      notify_back:notify_back ->
+      TextDocumentItem.t ->
+      content:string ->
+      unit IO.t
+
+    method virtual on_notif_doc_did_close :
+      notify_back:notify_back ->
+      TextDocumentIdentifier.t ->
+      unit IO.t
+
+    (** Called when the document changes. *)
+    method virtual on_notif_doc_did_change :
+      notify_back:notify_back ->
+      VersionedTextDocumentIdentifier.t ->
+      TextDocumentContentChangeEvent.t list ->
+      old_content:string ->
+      new_content:string ->
+      unit IO.t
+
+    method on_notification
+        ~notify_back (n:Lsp.Client_notification.t) : unit IO.t =
+      let open Lsp.Types in
+      begin match n with
+        | Lsp.Client_notification.TextDocumentDidOpen
+            {DidOpenTextDocumentParams.textDocument=doc} ->
+          let notify_back =
+            new notify_back ~uri:doc.uri ~version:doc.version ~notify_back () in
+          let st = {
+            uri=doc.uri; version=doc.version; content=doc.text;
+            languageId=doc.languageId;
+          } in
+          Hashtbl.replace docs doc.uri st;
+          self#on_notif_doc_did_open ~notify_back doc ~content:st.content
+        | Lsp.Client_notification.TextDocumentDidClose {textDocument=doc} ->
+          let notify_back = new notify_back ~uri:doc.uri ~notify_back () in
+          self#on_notif_doc_did_close ~notify_back doc
+        | Lsp.Client_notification.TextDocumentDidChange {textDocument=doc; contentChanges=c} ->
+          let notify_back = new notify_back ~uri:doc.uri ~notify_back () in
+          begin match Hashtbl.find docs doc.uri with
+            | exception Not_found -> IO.failwith "unknown document"
+            | st ->
+              let old_content = st.content in
+              let new_doc: Lsp.Text_document.t =
+                let doc = Lsp.Text_document.make
+                    (DidOpenTextDocumentParams.create
+                       ~textDocument:(
+                         TextDocumentItem.create ~languageId:st.languageId
+                           ~uri:doc.uri ~version:st.version ~text:st.content))
+                in
+                List.fold_left
+                  (fun d ev -> Lsp.Text_document.apply_content_change d ev)
+                  doc c
+              in
+              let new_st = {
+                st with
+                content=Lsp.Text_document.text new_doc;
+                version=Lsp.Text_document.version new_doc;
+              } in
+              Hashtbl.replace docs doc.uri new_st;
+              self#on_notif_doc_did_change ~notify_back doc c ~old_content
+                ~new_content:new_st.content
+          end
+        | Lsp.Client_notification.Exit -> _quit <- true; IO.return ()
+        | Lsp.Client_notification.DidSaveTextDocument _
+        | Lsp.Client_notification.WillSaveTextDocument _
+        | Lsp.Client_notification.ChangeWorkspaceFolders _
+        | Lsp.Client_notification.ChangeConfiguration _
+        | Lsp.Client_notification.Initialized
+        | Lsp.Client_notification.Unknown_notification _
+        | Lsp.Client_notification.CancelRequest _
+          ->
+          IO.return () (* TODO: method for each of these *)
+      end
+  end
+end
diff --git a/src/task.ml b/src/task.ml
new file mode 100644
index 00000000..bb6712a5
--- /dev/null
+++ b/src/task.ml
@@ -0,0 +1,118 @@
+
+module Fmt = CCFormat
+
+type cancel = Lwt_switch.t
+
+type 'a m = 'a Lwt.t
+type 'a t = {
+  descr: string option;
+  cancel: cancel option;
+  mutable n_child: int;
+  cond: unit Lwt_condition.t;
+  parent: parent;
+  run: 'a t -> 'a m;
+}
+and parent =
+  | NoParent
+  | Parent : 'a t -> parent
+
+let cancel self =
+  let cancel_ s = Lwt.async (fun () -> Lwt_switch.turn_off s) in
+  CCOpt.iter cancel_ self.cancel
+let is_cancelled self = CCOpt.exists Lwt_switch.is_on self.cancel
+
+let return x : _ m = Lwt.return x
+
+let descr self = self.descr
+let pause (self:_ t) =
+  Lwt_switch.check self.cancel;
+  Lwt.pause()
+
+module Infix = struct
+  let (>|=) = Lwt.(>|=)
+  let (>>= ) = Lwt.(>>=)
+  let (let+) = (>|=)
+  let (let* ) = (>>=)
+  let (and+ ) = Lwt.both
+end
+
+include Infix
+
+let wait_all l =
+  let+ l = Lwt.all l in
+  match CCList.find_map (function Error e -> Some e | Ok () -> None) l with
+  | None -> Ok ()
+  | Some e -> Error e
+
+let unwrap = function
+  | Ok x -> return x
+  | Error e -> Lwt.fail e
+
+(** An exception caught and re-launched from a task *)
+module Wrapped_error = struct
+  type 'a task = 'a t
+
+  type t = E : {
+    task: 'a task;
+    e: exn;
+  } -> t
+
+  exception Wrapped of t
+
+  let rec pp out (E {task;e}) =
+    let descr = CCOpt.get_or ~default:"<no descr>" task.descr in
+    let pp_e out e = match e with
+      | Wrapped e -> pp out e
+      | e -> Fmt.string out (Printexc.to_string e)
+    in
+    Fmt.fprintf out "@[<v>error in task '%s':@ %a@]" descr pp_e e
+  let to_string = Fmt.to_string pp
+end
+
+let run_ (self:'a t) : ('a, exn) result m =
+  let rec wait_children() : unit m =
+    if self.n_child = 0 then Lwt.return ()
+    else (
+      let* () = Lwt_condition.wait self.cond in
+      wait_children()
+    )
+  in
+  let res () =
+    Lwt.catch
+      (fun () ->
+        let* x = self.run self in
+        let+ () = wait_children() in
+        Ok x)
+      (fun e ->
+         return @@ Error (Wrapped_error.Wrapped (Wrapped_error.E {task=self; e})))
+  in
+  match self.parent with
+  | NoParent -> res()
+  | Parent p ->
+    p.n_child <- 1 + p.n_child;
+    let+ r = res() in
+    p.n_child <- p.n_child - 1;
+    Lwt_condition.signal p.cond ();
+    r
+
+let run self = Lwt_main.run (run_ self)
+
+let start ?descr ?cancel run : _ t =
+  {descr; cancel; run; parent=NoParent; cond=Lwt_condition.create (); n_child=0; }
+
+let run_sub ~parent ?descr ?cancel run : _ m =
+  let t = {
+    descr; cancel; run; parent=Parent parent;
+    cond=Lwt_condition.create (); n_child=0;
+  } in
+  run_ t
+
+
+let () =
+  Printexc.register_printer
+    (function
+      | Wrapped_error.Wrapped e ->
+        let s = Wrapped_error.to_string e in
+        Some s
+      | _ -> None)
+
diff --git a/src/task.mli b/src/task.mli
new file mode 100644
index 00000000..8a835af4
--- /dev/null
+++ b/src/task.mli
@@ -0,0 +1,60 @@
+
+(** {1 Tasks}
+
+    Tasks built on top of Lwt, for cooperative multi-threading. *)
+
+type 'a t
+(** A task *)
+
+type 'a m = 'a Lwt.t
+(** Computation within the task *)
+
+type cancel
+
+val return : 'a -> 'a m
+
+val start :
+  ?descr:string ->
+  ?cancel:cancel -> ('a t -> 'a m) -> 'a t
+
+val descr : _ t -> string option
+
+val run : 'a t -> ('a, exn) result
+
+val run_sub :
+  parent:_ t ->
+  ?descr:string ->
+  ?cancel:cancel ->
+  ('a t -> 'a m) -> ('a, exn) result m
+
+module Wrapped_error : sig
+  type 'a task = 'a t
+
+  type t = E : {
+    task: 'a task;
+    e: exn;
+  } -> t
+
+  (** An exception caught and re-launched from a task *)
+  exception Wrapped of t
+
+  val pp : Format.formatter -> t -> unit
+  val to_string : t -> string
+end
+
+val unwrap : ('a, exn) result -> 'a m
+val is_cancelled : _ t -> bool
+val cancel : _ t -> unit
+val pause : _ t -> unit m
+
+val wait_all : (unit, exn) result m list -> (unit, exn) result m
+
+module Infix : sig
+  val (let+) : 'a m -> ('a -> 'b) -> 'b m
+  val (let* ) : 'a m -> ('a -> 'b m) -> 'b m
+  val (>|=) : 'a m -> ('a -> 'b) -> 'b m
+  val (>>= ) : 'a m -> ('a -> 'b m) -> 'b m
+  val (and+ ) : 'a m -> 'b m -> ('a*'b) m
+end
+
+include module type of Infix