extra/ctags/etags/etags.factor

   1 ! Copyright (C) 2008 Alfredo Beaumont
   2 ! See http://factorcode.org/license.txt for BSD license.
   3
   4 ! Emacs Etags generator
   5 ! Alfredo Beaumont <alfredo.beaumont@gmail.com>
   6 USING: kernel sequences sorting assocs words prettyprint ctags
   7 io.encodings.ascii io.files math math.parser namespaces strings locals
   8 shuffle io.backend arrays ;
   9 IN: ctags.etags
  10
  11 : ctag-path ( alist -- path )
  12   second first ;
  13
  14 : ctag-at ( key hash -- vector )
  15   at [ V{ } clone ] unless* ;
  16
  17 : ctag-hashvalue ( alist hash -- vector )
  18   [ ctag-path ] dip ctag-at ;
  19
  20 : ctag-value ( ctag -- seq )
  21   dup [ first , second second , ] { } make ;
  22
  23 : ctag-add ( ctag hash -- hash )
  24   [ ctag-hashvalue ] 2keep [
  25     dup ctag-path [ ctag-value suffix ] dip
  26   ] dip [ set-at ] keep ;
  27
  28 : ctag-hash ( seq -- hash )
  29   H{ } clone swap [ swap ctag-add ] each ;
  30
  31 : lines>bytes ( seq n -- bytes )
  32   head 0 [ length 1+ + ] reduce ;
  33
  34 : file>lines ( resource -- lines )
  35   ascii file-lines ;
  36
  37 : etag ( lines seq -- str )
  38   [
  39     dup first ?word-name %
  40     1 HEX: 7f <string> %
  41     second dup number>string %
  42     1 CHAR: , <string> %
  43     1- lines>bytes number>string %
  44   ] "" make ;
  45
  46 : etag-entry ( alist -- alist array )
  47   [ first ] keep swap [ file>lines ] keep 2array ;
  48
  49 : vector-length ( vector -- n )
  50   0 [ length + ] reduce ;
  51
  52 : <header> ( n path -- str )
  53   [
  54     %
  55     1 CHAR: , <string> %
  56     number>string %
  57   ] "" make ;
  58
  59 : etag-header ( vec1 n resource -- vec2 )
  60   normalize-path <header> prefix
  61   1 HEX: 0c <string> prefix ;
  62
  63 SYMBOL: resource
  64 : etag-strings ( alist -- seq )
  65   { } swap [
  66     etag-entry resource [
  67       second [
  68         resource get first swap etag
  69       ] map dup vector-length
  70       resource get second
  71     ] with-variable
  72     etag-header append
  73   ] each ;
  74
  75 : etags-write ( alist path -- )
  76   [ etag-strings ] dip ascii set-file-lines ;
  77
  78 : etags ( path -- )
  79   (ctags) sort-values ctag-hash >alist swap etags-write ;