129 lines
3.9 KiB
OCaml
129 lines
3.9 KiB
OCaml
type bigstring =
|
|
(char, Bigarray.int8_unsigned_elt, Bigarray.c_layout) Bigarray.Array1.t
|
|
|
|
module Json = struct
|
|
type value = [ `Null | `Bool of bool | `String of string | `Float of float ]
|
|
type t = [ value | `A of t list | `O of (string * t) list ]
|
|
|
|
module Stack = struct
|
|
type stack =
|
|
| In_array of t list * stack
|
|
| In_object of (string * t) list * stack
|
|
| Empty
|
|
end
|
|
|
|
let encode ?minify ?(size_chunk = 0x800) ~output t =
|
|
let encoder = Jsonm.encoder ?minify `Manual in
|
|
let buf = Bytes.create size_chunk in
|
|
let rec encode k stack value =
|
|
match Jsonm.encode encoder value with
|
|
| `Ok -> k stack
|
|
| `Partial ->
|
|
let len = Bytes.length buf - Jsonm.Manual.dst_rem encoder in
|
|
output (Bytes.sub_string buf 0 len);
|
|
Jsonm.Manual.dst encoder buf 0 (Bytes.length buf);
|
|
encode k stack `Await
|
|
and value k v stack =
|
|
match v with
|
|
| #value as v -> encode (continue k) stack (`Lexeme v)
|
|
| `O ms -> encode (obj k ms) stack (`Lexeme `Os)
|
|
| `A vs -> encode (arr k vs) stack (`Lexeme `As)
|
|
and obj k ms stack =
|
|
match ms with
|
|
| (n, v) :: ms ->
|
|
let stack = Stack.In_object (ms, stack) in
|
|
encode (value k v) stack (`Lexeme (`Name n))
|
|
| [] -> encode (continue k) stack (`Lexeme `Oe)
|
|
and arr k vs stack =
|
|
match vs with
|
|
| v :: vs ->
|
|
let stack = Stack.In_array (vs, stack) in
|
|
value k v stack
|
|
| [] -> encode (continue k) stack (`Lexeme `Ae)
|
|
and continue k = function
|
|
| Stack.In_array (vs, stack) -> arr k vs stack
|
|
| Stack.In_object (ms, stack) -> obj k ms stack
|
|
| Stack.Empty as stack -> encode k stack `End
|
|
in
|
|
Jsonm.Manual.dst encoder buf 0 (Bytes.length buf);
|
|
value (Fun.const ()) t Stack.Empty
|
|
end
|
|
|
|
let to_json = function
|
|
| `Block name ->
|
|
`O [ ("name", `String name); ("type", `String "BLOCK_BASIC") ]
|
|
| `Net name -> `O [ ("name", `String name); ("type", `String "NET_BASIC") ]
|
|
|
|
module Net = struct
|
|
type t = int
|
|
type mac = string
|
|
type cfg = { mac: mac; mtu: int }
|
|
|
|
let connect _name = assert false
|
|
let read_bigstring _t ?off:_ ?len:_ _bstr = assert false
|
|
let read_bytes _t ?off:_ ?len:_ _buf = assert false
|
|
let write_bigstring _t ?off:_ ?len:_ _bstr = assert false
|
|
let write_string _t ?off:_ ?len:_ _str = assert false
|
|
end
|
|
|
|
module Block = struct
|
|
type t = { handle: int; pagesize: int }
|
|
|
|
let pagesize _ = assert false
|
|
let connect _name = assert false
|
|
let atomic_read _t ~off:_ _bstr = assert false
|
|
let atomic_write _t ~off:_ _bstr = assert false
|
|
let read _t ~off:_ _bstr = assert false
|
|
let write _t ~off:_ _bstr = assert false
|
|
end
|
|
|
|
external clock_monotonic : unit -> (int[@untagged])
|
|
= "unimplemented" "miou_solo5_clock_monotonic"
|
|
[@@noalloc]
|
|
|
|
external clock_wall : unit -> (int[@untagged])
|
|
= "unimplemented" "miou_solo5_clock_wall"
|
|
[@@noalloc]
|
|
|
|
let sleep _ = assert false
|
|
|
|
type 'a arg =
|
|
| Args : ('k, 'res) devices -> 'a arg
|
|
| Block : string -> Block.t arg
|
|
| Net : string -> (Net.t * Net.cfg) arg
|
|
|
|
and ('k, 'res) devices =
|
|
| [] : (unit -> 'res, 'res) devices
|
|
| ( :: ) : 'a arg * ('k, 'res) devices -> ('a -> 'k, 'res) devices
|
|
|
|
let net name = Net name
|
|
let block name = Block name
|
|
let opt arg = Args [ arg ]
|
|
let map _fn args = Args args
|
|
let dft _v arg = Args [ arg ]
|
|
let const _ = Args []
|
|
|
|
type t = [ `Block of string | `Net of string ]
|
|
|
|
let collect devices =
|
|
let rec go : type k res. t list -> (k, res) devices -> t list =
|
|
fun acc -> function
|
|
| [] -> List.rev acc
|
|
| Block name :: rest -> go (`Block name :: acc) rest
|
|
| Net name :: rest -> go (`Net name :: acc) rest
|
|
| Args vs :: rest -> go (go acc vs) rest
|
|
in
|
|
go [] devices
|
|
|
|
let run ?g:_ args _fn =
|
|
let devices = collect args in
|
|
let v =
|
|
`O
|
|
List.
|
|
[
|
|
("type", `String "solo5.manifest"); ("version", `Float 1.0)
|
|
; ("devices", `A (List.map to_json devices))
|
|
]
|
|
in
|
|
let output str = output_string stdout str in
|
|
Json.encode ~output v; exit 0
|