diff --git a/:Format b/:Format new file mode 100644 index 0000000000..807d125286 --- /dev/null +++ b/:Format @@ -0,0 +1,64 @@ +let rec methods_of_xml = function + | Xml.PCData s -> ("text", Lang.string s) + | Xml.Element (name, params, ([Xml.PCData s] as children)) -> + (name, Lang.meth (Lang.string s) (xml_node ~params ~children)) + | Xml.Element (name, params, children) -> + ( name, + Lang.record ( + (List.fold_left + (fun methods el -> + let (name, v) = methods_of_xml el in + let v = + match Methods.find_opt name methods with + | None -> v + | Some (`Tuple {value}) -> Value.make (`Tuple (value @[v])) + | Some value -> (name, Value.make (`Tuple [value; v])) + in + Methods.add name value methods) + Methods.append elements (methods_of_xml el)) + (xml_node ~params ~children) + children) + +and xml_node ~params ~children = + Methods.from_list + [ + ( "xml_params", + Term.make + ~methods: + (Methods.from_list + (List.map (fun (k, v) -> (k, Term.make (`String v))) params)) + Term.unit ); + ( "xml_children", + Term.make (`Tuple (List.map (fun v -> term_of_xml v) children)) ); + ] + +and term_of_xml v = Term.make ~methods:(methods_of_xml v) `Null + +let _ = + Lang.add_builtin "_internal_xml_parser_" ~category:`String ~flags:[`Hidden] + ~descr:"Internal xml parser" + [ + ("type", Value.RuntimeType.t, None, Some "Runtime type"); + ("", Lang.string_t, None, None); + ] + (Lang.univ_t ()) + (fun p -> + let s = Lang.to_string (List.assoc "" p) in + let ty = Value.RuntimeType.of_value (List.assoc "type" p) in + let ty = Type.fresh ty in + try + let xml = Xml.parse_string s in + let tm = term_of_xml xml in + Typechecking.check ~throw:(fun exn -> raise exn) tm; + Typing.(ty <: tm.Term.t); + Evaluation.eval tm + with exn -> ( + let bt = Printexc.get_raw_backtrace () in + match exn with + | _ -> + Runtime_error.raise ~bt ~pos:(Lang.pos p) + ~message: + (Printf.sprintf + "Parse error: xml value cannot be parsed as type: %s" + (Type.to_string ty)) + "xml")) diff --git a/src/lang/builtins_xml.ml b/src/lang/builtins_xml.ml index f50d49c09b..b232a292c8 100644 --- a/src/lang/builtins_xml.ml +++ b/src/lang/builtins_xml.ml @@ -1,36 +1,59 @@ let rec methods_of_xml = function - | Xml.PCData s -> Methods.from_list [("text", Term.make (`String s))] + | Xml.PCData s -> ("text", Lang.string s) | Xml.Element (name, params, ([Xml.PCData s] as children)) -> - Methods.from_list - [(name, Term.make ~methods:(xml_node ~params ~children) (`String s))] + (name, Lang.meth (Lang.string s) (xml_node ~params ~children)) | Xml.Element (name, params, children) -> - Methods.from_list - [ - ( name, - Term.make - ~methods: - (List.fold_left - (fun elements el -> - Methods.append elements (methods_of_xml el)) - (xml_node ~params ~children) - children) - `Null ); - ] + ( name, + Lang.record + (Methods.bindings + (List.fold_left + (fun methods el -> + let name, v = methods_of_xml el in + let v = + match Methods.find_opt name methods with + | None -> v + | Some (Value.Tuple { value }) -> Lang.tuple (value @ [v]) + | Some value -> Lang.tuple [value; v] + in + Methods.add name v methods) + (Methods.from_list (xml_node ~params ~children)) + children)) ) and xml_node ~params ~children = - Methods.from_list - [ - ( "xml_params", - Term.make - ~methods: - (Methods.from_list - (List.map (fun (k, v) -> (k, Term.make (`String v))) params)) - Term.unit ); - ( "xml_children", - Term.make (`Tuple (List.map (fun v -> term_of_xml v) children)) ); - ] + [ + ( "xml_params", + Lang.record (List.map (fun (k, v) -> (k, Lang.string v)) params) ); + ("xml_children", Lang.tuple (List.map (fun v -> value_of_xml v) children)); + ] + +and value_of_xml v = Lang.record [methods_of_xml v] -and term_of_xml v = Term.make ~methods:(methods_of_xml v) `Null +let rec check_value v ty = + let typ_meths, ty = Type.split_meths ty in + let meths, v = Value.split_meths v in + let v = + match (v, ty.Type.descr) with + | Value.Tuple { value = [] }, Type.Nullable _ -> Lang.null + | Value.String { value = s }, Type.Int -> Lang.int (int_of_string s) + | Value.String { value = s }, Type.Float -> Lang.float (float_of_string s) + | Value.String { value = s }, Type.Bool -> Lang.bool (bool_of_string s) + | Value.String _, Type.Nullable ty -> check_value v ty + | _, Type.Var _ + | Value.Tuple { value = [] }, Type.Tuple [] + | Value.String _, Type.String -> + v + | _ -> assert false + in + let meths = + List.fold_left + (fun meths (name, v) -> + match List.find_opt (fun { Type.meth } -> meth = name) typ_meths with + | None -> meths + | Some { Type.scheme = _, ty } -> (name, check_value v ty) :: meths) + [] meths + in + let v = Lang.meth v meths in + v let _ = Lang.add_builtin "_internal_xml_parser_" ~category:`String ~flags:[`Hidden] @@ -46,10 +69,8 @@ let _ = let ty = Type.fresh ty in try let xml = Xml.parse_string s in - let tm = term_of_xml xml in - Typechecking.check ~throw:(fun exn -> raise exn) tm; - Typing.(ty <: tm.Term.t); - Evaluation.eval tm + let value = value_of_xml xml in + check_value value ty with exn -> ( let bt = Printexc.get_raw_backtrace () in match exn with diff --git a/src/libs/extra/audioscrobbler.liq b/src/libs/extra/audioscrobbler.liq index 6888132945..f50e8b2c99 100644 --- a/src/libs/extra/audioscrobbler.liq +++ b/src/libs/extra/audioscrobbler.liq @@ -175,12 +175,12 @@ def audioscrobbler.api.track.updateNowPlaying( { lfm: { nowplaying: { - track: string.{ xml_params: {corrected: string} }, - artist: string.{ xml_params: {corrected: string} }, - album: string?.{ xml_params: {corrected: string} }, - albumArtist: string?.{ xml_params: {corrected: string} }, - timestamp: string, - ignoredMessage: {xml_params: {code: string}} + track: string.{ xml_params: {corrected: int} }, + artist: string.{ xml_params: {corrected: int} }, + album: string?.{ xml_params: {corrected: int} }, + albumArtist: string?.{ xml_params: {corrected: int} }, + timestamp: float, + ignoredMessage: {xml_params: {code: int}} }, xml_params: {status: string} } @@ -277,14 +277,14 @@ def audioscrobbler.api.track.scrobble( lfm: { scrobbles: { scrobble: { - track: string.{ xml_params: {corrected: string} }, - artist: string.{ xml_params: {corrected: string} }, - album: string?.{ xml_params: {corrected: string} }, - albumArtist: string?.{ xml_params: {corrected: string} }, - timestamp: string, - ignoredMessage: {xml_params: {code: string}} + track: string.{ xml_params: {corrected: int} }, + artist: string.{ xml_params: {corrected: int} }, + album: string?.{ xml_params: {corrected: int} }, + albumArtist: string?.{ xml_params: {corrected: int} }, + timestamp: float, + ignoredMessage: {xml_params: {code: int}} }, - xml_params: {ignored: string, accepted: string} + xml_params: {ignored: int, accepted: int} }, xml_params: {status: string} }