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 memoize ;
   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 : line>bytes ( n seq -- bytes )
  32   nth length 1+ ;
  33
  34 : lines>bytes ( n seq -- bytes )
  35   over zero? [
  36     line>bytes ] [
  37     [
  38       [ 1- ] dip lines>bytes
  39     ] 2keep line>bytes +
  40   ] if ;
  41
  42 : file>bytes ( n path -- bytes )
  43   ascii file-lines lines>bytes ;
  44
  45 : etag ( path seq -- str )
  46   [
  47     dup first ?word-name %
  48     1 HEX: 7f <string> %
  49     second dup number>string %
  50     1 CHAR: , <string> %
  51     2 - swap file>bytes number>string %
  52   ] "" make ;
  53
  54 : etag-entry ( alist -- alist path )
  55   [ first ] keep swap ;
  56
  57 : vector-length ( vector -- n )
  58   0 [ length + ] reduce ;
  59
  60 : <header> ( n path -- str )
  61   [
  62     %
  63     1 CHAR: , <string> %
  64     number>string %
  65   ] "" make ;
  66
  67 : etag-header ( vec1 n resource -- vec2 )
  68   normalize-path <header> prefix
  69   1 HEX: 0c <string> prefix ;
  70
  71 SYMBOL: resource
  72 : etag-strings ( alist -- seq )
  73   { } swap [
  74     etag-entry resource [
  75       second [
  76         resource get swap etag
  77       ] map dup vector-length
  78       resource get
  79     ] with-variable
  80     etag-header append
  81   ] each ;
  82
  83 : etags-write ( alist path -- )
  84   [ etag-strings ] dip ascii set-file-lines ;
  85
  86 : etags ( path -- )
  87   (ctags) sort-values ctag-hash >alist swap etags-write ;