Merge c389a95 into a84361f

Makefile

@@ -1,8 +1,21 @@
-tests: $(patsubst %.h,%.out,$(wildcard src/tests/*.h))
+tests:	\
+	$(patsubst %.api.h,%.out.h,$(wildcard src/tests/*.api.h)) \
+	$(patsubst %.api.h,%.out.hs,$(wildcard src/tests/*.api.h)) \
+	$(patsubst %.api.h,%.out.ast,$(wildcard src/tests/*.api.h))
 
-src/tests/%.out: src/tests/%.h all
-	-cd src && ../apigen.native $(patsubst src/%,%,$<) > $(patsubst src/%,%,$@) 2>&1
-	diff -u $@ src/tests/$*.exp
+src/tests/%.out.h: src/tests/%.api.h all
+	-cd src && ../apigen.native -c $(patsubst src/%,%,$<) > $(patsubst src/%,%,$@) 2>&1
+	diff -u $@ src/tests/$*.exp.h
+	rm -f $@
+
+src/tests/%.out.hs: src/tests/%.api.h all
+	-cd src && ../apigen.native -hs Main $(patsubst src/%,%,$<) > $(patsubst src/%,%,$@) 2>&1
+	diff -u $@ src/tests/$*.exp.hs
+	rm -f $@
+
+src/tests/%.out.ast: src/tests/%.api.h all
+	-cd src && ../apigen.native -ast $(patsubst src/%,%,$<) > $(patsubst src/%,%,$@) 2>&1
+	diff -u $@ src/tests/$*.exp.ast
 	rm -f $@
 
 all:

_tags

@@ -1,7 +1,7 @@
 true: use_menhir
 true: annot
 true: bin_annot
-<*/*.{native,byte,ml,mli}>: package(ppx_deriving.std), package(menhirLib)
+<*/*.{native,byte,ml,mli}>: package(ppx_deriving.std), package(menhirLib), package(str)
 
 ".": -include
 "src": include

src/.gitignore

@@ -1,2 +1,5 @@
+/_build
 /setup.data
 /setup.log
+/*.byte
+/*.native

src/Makefile

@@ -3,11 +3,24 @@ BUILDFLAGS := -yaccflags --table
 
 default: test
 
-tests: $(patsubst %.h,%.out,$(wildcard tests/*.h))
+tests:	\
+	$(patsubst %.api.h,%.out.h,$(wildcard tests/*.api.h)) \
+	$(patsubst %.api.h,%.out.hs,$(wildcard tests/*.api.h)) \
+	$(patsubst %.api.h,%.out.ast,$(wildcard tests/*.api.h))
 
-tests/%.out: tests/%.h build
+tests/%.out.h: tests/%.api.h build
 	-./apigen.native $< > $@ 2>&1
-	diff -u $@ tests/$*.exp
+	diff -u $@ tests/$*.exp.h
+	rm -f $@
+
+tests/%.out.hs: tests/%.api.h build
+	-./apigen.native -hs "Main" $< > $@ 2>&1
+	diff -u $@ tests/$*.exp.hs
+	rm -f $@
+
+tests/%.out.ast: tests/%.api.h build
+	-./apigen.native -ast $< > $@ 2>&1
+	diff -u $@ tests/$*.exp.ast
 	rm -f $@
 
 # We have our own for now, because upstream is broken.

src/_oasis

@@ -13,7 +13,7 @@ Executable apidsl
   Path:           .
   BuildTools:     ocamlbuild
   MainIs:         apigen.ml
-  BuildDepends:   ppx_deriving.std, menhirLib
+  BuildDepends:   ppx_deriving.std, menhirLib, str
   CompiledObject: best
 
 Test regressions

src/_tags

@@ -1,5 +1,5 @@
 # OASIS_START
-# DO NOT EDIT (digest: 95032ee7dc868e85040dd63734005b82)
+# DO NOT EDIT (digest: 0e9d5e0301eeace397df289756f2c39e)
 # Ignore VCS directories, you can use the same kind of rule outside
 # OASIS_START/STOP if you want to exclude directories that contains
 # useless stuff for the build process
@@ -17,8 +17,10 @@ true: annot, bin_annot
 # Executable apidsl
 <apigen.{native,byte}>: package(menhirLib)
 <apigen.{native,byte}>: package(ppx_deriving.std)
+<apigen.{native,byte}>: package(str)
 <*.ml{,i,y}>: package(menhirLib)
 <*.ml{,i,y}>: package(ppx_deriving.std)
+<*.ml{,i,y}>: package(str)
 # OASIS_STOP
 
 true: use_menhir

src/apiAst.ml

@@ -37,7 +37,7 @@ type 'id type_name =
   | Ty_UName of 'id uname
   | Ty_LName of 'id lname
   | Ty_TVar of 'id lname
-  | Ty_Array of 'id lname * 'id size_spec
+  | Ty_Array of 'id type_name * 'id size_spec
   | Ty_Auto
   | Ty_Const of 'id type_name
   | Ty_Pointer of 'id type_name

src/apiCodegen.ml

@@ -112,9 +112,9 @@ let rec cg_type_name fmt = function
   | Ty_TVar lname ->
       Format.fprintf fmt "`%a "
         cg_lname lname
-  | Ty_Array (lname, size_spec) ->
+  | Ty_Array (type_name, size_spec) ->
       Format.fprintf fmt "%a%a "
-        cg_lname lname
+        cg_type_name type_name
         cg_size_spec size_spec
   | Ty_Auto ->
       Format.fprintf fmt "auto "

src/apiFold.ml

@@ -90,8 +90,8 @@ let visit_type_name v state = function
   | Ty_TVar lname ->
       let state = v.fold_lname v state lname in
       state
-  | Ty_Array (lname, size_spec) ->
-      let state = v.fold_lname v state lname in
+  | Ty_Array (type_name, size_spec) ->
+      let state = v.fold_type_name v state type_name in
       let state = v.fold_size_spec v state size_spec in
       state
   | Ty_Auto ->

src/apiFoldMap.ml

@@ -97,10 +97,10 @@ let visit_type_name v state = function
   | Ty_TVar lname ->
       let state, lname = v.fold_lname v state lname in
       state, Ty_TVar lname
-  | Ty_Array (lname, size_spec) ->
-      let state, lname = v.fold_lname v state lname in
+  | Ty_Array (type_name, size_spec) ->
+      let state, type_name = v.fold_type_name v state type_name in
       let state, size_spec = v.fold_size_spec v state size_spec in
-      state, Ty_Array (lname, size_spec)
+      state, Ty_Array (type_name, size_spec)
   | Ty_Auto ->
       state, Ty_Auto
   | Ty_Const type_name ->

src/apiMap.ml

@@ -90,10 +90,10 @@ let visit_type_name v state = function
   | Ty_TVar lname ->
       let lname = v.map_lname v state lname in
       Ty_TVar lname
-  | Ty_Array (lname, size_spec) ->
-      let lname = v.map_lname v state lname in
+  | Ty_Array (type_name, size_spec) ->
+      let type_name = v.map_type_name v state type_name in
       let size_spec = v.map_size_spec v state size_spec in
-      Ty_Array (lname, size_spec)
+      Ty_Array (type_name, size_spec)
   | Ty_Auto ->
       Ty_Auto
   | Ty_Const type_name ->

src/apiParser.mly

@@ -228,7 +228,7 @@ type_name
 	| lname STAR
 		{ Ty_Pointer (Ty_LName $1) }
 	| lname LSQBRACK size_spec RSQBRACK
-		{ Ty_Array ($1, $3) }
+		{ Ty_Array (Ty_LName $1, $3) }
 	| BACKTICK lname
 		{ Ty_TVar $2 }
 	| ANY

src/apiPasses.ml

@@ -1,3 +1,12 @@
+let haskell_preamble = "
+import           Data.Int                  (Int16, Int32, Int64, Int8)
+import           Data.Word                 (Word16, Word32, Word64, Word8)
+import           Foreign.C.String          (CString, withCString)
+import           Foreign.C.Types           (CInt (..), CSize (..))
+import           Foreign.Ptr               (FunPtr, Ptr)
+"
+
+
 let pass msg f x =
   (*print_endline msg;*)
   f x
@@ -57,6 +66,61 @@ let all pre api post =
   Format.flush_str_formatter ()
 
 
+let haskell modname api =
+  let api =
+    api
+    |> pass "GetSetStruct" GetSetStruct.transform
+    |> pass "ConstFunction" ConstFunction.transform
+    |> pass "ThisComments" ThisComments.transform
+    |> pass "ErrorNULL" ErrorNULL.transform
+    |> pass "ErrorOK" ErrorOK.transform
+    |> pass "GetSetParams" GetSetParams.transform
+    |> pass "LengthParams" LengthParams.transform
+    |> pass "ThisParams" ThisParams.transform
+    |> pass "ErrorSplitFromFunction" ErrorSplitFromFunction.transform
+    |> pass "ExtractSymbols" (fun api -> ExtractSymbols.extract api, api)
+    |> pass "ScopeBinding" ScopeBinding.transform
+    |> pass "EventRename" EventRename.transform
+    |> pass "EventApply" EventApply.transform
+    |> pass "ErrorEnumsRename" ErrorEnumsRename.transform
+    |> pass "GetSetRename" GetSetRename.transform
+    |> pass "GetSetFlatten" GetSetFlatten.transform
+    |> pass "StaticApply" StaticApply.transform
+    |> pass "StructTypes" StructTypes.transform
+    |> pass "ClassToNamespace" ClassToNamespace.transform
+    |> pass "NamespaceApplyEvents" NamespaceApplyEvents.transform
+    |> pass "NamespaceApply" (NamespaceApply.transform 1)
+    |> pass "NamespaceFlatten" (NamespaceFlatten.transform 1)
+    |> pass "ErrorEnumsAddERR" ErrorEnumsAddERR.transform
+    |> pass "ErrorEnums" ErrorEnums.transform
+    |> pass "ErrorParams" ErrorParams.transform
+    |> pass "EventFunction" EventFunction.transform
+    |> pass "EventCloneFunctionName" EventCloneFunctionName.transform
+    |> pass "EventParams" EventParams.transform
+    |> pass "EventComments" EventComments.transform
+    |> pass "EventFlatten" EventFlatten.transform
+    |> pass "NamespaceApply" (NamespaceApply.transform 0)
+    |> pass "NamespaceFlatten" (NamespaceFlatten.transform 0)
+    |> pass "EnumNamespaceApply" EnumNamespaceApply.transform
+    |> pass "EnumNamespaceFlatten" EnumNamespaceFlatten.transform
+    |> pass "EnumApply" EnumApply.transform
+    |> pass "StaticElide" StaticElide.transform
+    |> pass "HaskellCamelCase" HaskellCamelCase.transform
+    |> pass "HaskellTypes" HaskellTypes.transform
+    |> pass "ScopeBinding" ScopeBinding.Inverse.transform
+    |> pass "EnumBitmasks" EnumBitmasks.transform
+    |> pass "HaskellFromC" HaskellFromC.transform
+    |> pass "HaskellComments" HaskellComments.transform
+  in
+
+  Format.fprintf Format.str_formatter "module %s where@," modname;
+  Format.fprintf Format.str_formatter "%s" haskell_preamble;
+  Format.fprintf Format.str_formatter "%a\n"
+    HaskellCodegen.cg_decls api;
+
+  Format.flush_str_formatter ()
+
+
 let format_error (token, start_p, end_p) =
   let open Lexing in
   Printf.sprintf "%s:%d:%d: error at %s"

src/apigen.ml

@@ -1,3 +1,8 @@
+type outlang =
+  | Ast
+  | C
+  | Haskell of string
+
 let parse_file file =
   let fh = open_in file in
   let lexbuf = Lexing.from_channel fh in
@@ -13,16 +18,21 @@ let parse_file file =
   api
 
 
-let main input =
+let main outlang input =
   let ApiAst.Api (pre, api, post) = parse_file input in
 
-  (*print_endline (ApiAst.show_decls Format.pp_print_string api);*)
-  print_string (ApiPasses.all pre api post);
+  match outlang with
+  | C               -> print_string (ApiPasses.all pre api post)
+  | Haskell modname -> print_string (ApiPasses.haskell modname api)
+  | Ast             -> print_endline (ApiAst.show_decls Format.pp_print_string api)
 ;;
 
 
 let () =
   (*Printexc.record_backtrace true;*)
   match Sys.argv with
-  | [|_; input|] -> main input
+  | [|_; input|]
+  | [|_; "-c"; input|] -> main C input
+  | [|_; "-hs"; modname; input|] -> main (Haskell modname) input
+  | [|_; "-ast"; input|] -> main Ast input
   | _ -> print_endline "Usage: apigen <file>"

src/arrayToPointer.ml

@@ -4,8 +4,8 @@ open ApiMap
 
 let map_type_name v symtab = function
 
-  | Ty_Array (lname, _) ->
-      Ty_Pointer (Ty_LName lname)
+  | Ty_Array (type_name, _) ->
+      Ty_Pointer type_name
 
   | type_name ->
       visit_type_name v symtab type_name

src/configure

@@ -0,0 +1,27 @@
+#!/bin/sh
+
+# OASIS_START
+# DO NOT EDIT (digest: dc86c2ad450f91ca10c931b6045d0499)
+set -e
+
+FST=true
+for i in "$@"; do
+  if $FST; then
+    set --
+    FST=false
+  fi
+
+  case $i in
+    --*=*)
+      ARG=${i%%=*}
+      VAL=${i##*=}
+      set -- "$@" "$ARG" "$VAL"
+      ;;
+    *)
+      set -- "$@" "$i"
+      ;;
+  esac
+done
+
+ocaml setup.ml -configure "$@"
+# OASIS_STOP

src/enumApply.ml

@@ -4,8 +4,8 @@ open ApiFold
 
 let fold_enumerator v (symtab, enum) = function
   | Enum_Name (comment, uname, value) ->
-      SymbolTable.rename symtab uname
-        (fun name -> enum ^ "_" ^ name), enum
+      SymbolTable.rename uname
+        (fun name -> enum ^ "_" ^ name) symtab, enum
 
   | enumerator ->
       visit_enumerator v (symtab, enum) enumerator

src/enumNamespaceApply.ml

@@ -16,8 +16,8 @@ let resolve_ns symtab ns =
 let fold_enumerator v (symtab, ns) = function
   | Enum_Name (comment, uname, value) ->
       let symtab =
-        SymbolTable.rename symtab uname
-          (prepend_ns (resolve_ns symtab ns))
+        SymbolTable.rename uname
+          (prepend_ns (resolve_ns symtab ns)) symtab
       in
       (symtab, ns)
 

src/errorEnumsAddERR.ml

@@ -4,8 +4,8 @@ open ApiFold
 
 let fold_decl v symtab = function
   | Decl_Error (lname, enumerators) ->
-      SymbolTable.rename symtab lname
-        (fun name -> "ERR_" ^ name)
+      SymbolTable.rename lname
+        (fun name -> "ERR_" ^ name) symtab
 
   | decl ->
       visit_decl v symtab decl

src/errorEnumsRename.ml

@@ -4,11 +4,11 @@ open ApiFold
 
 let fold_decl v symtab = function
   | Decl_Error (lname, enumerators) ->
-      SymbolTable.rename symtab lname
+      SymbolTable.rename lname
         (fun name ->
            assert (String.sub name 0 6 = "error ");
            String.uppercase (String.sub name 6 (String.length name - 6))
-        )
+        ) symtab
 
   | decl ->
       visit_decl v symtab decl

src/eventApply.ml

@@ -4,8 +4,8 @@ open ApiFold
 
 let fold_decl v (symtab, event) = function
   | Decl_Typedef (_, lname, _) ->
-      SymbolTable.rename symtab lname
-        (fun name -> event ^ "_" ^ name), event
+      SymbolTable.rename lname
+        (fun name -> event ^ "_" ^ name) symtab, event
 
   | Decl_Event (lname, _, decls) ->
       let symtab, _ =

src/eventCloneFunctionName.ml

@@ -8,8 +8,8 @@ let fold_decl v (symtab, in_event) = function
       let symtab, lname = SymbolTable.clone_symbol symtab lname in
 
       let symtab =
-        SymbolTable.rename symtab lname
-          (fun name -> "callback_" ^ name)
+        SymbolTable.rename lname
+          (fun name -> "callback_" ^ name) symtab
       in
 
       (symtab, in_event), Decl_Function (type_name, lname, parameters, error_list)

src/eventRename.ml

@@ -4,11 +4,11 @@ open ApiFold
 
 let fold_decl v symtab = function
   | Decl_Event (lname, _, _) ->
-      SymbolTable.rename symtab lname
+      SymbolTable.rename lname
         (fun name ->
            assert (String.sub name 0 6 = "event ");
            String.sub name 6 (String.length name - 6)
-        )
+        ) symtab
 
   | decl ->
       visit_decl v symtab decl