;; $Id: string57.scm,v 1.1 1998/03/16 08:00:02 foner Exp $

(require 'substring:find-char)
(require 'substring:find-chars)
(require 'substring:find-string)
(require 'substring:prefix?)
(require 'char-set?)
(require 'char-set:member?)

;; FIND

;;+doc
;; procedure: string:search:find-string
;; arguments: string
;;
;; Attempts to find the given STRING.  If the item is
;; found, the position is updated to ...? XXX
;; Equivalent to "find" in Icon.
;;-doc

(define string:search:find-string
  (lambda (p)
    (let ((a (substring:find-string p)))
      (lambda (s ss se y n r)
	(a ss se (lambda (i _ r) (y i r)) (lambda (r) r) r)))))


;;+doc
;; procedure: string:search:find-char
;; arguments: char
;;
;; Attempts to find the given CHAR.  If the item is
;; found, the position is updated to ...? XXX
;; Equivalent to "find" in Icon.
;;-doc

(define string:search:find-char
  (lambda (p)
    (lambda (s ss se y n r)
      (substring:find-char s ss se p (lambda (i _ r) (y i r)) (lambda (r) r) r))))


;;+doc
;; procedure: string:search:find$
;; arguments: none
;;
;; Locates the end of the string
;;-doc

(define string:search:find$
  (lambda ()
    (lambda (s ss se y n r)
      (y se r))))


;;+doc
;; procedure: string:search:find-chars
;; arguments: char-set
;;
;; Attempts to find the given CHAR-SET.  If the item is
;; found, the position is updated to ...? XXX
;; Equivalent to "find" in Icon.
;;-doc

(define string:search:find-chars
  (lambda (p)
    (lambda (s ss se y n r)
      (substring:find-chars s ss se p (lambda (i _ r) (y i r)) (lambda (r) r) r))))


;;+doc
;; procedure: string:search:find
;; arguments: (string|char-set|char)
;;
;; Attempts to find the given STRING/CHAR-SET/CHAR.  If the item is
;; found, the position is updated to ...? XXX
;; Equivalent to "find" in Icon.
;;-doc

(define string:search:find
  (lambda (p)
    (cond
     ((char-set? p) (string:search:find-chars p))
     ((string? p) (string:search:find-string p))
     ((char? p) (string:search:find-char p))
     (else (error 'string:search:find "invalid pattern type")))))


;; MATCH

;;+doc
;; procedure: string:search:match-string
;; arguments: string
;;
;; Attempts to match the given STRING.  If the match
;; succeeds, the position is updated to the first character after the 
;; end of the string.  Equivalent to "match" in Icon.
;;-doc

(define string:search:match-string
  (lambda (p)
    (lambda (s ss se y n r)
      (let ((i (substring:prefix? p 0 (string-length p) s ss se)))
	(if i (y i r) (n r))))))


;;+doc
;; procedure: string:search:match-char
;; arguments: char
;;
;; Attempts to match the given CHAR.  If the match
;; succeeds, the position is updated to the first character after the
;; character.  Equivalent to "match" in Icon.
;;-doc

(define string:search:match-char
  (lambda (c)
    (lambda (s ss se y n r)
      (if (and (< ss se) (char=? c (string-ref s ss))) (y (+ ss 1) r) (n r)))))


;;+doc
;; procedure: string:search:match-chars
;; arguments: char-set
;;
;; Attempts to match the given CHAR.  If the match
;; succeeds, the position is updated to the first character after the
;; character.  Equivalent to "match" in Icon.
;;-doc

(define string:search:match-chars
  (lambda (cs)
    (lambda (s ss se y n r)
      (if (and (< ss se) (char-set:member? cs (string-ref s ss)))
	  (y (+ ss 1) r)
	  (n r)))))

;;+doc
;; procedure: string:search:match$
;; arguments: none
;;
;; Locates the end of the string
;;-doc

(define string:search:match$
  (lambda ()
    (lambda (s ss se y n r)
      (if (= ss se) (y ss r) (n r)))))


;;+doc
;; procedure: string:search:match
;; arguments: (string|char-set|char)
;;
;; Attempts to match the given STRING/CHAR-SET/CHAR.  If the match
;; succeeds, the position is updated to the first character after the matching
;; item.  Equivalent to "match" in Icon.
;;-doc

(define string:search:match
  (lambda (p)
    (cond
     ((char-set? p) (string:search:match-chars p))
     ((string? p) (string:search:match-string p))
     ((char? p) (string:search:match-char p))
     (else (error 'string:search:match "invalid pattern type")))))


;; SKIP

(define string:search:skip-string*
  (lambda (p)
    (lambda (s ss se y n r)
      (let loop ((ss ss))
	(let ((i (substring:prefix? p 0 (string-length p) s ss se)))
	  (if i (loop i) (y ss r)))))))

(define string:search:skip-char*
  (lambda (p)
    (lambda (s ss se y n r)
      (if (>= ss se)
	  (n r)
	  (let loop ((i ss))
	    (cond ((= i se) (y i r))
		  ((char=? p (string-ref s i)) (loop (+ i 1)))
		  (else (y i r))))))))

(define string:search:skip-chars*
  (lambda (cs)
    (lambda (s ss se y n r)
      (if (>= ss se)
	  (n r)
	  (let loop ((i ss))
	    (cond ((= i se) (y i r))
		  ((char-set:member? cs (string-ref s i)) (loop (+ i 1)))
		  (else (y i r))))))))


(define string:search:skip-int
  (lambda (p)
    (lambda (s ss se y n r)
      (let ((i (+ ss p)))
	(if (< i se) (y i r) (n r))))))

;;+doc
;; procedure: string:search:skip*
;; arguments: (string|char|char-set|int)
;;
;; Attempts to match the given STRING/CHAR-SET/CHAR.  If the match
;; succeeds, the position is updated to the first character after the matching
;; item.  Equivalent to "match" in Icon.
;;-doc

(define string:search:skip*
  (lambda (p)
    (cond
     ((char-set? p) (string:search:skip-chars* p))
     ((char? p) (string:search:skip-char* p))
     ((string? p) (string:search:skip-string* p))
     ((integer? p) (string:search:skip-int p))
     (else (error 'string:search:skip "invalid pattern type")))))


(define string:search:skip-char+
  (lambda (c)
    (lambda (s ss se y n r)
      (if (or (>= ss se) (not (char=? c (string-ref s ss))))
	  (n r)
	  (let loop ((i (+ ss 1)))
	    (cond ((= i se) (y i r))
		  ((char=? c (string-ref s i)) (loop (+ i 1)))
		  (else (y i r))))))))

(define string:search:skip-chars+
  (lambda (cs)
    (lambda (s ss se y n r)
      (if (or (>= ss se) (not (char-set:member? cs (string-ref s ss))))
	  (n r)
	  (let loop ((i (+ ss 1)))
	    (cond ((= i se) (y i r))
		  ((char-set:member? cs (string-ref s i)) (loop (+ i 1)))
		  (else (y i r))))))))

(define string:search:skip+
  (lambda (p)
    (cond
     ((char-set? p) (string:search:skip-chars+ p))
     ((char? p) (string:search:skip-char+ p))
     ((integer? p) (string:search:skip-int p))
     (else (error 'string:search:skip "invalid pattern type")))))

;;

;;+doc
;; procedure: string:search:save-pos
;;
;; Save the current position.  Prior to the introduction of SAVE-STRING
;; this was used to delimit areas which were subsequently extracted by
;; the user.
;;-doc

(define string:search:save-pos
  (lambda ()
    (lambda (s ss se y n r)
      (y ss (cons ss r)))))


;;+doc
;; procedure: string:search:save-string
;; argument: actions ...
;; 
;; Save the string that is delimited by the implicit position
;; and the point left at the end of the implicit actions.
;; Leaves the implicit position at the end marked by the actions and
;; leaves the result containing the string preceded by any additions
;; to the result done whilst performing ACTIONS.
;; For example, the following will extract out the name of the 
;; file that is being included.
;;
;; > (substring:search "#include \"foo.h\"" 0 16 
;;     (lambda (file-name)
;;       (display "include file-name is ")
;;       (display file-name))
;;     (lambda (_) 'failed)
;;     (match "#") (skip* whitespace) (match "include") (skip* whitespace)
;;     (match #\") (save-string (find #\")))
;; ("foo.h")
;;-doc

(define string:search:save-string
  (lambda actions
    (lambda (s ss se y n r)
      (let* ((yy (lambda (end . r) (y end (cons (substring s ss end) r)))))
	(substring:search:and:: s ss se yy n r actions)))))



;; XXX: this is wrong, don't use it.

(define substring:search:or::
  (lambda (s ss se y n r ops)
    (let ((yy (lambda (i r) (apply y i r))))
      (let loop ((ss ss) (ops ops))
	(if (null? ops)
	    (n r)
	    ((car ops) s ss se yy (lambda (_) (loop ss (cdr ops))) r))))))

(define substring:search:or
  (lambda (s ss se y n r . ops)
    (substring:search:or:: s ss se y n r ops)))



(define substring:search:and::
  (lambda (s ss se y n r ops)
    (let ((yy (lambda (ss r)
		(substring:search:and:: s ss se y n r (cdr ops)))))
      (if (null? ops)
	  (apply y ss r)
	  ((car ops) s ss se yy n r)))))


(define substring:search:and
  (lambda (s ss se y n r . ops)
    (substring:search:and:: s ss se y n r ops)))


;;+doc
;; procedure: substring:search
;; arguments: string start end if-match if-not-match matching-procedures ...
;; signature: string x int x int x (int x obj* -> a) x ([obj] -> a) x ?? -> a
;;
;; > (substring:search "#include <stdio.h> " 0 19
;;     (lambda (end start) (cons start end))
;;     (lambda (_) 'failed)
;;     (match "#") (skip* ws) (match "include") (skip* ws) (save-pos) (find ws))
;; (9 . 18)
;;-doc

(define substring:search
  (lambda (s ss se y n . ops)
    (substring:search:and:: s ss se y n '() ops)))



;;+doc
;; procedure: string:search
;; arguments: string if-match if-not-match matching-procedures
;; signature: forall a => string x (int obj* -> a) x ([obj] -> a) x ?? -> a
;;
;; For example, the following will return true (the position of "include")
;; if `line' has the form "^#[\t ]*include"
;;
;; > (string:search "#include <stdio.h> "
;;     (lambda (end start) (cons start end))
;;     (lambda (_) 'failed)
;;     (match "#") (skip* ws) (match "include") (skip* ws) (save-pos) (find ws))
;; (9 . 18)
;;
;; > (string:search "#include <stdio.h> "
;;     (lambda (_end file-name)
;;       (cons start end))
;;     (lambda (_) 'failed)
;;     (match "#") (skip* ws) (match "include") (skip* ws) (save-string (find ws)))
;; "<stdio.h>"
;;-doc

(define string:search
  (lambda (s y n . ops)
    (substring:search:and:: s 0 (string-length s) y n '() ops)))


;; eof
