let bytes =
open_in_with path input_bytes in
let swf =
- Template.make t bytes in
+ Template.make t (Abc.read (Stream.of_list bytes)) in
open_out_with t#output (fun ch -> Swf.write ch swf)
| _ ->
failwith "not suppert many files"
open Swflib
open Swflib.SwfType
-let make t abc : TagType.t SwfType.t = {
+let make t abc : Swf.t = {
version = 9;
frame_count = 1;
frame_rate = 24.;
let to_multiname (ns,name) =
`QName (`Namespace (String.concat "." ns),name)
-let to_bytes program =
+let generate program =
program
+> Module.of_ast
+> ClosureTrans.trans
List.map to_multiname a,
Codegen.generate @@ Override.of_binding b)
+> curry Swflib.Abc.compile
- +> Swflib.Abc.asm
-
-let generate program =
- program
- +> to_bytes
- +> Swflib.BytesOut.to_int_list
+ +> Swflib.Abc.write
let output ch program =
program
- +> to_bytes
- +> Swflib.BytesOut.output_bytes ch
-
+ +> generate
+ +> List.iter (output_byte ch)
+open Base
+
module A = AbcOut.Make(LowInst)
module D = AbcIn.Make(LowInst)
module C = MethodOut.Make(HighInst)
-type abc = LowInst.t AbcType.t
+type t = LowInst.t AbcType.t
type meth = HighInst.s MethodType.method_
-let asm : abc -> BytesOut.t list =
- A.to_bytes
-let disasm : BytesIn.t Stream.t -> abc =
+
+let write : t -> int list =
+ BytesOut.to_int_list $ A.to_bytes
+
+let read : int Stream.t -> t =
D.of_bytes
-let compile : Cpool.multiname list -> meth -> abc =
- C.to_abc
+let compile : Cpool.multiname list -> meth -> t =
+ C.to_abc
open SwfOut
open TagOut
-type swf = TagType.t SwfType.t
+type t = LowInst.t TagType.t SwfType.t
-module Writer = SwfOut.Make(struct
- type t = TagType.t
- include TagOut
- end)
-
-module Reader = SwfIn.Make(struct
- type t = TagType.t
- include TagIn
- end)
+module Writer = SwfOut.Make(TagOut.Make(Abc))
+module Reader = SwfIn.Make(TagIn.Make(Abc))
let write ch swf =
- Writer.to_base swf
+ Writer.write swf
+> SwfBaseOut.to_list
+> List.iter (output_byte ch)
+
+let read ch =
+ BytesIn.of_channel ch
+ +> Reader.read
+
module type TagType = sig
type t
- val of_base : int -> int Stream.t -> t
+ val read : int -> int Stream.t -> t
end
let to_tag = parser
[< (tag,size) = tag_and_size; body = repeat size ui8 >] ->
- Tag.of_base tag @@ Stream.of_list body
+ Tag.read tag @@ Stream.of_list body
- let of_base = parser
+ let read = parser
[< _ = char 'F'; _ = char 'W'; _ = char 'S';
version = ui8; _ = ui32; (left,right,top,bottom) = rect;
frame_rate = fixed8; frame_count = ui16; tags = many to_tag >] ->
module type TagType = sig
type t
- val of_base : int -> int Stream.t -> t
+ val read : int -> int Stream.t -> t
end
module Make: functor (Tag:TagType) -> sig
- val of_base : int Stream.t -> Tag.t SwfType.t
+ val read : int Stream.t -> Tag.t SwfType.t
(* for debug *)
val to_tag : int Stream.t -> Tag.t
with Stream.Failure ->
[]
-module M = SwfIn.Make(struct
- type t = int * int list
- let of_base t s = (t,entire s)
- end)
+module M = SwfIn.Make(
+ struct
+ type t = int * int list
+ let read t s = (t,entire s)
+ end)
open M
let char c =
frame_count = 42;
tags = []
} in
- ok swf M.of_base [
+ ok swf M.read [
(* signature *)
char 'F'; char 'W'; char 'S';
(* version *)
module type TagType = sig
type t
- val to_base : t -> int * SwfBaseOut.s list
+ val write : t -> int * SwfBaseOut.s list
end
module Make(Tag : TagType) = struct
[`Ui16 ((t lsl 6) lor size)]
else
[`Ui16 ((t lsl 6) lor 0x3F); `Si32 (Int32.of_int size)] in
- let t,data' =
- Tag.to_base tag in
+ let t, data' =
+ Tag.write tag in
[`Size(make_type t, data')]
- let to_base t : SwfBaseOut.t list = [
+ let write t : SwfBaseOut.t list = [
(* signature *)
char 'F'; char 'W'; char 'S';
(* version *)
module type TagType = sig
type t
- val to_base : t -> int * SwfBaseOut.s list
+ val write : t -> int * SwfBaseOut.s list
end
module Make: functor (Tag:TagType) -> sig
- val to_base : Tag.t SwfType.t -> SwfBaseOut.t list
+ val write : Tag.t SwfType.t -> SwfBaseOut.t list
(* for debug *)
val of_tag : Tag.t -> SwfBaseOut.t list
open SwfType
open OUnit
-module M = SwfOut.Make(struct
- type t = int * SwfBaseOut.s list
- let to_base x = x
- end)
+module M = SwfOut.Make(
+ struct
+ type t = int * SwfBaseOut.s list
+ let write x = x
+ end)
+
open M
let char c =
frame_count = 42;
tags = []
} in
- ok to_base swf [
+ ok write swf [
(* signature *)
char 'F'; char 'W'; char 'S';
(* version *)
-open Base
-open SwfBaseIn
+module type Abc = sig
+ type t
+ val read : int Stream.t -> t
+end
-let stream tag s =
- Stream.from begin function
- 0 -> Some tag
- | _ ->
- try
- Some (Stream.next s)
- with _ ->
- None
- end
+module Make(Abc : Abc) = struct
+ open Base
+ open SwfBaseIn
-let tag n stream =
- match Stream.peek stream with
- Some m when m = n ->
- Stream.next stream
- | _ ->
- raise Stream.Failure
+ type t = Abc.t TagType.t
-let option f stream =
- try
- Some (f stream)
- with Stream.Failure ->
- None
+ let stream tag s =
+ Stream.from begin function
+ 0 -> Some tag
+ | _ ->
+ try
+ Some (Stream.next s)
+ with _ ->
+ None
+ end
-let rec many parse stream =
- match stream with parser
- [< e = parse; s>] -> e::many parse s
- | [<>] -> []
+ let tag n stream =
+ match Stream.peek stream with
+ Some m when m = n ->
+ Stream.next stream
+ | _ ->
+ raise Stream.Failure
-let rec repeat n f stream =
- if n = 0 then
- []
- else
+ let option f stream =
+ try
+ Some (f stream)
+ with Stream.Failure ->
+ None
+
+ let rec many parse stream =
match stream with parser
- [<c = f>] ->
- c::repeat (n-1) f stream
- | [<>] ->
- raise (Stream.Error "invalid format")
+ [< e = parse; s>] -> e::many parse s
+ | [<>] -> []
-let repeat_l n f stream =
- repeat (Int32.to_int n) f stream
+ let rec repeat n f stream =
+ if n = 0 then
+ []
+ else
+ match stream with parser
+ [<c = f>] ->
+ c::repeat (n-1) f stream
+ | [<>] ->
+ raise (Stream.Error "invalid format")
+ let repeat_l n f stream =
+ repeat (Int32.to_int n) f stream
-let pair f g = parser
- [< x = f; y = g >] ->
- (x,y)
+ let pair f g = parser
+ [< x = f; y = g >] ->
+ (x,y)
-let alist = parser
- [< count = ui16; xs = repeat count (pair ui16 str) >] ->
- xs
+ let alist = parser
+ [< count = ui16; xs = repeat count (pair ui16 str) >] ->
+ xs
-let bit_bool n s =
- ub n s = 1
+ let bit_bool n s =
+ ub n s = 1
-let read = parser
- [< _ = tag 0 >]->
- `End
- | [< _ = tag 9; c = rgb >]->
- `SetBackgroundColor c
- | [< _ = tag 43; name = str; anchor = option (tag 1) >] ->
- `FrameLabel (name,anchor <> None)
- | [< _ = tag 24 >] ->
- `Protect
- | [< _ = tag 56; xs = alist >] ->
- `ExportAssets xs
- | [< _ = tag 57; url = str; xs = alist >] ->
- `ImportAssets (url,xs)
- | [< _ = tag 58; passwd = str >] ->
- `EnableDebugger passwd
- | [< _ = tag 64; _ = ui16; passwd = str >] ->
- `EnableDebugger2 passwd
- | [< _ = tag 65; max_rec = ui16; timeout = ui16 >] ->
- `ScriptLimits (max_rec, timeout)
- | [< _ = tag 66; depth = ui16; index = ui16 >] ->
- `SetTabIndex (depth, index)
- | [< _ = tag 69; (is_metadata, is_as3, use_network) = bits ~f:parser
- [< _ = ub 3; is_metadata = bit_bool 1; is_as3 = bit_bool 1; _ = ub 2; use_network = bit_bool 1; _ = ub 24 >] ->
- (is_metadata, is_as3, use_network) >] ->
- open TagType in
- `FileAttributes { is_metadata; is_as3; use_network }
- | [< _ = tag 71; url = str; _ = ui8; _ = ui8; xs = alist >] ->
- `ImportAssets2 (url,xs)
- | [< _ = tag 76; xs = alist >] ->
- `SymbolClass xs
- | [< _ = tag 77; s = str >] ->
- `Metadata s
- | [< _ = tag 78; id = ui16; (left,right,top,bottom) = rect >] ->
- open SwfType in
- `DefineScalingGrid (id, {left;right;top;bottom})
- | [< _ = tag 86;
- scene_count = eui32; xs = repeat_l scene_count (pair eui32 str);
- frame_count = eui32; ys = repeat_l frame_count (pair eui32 str); >] ->
- `DefineSceneAndFrameLabelData (xs, ys)
- | [< _ = tag 1 >] ->
- `ShowFrame
- | [< _ = tag 82; lazyInit = ui32; name = str; data = many ui8 >] ->
- `DoABC (lazyInit = 1l, name, data)
- | [<>] ->
- failwith "unknown tag"
+ let parse : int Stream.t -> Abc.t TagType.t = parser
+ [< _ = tag 0 >]->
+ `End
+ | [< _ = tag 9; c = rgb >]->
+ `SetBackgroundColor c
+ | [< _ = tag 43; name = str; anchor = option (tag 1) >] ->
+ `FrameLabel (name,anchor <> None)
+ | [< _ = tag 24 >] ->
+ `Protect
+ | [< _ = tag 56; xs = alist >] ->
+ `ExportAssets xs
+ | [< _ = tag 57; url = str; xs = alist >] ->
+ `ImportAssets (url,xs)
+ | [< _ = tag 58; passwd = str >] ->
+ `EnableDebugger passwd
+ | [< _ = tag 64; _ = ui16; passwd = str >] ->
+ `EnableDebugger2 passwd
+ | [< _ = tag 65; max_rec = ui16; timeout = ui16 >] ->
+ `ScriptLimits (max_rec, timeout)
+ | [< _ = tag 66; depth = ui16; index = ui16 >] ->
+ `SetTabIndex (depth, index)
+ | [< _ = tag 69; (is_metadata, is_as3, use_network) = bits ~f:parser
+ [< _ = ub 3; is_metadata = bit_bool 1; is_as3 = bit_bool 1; _ = ub 2; use_network = bit_bool 1; _ = ub 24 >] ->
+ (is_metadata, is_as3, use_network) >] ->
+ open TagType in
+ `FileAttributes { is_metadata; is_as3; use_network }
+ | [< _ = tag 71; url = str; _ = ui8; _ = ui8; xs = alist >] ->
+ `ImportAssets2 (url,xs)
+ | [< _ = tag 76; xs = alist >] ->
+ `SymbolClass xs
+ | [< _ = tag 77; s = str >] ->
+ `Metadata s
+ | [< _ = tag 78; id = ui16; (left,right,top,bottom) = rect >] ->
+ open SwfType in
+ `DefineScalingGrid (id, {left;right;top;bottom})
+ | [< _ = tag 86;
+ scene_count = eui32; xs = repeat_l scene_count (pair eui32 str);
+ frame_count = eui32; ys = repeat_l frame_count (pair eui32 str); >] ->
+ `DefineSceneAndFrameLabelData (xs, ys)
+ | [< _ = tag 1 >] ->
+ `ShowFrame
+ | [< _ = tag 82; lazyInit = ui32; name = str; data = Abc.read>] ->
+ `DoABC (lazyInit = 1l, name, data)
+ | [<>] ->
+ failwith "unknown tag"
-let of_base tag s =
- read @@ stream tag s
+ let read tag s =
+ parse @@ stream tag s
+end
-val of_base : int -> int Stream.t -> TagType.t
+module type Abc = sig
+ type t
+ val read : int Stream.t -> t
+end
+
+module Make: functor (Abc : Abc) -> sig
+ type t = Abc.t TagType.t
+ val read : int -> int Stream.t -> t
+end
+
+
open Base
open OUnit
+module T = TagIn.Make(
+ struct
+ type t = int
+ let read _ = 0
+ end)
+
let ok tag x xs =
let s =
Stream.of_list @@ SwfBaseOut.to_list xs in
- assert_equal tag (TagIn.of_base x s)
+ assert_equal tag (T.read x s)
let _ = begin "tagIn.ml" >::: [
"End" >:: begin fun () ->
-open Base
-open SwfType
-open TagType
-open SwfBaseOut
+module type Abc = sig
+ type t
+ val write : t -> int list
+end
-let alist xs =
- let symbol (id,name) =
- [`Ui16 id; `Str name] in
- List.concat [
- [`Ui16 (List.length xs)];
- HList.concat_map symbol xs]
+module Make(Abc : Abc) = struct
+ open Base
+ open SwfType
+ open TagType
+ open SwfBaseOut
-let tag id body =
- (id,body)
+ type t = Abc.t TagType.t
-let to_base : TagType.t -> int*SwfBaseOut.s list = function
-(* `PlaceObject (id,depth,matrix) ->
- tag 4 [
- `Ui16 id;
- `Ui16 depth;
- `Matrix matrix
- ]*)
- | `FrameLabel (name,anchor) ->
- if anchor then
- tag 43 [`Str name; `Ui8 1]
- else
- tag 43 [`Str name]
- | `Protect ->
- tag 24 []
- | `End ->
- tag 0 []
- | `ExportAssets xs ->
- tag 56 @@ alist xs
- | `ImportAssets (url, xs) ->
- tag 57 @@ (`Str url)::alist xs
- | `EnableDebugger passwd ->
- tag 58 [`Str passwd]
- | `EnableDebugger2 passwd ->
- tag 64 [`Ui16 0; `Str passwd]
- | `ScriptLimits (recursion, timeout) ->
- tag 65 [`Ui16 recursion; `Ui16 timeout]
- | `SetTabIndex (depth, order) ->
- tag 66 [`Ui16 depth; `Ui16 order]
- | `ShowFrame ->
- tag 1 []
- | `SetBackgroundColor(r,g,b) ->
- tag 9 [`RGB(r,g,b)]
- | `FileAttributes {is_metadata; is_as3; use_network} ->
- tag 69 [
- `Bits [
- UB(3 , 0);
- UB(1 , if is_metadata then 1 else 0);
- UB(1 , if is_as3 then 1 else 0);
- UB(2 , 0);
- UB(1 , if use_network then 1 else 0);
- UB(24, 0)
- ]]
- | `ImportAssets2 (url, xs) ->
- tag 71 @@ (`Str url)::`Ui8 1::`Ui8 0::alist xs
- | `SymbolClass xs ->
- tag 76 @@ alist xs
- | `Metadata xml ->
- tag 77 [`Str xml]
- | `DefineScalingGrid (id, {left;right;top;bottom}) ->
- tag 78 [`Ui16 id; `Rect (left,right,top,bottom)]
- | `DefineSceneAndFrameLabelData (scenes, frames) ->
- let bytes xs =
- (`EUi32 (Int32.of_int @@ List.length xs))::
- HList.concat_map (fun (x,y) -> [`EUi32 x; `Str y]) xs in
- tag 86 @@ List.concat [
- bytes scenes;
- bytes frames;
- ]
- | `DoABC (lazyInit, name, data) ->
- tag 82 @@ List.concat [
- [if lazyInit then `Ui32 1l else `Ui32 0l;
- `Str name];
- List.map (fun n -> `Ui8 n) data ]
+ let alist xs =
+ let symbol (id,name) =
+ [`Ui16 id; `Str name] in
+ List.concat [
+ [`Ui16 (List.length xs)];
+ HList.concat_map symbol xs]
+ let tag id body =
+ (id,body)
+
+ let write : Abc.t TagType.t -> int * SwfBaseOut.s list = function
+ (* `PlaceObject (id,depth,matrix) ->
+ tag 4 [
+ `Ui16 id;
+ `Ui16 depth;
+ `Matrix matrix
+ ]*)
+ | `FrameLabel (name,anchor) ->
+ if anchor then
+ tag 43 [`Str name; `Ui8 1]
+ else
+ tag 43 [`Str name]
+ | `Protect ->
+ tag 24 []
+ | `End ->
+ tag 0 []
+ | `ExportAssets xs ->
+ tag 56 @@ alist xs
+ | `ImportAssets (url, xs) ->
+ tag 57 @@ (`Str url)::alist xs
+ | `EnableDebugger passwd ->
+ tag 58 [`Str passwd]
+ | `EnableDebugger2 passwd ->
+ tag 64 [`Ui16 0; `Str passwd]
+ | `ScriptLimits (recursion, timeout) ->
+ tag 65 [`Ui16 recursion; `Ui16 timeout]
+ | `SetTabIndex (depth, order) ->
+ tag 66 [`Ui16 depth; `Ui16 order]
+ | `ShowFrame ->
+ tag 1 []
+ | `SetBackgroundColor(r,g,b) ->
+ tag 9 [`RGB(r,g,b)]
+ | `FileAttributes {is_metadata; is_as3; use_network} ->
+ tag 69 [
+ `Bits [
+ UB(3 , 0);
+ UB(1 , if is_metadata then 1 else 0);
+ UB(1 , if is_as3 then 1 else 0);
+ UB(2 , 0);
+ UB(1 , if use_network then 1 else 0);
+ UB(24, 0)
+ ]]
+ | `ImportAssets2 (url, xs) ->
+ tag 71 @@ (`Str url)::`Ui8 1::`Ui8 0::alist xs
+ | `SymbolClass xs ->
+ tag 76 @@ alist xs
+ | `Metadata xml ->
+ tag 77 [`Str xml]
+ | `DefineScalingGrid (id, {left;right;top;bottom}) ->
+ tag 78 [`Ui16 id; `Rect (left,right,top,bottom)]
+ | `DefineSceneAndFrameLabelData (scenes, frames) ->
+ let bytes xs =
+ (`EUi32 (Int32.of_int @@ List.length xs))::
+ HList.concat_map (fun (x,y) -> [`EUi32 x; `Str y]) xs in
+ tag 86 @@ List.concat [
+ bytes scenes;
+ bytes frames;
+ ]
+ | `DoABC (lazyInit, name, data) ->
+ tag 82 @@ List.concat [
+ [if lazyInit then `Ui32 1l else `Ui32 0l;
+ `Str name];
+ List.map (fun x -> `Ui8 x) @@ Abc.write data ]
+end
--- /dev/null
+module type Abc = sig
+ type t
+ val write : t -> int list
+end
+
+module Make: functor (Abc : Abc) -> sig
+ type t = Abc.t TagType.t
+ val write : t -> int * SwfBaseOut.s list
+end
open Base
open OUnit
-open TagOut
+
+module T = TagOut.Make(struct
+ type t = int list
+ let write x = x
+ end)
let ok x y =
- assert_equal ~printer:Std.dump x @@ to_base y
+ assert_equal ~printer:Std.dump x @@ T.write y
let _ = begin "tagOut.ml" >::: [
"End" >:: begin fun () ->
}
type alist = (int * string) list
-type t = [
+type 'a t = [
(*| `PlaceObject of int * int * SwfType.matrix*)
| `FrameLabel of string * bool
| `Protect
| `DefineSceneAndFrameLabelData of (int32 * string) list * (int32 * string) list
| `ShowFrame
| `SetBackgroundColor of int * int * int
-| `DoABC of bool * string * int list
+| `DoABC of bool * string * 'a
]
xs +> List.iter (print_endline $
Xml.to_string_fmt $
Swfmill.to_xml $
- Swflib.Abc.disasm $
+ Swflib.Abc.read $
Swflib.BytesIn.of_channel $
open_in_bin)
| [] ->
OSDN Git Service
