From b93342298f2d043815df41dd404a27d34793e047 Mon Sep 17 00:00:00 2001
From: Alfredo Beaumont <alfredo.beaumont@gmail.com>
Date: Thu, 10 Jul 2008 23:59:43 +0200
Subject: [PATCH] Initial import of etags vocab, that generates an word index
 in Emacs etags format

---
 extra/ctags/etags/etags-tests.factor | 47 +++++++++++++++++++
 extra/ctags/etags/etags.factor       | 68 ++++++++++++++++++++++++++++
 2 files changed, 115 insertions(+)
 create mode 100644 extra/ctags/etags/etags-tests.factor
 create mode 100644 extra/ctags/etags/etags.factor

diff --git a/extra/ctags/etags/etags-tests.factor b/extra/ctags/etags/etags-tests.factor
new file mode 100644
index 0000000000..fbd9a65186
--- /dev/null
+++ b/extra/ctags/etags/etags-tests.factor
@@ -0,0 +1,47 @@
+USING: kernel ctags.etags tools.test io.backend sequences arrays prettyprint hashtables assocs ;
+IN: ctags.etags.tests
+
+
+[ H{ { "path" V{ if { "path" 1 } } } } ]
+[ H{ } clone dup V{ if { "path" 1 } } "path" rot set-at ] unit-test
+
+[ { "path" V{ if { "path" 1 } } } ]
+[ H{ } clone dup { "path" V{ if { "path" 1 } } } "path" rot set-at "path" swap at ] unit-test
+
+
+[ V{ if { "path" 1 } } ]
+[ "path" H{ { "path" V{ if { "path" 1 } } } } at ] unit-test
+
+[ "path" ] [ { if { "path" 1 } } ctag-path ] unit-test
+
+[ V{ } ]
+[ "path" H{ } clone ctag-at ] unit-test
+
+[ V{ if { "path" 1 } } ]
+[ "path" H{ { "path" V{ if { "path" 1 } } } } ctag-at ] unit-test
+
+[ { if 28 } ]
+[ { if { "resource:core/kernel/kernel.factor" 28 } } ctag-value ] unit-test
+
+[ V{ } ] [ { if { "path" 1 } } H{ } clone ctag-hashvalue ] unit-test
+
+[ V{ if { "path" 1 } } ]
+[ { if { "path" 1 } }
+  { { "path" V{ if { "path" 1 } } } } >hashtable
+  ctag-hashvalue
+] unit-test
+
+[ H{ { "path" V{ { if  1 } } } } ]
+[ { if { "path" 1 } } H{ } clone ctag-add ] unit-test
+
+[ H{ { "path" V{ { if 1 } } } } ]
+[ { { if { "path" 1 } } } ctag-hash ] unit-test
+
+[ "if28,704" ]
+[ "resource:core/kernel/kernel.factor" { if 28 } etag ] unit-test
+
+! [ V{ "" "resource:core/kernel/kernel.factor,22" "if28,704" "unless31,755" } ]
+! [ { { "resource:core/kernel/kernel.factor"
+!      V{ { if 28 }
+!         { unless 31 } } } } etag-strings ] unit-test
+
diff --git a/extra/ctags/etags/etags.factor b/extra/ctags/etags/etags.factor
new file mode 100644
index 0000000000..227f146307
--- /dev/null
+++ b/extra/ctags/etags/etags.factor
@@ -0,0 +1,68 @@
+! Copyright (C) 2008 Alfredo Beaumont
+! See http://factorcode.org/license.txt for BSD license.
+
+! Emacs Etags generator
+! Alfredo Beaumont <alfredo.beaumont@gmail.com>
+USING: kernel sequences sorting assocs words prettyprint ctags
+io.encodings.ascii io.files math math.parser namespaces strings locals
+shuffle io.backend memoize ;
+IN: ctags.etags
+
+: ctag-path ( alist -- path )
+  second first ;
+
+: ctag-at ( key hash -- vector )
+  at [ V{ } clone ] unless* ;
+
+: ctag-hashvalue ( alist hash -- vector )
+  [ ctag-path ] dip ctag-at ;
+
+: ctag-value ( ctag -- seq )
+  dup [ first , second second , ] { } make ;
+
+: ctag-add ( ctag hash -- hash )
+  [ ctag-hashvalue ] 2keep [ dup ctag-path [ ctag-value suffix ] dip ] dip [ set-at ] keep ;
+    
+: ctag-hash ( seq -- hash )
+  H{ } clone swap [ swap ctag-add ] each ;
+
+: line>bytes ( n seq -- bytes )
+  nth length 1+ ;
+
+: lines>bytes ( n seq -- bytes )
+  over zero? [ line>bytes ] [ [ [ 1 - ] dip lines>bytes ] 2keep line>bytes + ] if ;
+
+: file>bytes ( n path -- bytes )
+  ascii file-lines lines>bytes ;
+
+SYMBOL: resource    
+: etag ( path seq -- str )
+  [
+    dup first ?word-name %
+    1 HEX: 7f <string> %
+    second dup number>string %
+    1 CHAR: , <string> %
+    2 - swap file>bytes number>string %
+  ] "" make ;
+
+: etag-entry ( alist -- alist path )
+  [ first ] keep swap ;
+
+: vector-length ( vector -- n )
+  0 [ length + ] reduce ;
+
+: etag-header ( n path -- str )
+  [
+    %
+    1 CHAR: , <string> %
+    number>string %
+  ] "" make ;
+
+: etag-strings ( alist -- seq )
+  { } swap [ etag-entry resource [ second [ resource get swap etag ] map dup vector-length resource get normalize-path etag-header prefix 1 HEX: 0c <string> prefix ] with-variable append ] each ;
+
+: etags-write ( alist path -- )
+  [ etag-strings ] dip ascii set-file-lines ; 
+
+: etags ( path -- )
+  (ctags) sort-values ctag-hash >alist swap etags-write ;
\ No newline at end of file