Source

opycaml / module.pl

Full commit
#!/usr/bin/perl

get_class_deps();
get_comments();
filter();

%deps;

# obtain class dependency from type.ml
sub get_class_deps {
    open(IN, "type.ml");
    while(<IN>){
	if( /type\s+(_[A-Z][a-z0-9]+)\s*=\s*\[([^\]]+)\]/ ){
	    my $cls = $1;
	    my $deps = $2;
	    $cls =~ s/^_//;
	    $deps =~ s/`_[A-Z][a-z]+//g;
	    $deps =~ s/\(\*.*\*\)//g;
	    $deps =~ s/_([A-Z])/$1/g;
	    my @deps = split(/\s|\|/, $deps);
	    $deps{$cls} = \@deps;
	    printf STDERR "$cls: %s\n", join(' ', @{$deps{$cls}});
	}
    }
    close(IN);
}


sub get_comments {
    for $i (@ARGV){
	open(IN, "$i");
	while(<IN>){
	    if( /^typedef/ ){ next; }
	    if( /^\s*$/ ){ next; }
	    if( /^\s*\/\// ){ next; }
	    if( /(Py[A-Za-z_0-9]+)\(/ ){
		$func_name = $1;
		if( /\[internal\]/ ){
		    $internal{$func_name} = 1;
		}
		if( /\[mlname ([^\]]+)\]/ ){
		    $mlname{$func_name} = $1;
		}
		while(<IN>){
		    if( /^\/\/\s*/ ){
			$_ = $';
		        s/\(\*/( */g;
		        $comment{$func_name} = "$comment{$func_name}$_";
		    } else { last; }
                }  
	    }
	}
    }
}

%printed_module;

sub print_module {
    my $k = $_[0];

    if( $printed_module{$k} ){ return; }
    
    for my $kk (@{$deps{$k}}) {
	print_module($kk);
    }

    print STDERR "printing $k\n";
    $printed_module{$k} = 1;

    print "module $k = struct\n";
    print $mod{$k};
    if( $mod{$k} =~ /external check +: \[>_Object\] t -> bool/ ){
        print 
"  (** coercion to [_$k t]. Raises Coercion when impossible *)
  let coerce : [>_Object] t -> _$k t = fun t ->
    if check t then unsafe_coerce t else raise Coercion
  ;;

  (** coercion to [_$k t]. Return None when impossible *)
  let coerce_opt : [>_Object] t -> _$k t option = fun t ->
    if check t then Some (unsafe_coerce t) else None
  ;;
";
    }
    print "end\n\n";
}

sub filter {
    open(IN, "auto.ml");
    while(<IN>){
        if( /^(type|and) [a-z][A-Za-z_0-9]+( =.*)?$/ ){ next; }
        if ( s/^external // ){
	    $def = <IN>;
	    s/^py([A-Za-z]*)?_([^ ]*)//;

	    $k = $1; # kind
	    $f = $2;
	    $rem = $';

	    $fname = $&;
	    $fname =~ s/py/Py/;
	    $comment = $comment{$fname};
            $comment =~ s/\n/\n      /g;
            # P4 parses << and >> in comments specially!
            $comment =~ s/<</LessLess/g;
            $comment =~ s/>>/GreaterGreater/g;
            $internal = $internal{$fname};

            # $f =~ s/GET_SIZE/get_size/;
            if( $f =~ /^[A-Z_]+$/ ){
                $f = "_$f";
            } else {
      	        $f = lcfirst($f);
            }
    	    $f =~ s/^(type|and|or|new)$/$1_/;
	    if( $mlname{$fname} ){ $f = $mlname{$fname}; }
            if( $internal ){ $f = "_internal_$f"; }
            $f =~ s/_wrap$//; # [wrap] cleanup

	    # pyAbcObject => pyAbc (but keep pyObject )
            $rem =~ s/py([A-z]+)Object/py$1/g;

            # rem includes type 
            $rem =~ s/py([A-z]+)_p_option/py$1 option/g;
            $rem =~ s/py([A-z]+)_p_noincr/py$1/g;
            $rem =~ s/py([A-z]+)_p_incr/py$1/g;
            $rem =~ s/py([A-z]+)_p/py$1/g;
	    # FILE
	    $rem =~ s/fILE/_FILE/g;

	    # introduce polymorphism (pretty dirty)
	    # pyAbcd ... -> ==> [>_Abcd] t ... ->
	    while( $rem =~ s/py([A-Z][A-z]+)(.*->)/[>_$1] t$2/g ){
	    }
	    # return types have no polymorphism
	    $rem =~ s/py([A-Z][A-z]+)/_$1 t/g;

    	    if ( $k eq "" ){ $k = "Base"; }
            if( $comment ne "" ){
    	        $mod{$k} = "$mod{$k}  external $f $rem$def  (** $comment **)\n\n";
            } else {
    	        $mod{$k} = "$mod{$k}  external $f $rem$def\n";
            }
        } 
    }

    print "open Type\n\n";
    for $k (keys %mod){
	print_module($k);
    }
    # a dummy module to indicate the end of the file
    print "module Unicode = struct end\n";
    print "module List = struct end\n";
    print "module Slice = struct end\n";
    print "module Long = struct end\n";
}