From mhenoch at common-lisp.net Sat Jun 10 15:50:26 2006 From: mhenoch at common-lisp.net (mhenoch at common-lisp.net) Date: Sat, 10 Jun 2006 11:50:26 -0400 (EDT) Subject: [Cl-darcs-cvs] r6 - cl-darcs/trunk Message-ID: <20060610155026.B6A3C79000@common-lisp.net> Author: mhenoch Date: Sat Jun 10 11:50:26 2006 New Revision: 6 Added: cl-darcs/trunk/commute.lisp Modified: cl-darcs/trunk/cl-darcs.asd Log: Start hacking commutation. Modified: cl-darcs/trunk/cl-darcs.asd ============================================================================== --- cl-darcs/trunk/cl-darcs.asd (original) +++ cl-darcs/trunk/cl-darcs.asd Sat Jun 10 11:50:26 2006 @@ -37,6 +37,7 @@ (:file "apply-patch" :depends-on ("patch-core")) (:file "invert-patch" :depends-on ("patch-core")) (:file "touching" :depends-on ("patch-core")) + (:file "commute" :depends-on ("patch-core")) ;; Franz' inflate implementation #-allegro (:file "ifstar") Added: cl-darcs/trunk/commute.lisp ============================================================================== --- (empty file) +++ cl-darcs/trunk/commute.lisp Sat Jun 10 11:50:26 2006 @@ -0,0 +1,58 @@ +(in-package :darcs) + +(defgeneric commute-patches (p2 p1) + (:documentation "Attempt to commute the patches P2 and P1. +Return a list, (P1-NEW P2-NEW), such that applying P2-NEW and then +P1-NEW has the same effect as applying P1 and then P2. +If commutations fails, return nil.")) + +(defmethod commute-patches :around ((p2 file-patch) (p1 file-patch)) + "If P1 and P2 change different files, commutation is trivial." + (let ((p1-file (patch-filename p1)) + (p2-file (patch-filename p2))) + (if (not (equal p1-file p2-file)) + (list p1 p2) + (call-next-method)))) + +(defmethod commute-patches ((p2 hunk-patch) (p1 hunk-patch)) + "Attempt to commute the two hunk patches P1 and P2." + (assert (equal (patch-filename p1) (patch-filename p2))) + (with-accessors ((line1 hunk-line-number) + (old1 hunk-old-lines) + (new1 hunk-new-lines)) p1 + (with-accessors ((line2 hunk-line-number) + (old2 hunk-old-lines) + (new2 hunk-new-lines)) p2 + (cond + ((< (+ line1 (length new1)) line2) + ;; The first patch changes text before the second patch. + (list p1 + (make-instance 'hunk-patch :filename (patch-filename p2) + :line-number (+ line2 (- (length new1)) (length old1)) + :old old2 :new new2))) + ((< (+ line2 (length old2) line1)) + ;; The second patch changes text before the first patch. + (list (make-instance 'hunk-patch :filename (patch-filename p1) + :line-number (+ line1 (length new2) (- (length old2))) + :old old1 :new new1) + p2)) + ((and (= (+ line1 (length new1)) line2) + (notany #'zerop + (mapcar #'length (list old1 old2 new1 new2)))) + ;; The first patch goes exactly until the beginning of the second patch. + (list p1 + (make-instance 'hunk-patch :filename (patch-filename p2) + :line-number (+ line2 (- (length new1)) (length old1)) + :old old2 :new new2))) + ((and (= (+ line2 (length old2)) line1) + (notany #'zerop + (mapcar #'length (list old1 old2 new1 new2)))) + ;; The second patch goes exactly until the beginning of the first patch. + (list (make-instance 'hunk-patch :filename (patch-filename p1) + :line-number (+ line1 (length new2) (- (length old2))) + :old old1 :new new1) + p2)) + (t + ;; In other cases, there is no failsafe way to commute the + ;; patches, so we give up. + nil))))) From mhenoch at common-lisp.net Sat Jun 10 22:28:47 2006 From: mhenoch at common-lisp.net (mhenoch at common-lisp.net) Date: Sat, 10 Jun 2006 18:28:47 -0400 (EDT) Subject: [Cl-darcs-cvs] r7 - cl-darcs/trunk Message-ID: <20060610222847.9F6A5550D3@common-lisp.net> Author: mhenoch Date: Sat Jun 10 18:28:47 2006 New Revision: 7 Added: cl-darcs/trunk/unwind.lisp Modified: cl-darcs/trunk/apply-patch.lisp cl-darcs/trunk/cl-darcs.asd cl-darcs/trunk/commute.lisp cl-darcs/trunk/invert-patch.lisp cl-darcs/trunk/patch-core.lisp cl-darcs/trunk/read-patch.lisp Log: Start hacking merger unwinding Modified: cl-darcs/trunk/apply-patch.lisp ============================================================================== --- cl-darcs/trunk/apply-patch.lisp (original) +++ cl-darcs/trunk/apply-patch.lisp Sat Jun 10 18:28:47 2006 @@ -319,4 +319,8 @@ (when (null undo) (error "Don't know how to undo ~A." patch)) - (apply-patch undo repodir))) + (apply-patch undo repodir) + + ;; After this comes "glump". As long as version is "0.0", it + ;; doesn't do anything. + (assert (string= (merger-version patch) "0.0")))) Modified: cl-darcs/trunk/cl-darcs.asd ============================================================================== --- cl-darcs/trunk/cl-darcs.asd (original) +++ cl-darcs/trunk/cl-darcs.asd Sat Jun 10 18:28:47 2006 @@ -38,6 +38,8 @@ (:file "invert-patch" :depends-on ("patch-core")) (:file "touching" :depends-on ("patch-core")) (:file "commute" :depends-on ("patch-core")) + (:file "unwind" :depends-on ("patch-core")) + (:file "equal" :depends-on ("patch-core")) ;; Franz' inflate implementation #-allegro (:file "ifstar") Modified: cl-darcs/trunk/commute.lisp ============================================================================== --- cl-darcs/trunk/commute.lisp (original) +++ cl-darcs/trunk/commute.lisp Sat Jun 10 18:28:47 2006 @@ -1,12 +1,12 @@ (in-package :darcs) -(defgeneric commute-patches (p2 p1) +(defgeneric commute (p2 p1) (:documentation "Attempt to commute the patches P2 and P1. Return a list, (P1-NEW P2-NEW), such that applying P2-NEW and then P1-NEW has the same effect as applying P1 and then P2. If commutations fails, return nil.")) -(defmethod commute-patches :around ((p2 file-patch) (p1 file-patch)) +(defmethod commute :around ((p2 file-patch) (p1 file-patch)) "If P1 and P2 change different files, commutation is trivial." (let ((p1-file (patch-filename p1)) (p2-file (patch-filename p2))) @@ -14,7 +14,7 @@ (list p1 p2) (call-next-method)))) -(defmethod commute-patches ((p2 hunk-patch) (p1 hunk-patch)) +(defmethod commute ((p2 hunk-patch) (p1 hunk-patch)) "Attempt to commute the two hunk patches P1 and P2." (assert (equal (patch-filename p1) (patch-filename p2))) (with-accessors ((line1 hunk-line-number) Modified: cl-darcs/trunk/invert-patch.lisp ============================================================================== --- cl-darcs/trunk/invert-patch.lisp (original) +++ cl-darcs/trunk/invert-patch.lisp Sat Jun 10 18:28:47 2006 @@ -84,3 +84,11 @@ (defmethod invert-patch ((patch rm-dir-patch)) (make-instance 'add-dir-patch)) +(defmethod invert-patch ((patch merger-patch)) + (make-instance 'merger-patch + :version (merger-version patch) + :first (merger-first patch) + :second (merger-second patch) + :undo (merger-undo patch) + :unwindings (unwind patch) + :inverted (not (merger-inverted patch)))) Modified: cl-darcs/trunk/patch-core.lisp ============================================================================== --- cl-darcs/trunk/patch-core.lisp (original) +++ cl-darcs/trunk/patch-core.lisp Sat Jun 10 18:28:47 2006 @@ -33,7 +33,7 @@ ((patches :accessor patches :initarg :patches :initform ()))) (defclass file-patch (patch) - ((filename :accessor patch-filename :initarg :filename)) + ((filename :accessor patch-filename :initarg :filename :type pathname)) (:documentation "Base class for patches affecting a single file.")) (defmethod print-object ((patch file-patch) stream) @@ -75,9 +75,9 @@ (:documentation "A patch that changes a binary file.")) (defclass token-replace-patch (file-patch) - ((regexp :accessor token-regexp :initarg :regexp) - (old-token :accessor old-token :initarg :old-token) - (new-token :accessor new-token :initarg :new-token)) + ((regexp :accessor token-regexp :initarg :regexp :type 'string) + (old-token :accessor old-token :initarg :old-token :type 'string) + (new-token :accessor new-token :initarg :new-token :type 'string)) (:documentation "A patch that replaces one token with another.")) (defmethod print-object ((patch token-replace-patch) stream) @@ -161,8 +161,9 @@ (defmethod print-object ((patch merger-patch) stream) (if *print-readably* (call-next-method) - (format stream "#<~A ~A: ~A ~A>" + (format stream "#<~A ~:[(inverted) ~;~]~A: ~A ~A>" (type-of patch) + (merger-inverted patch) (merger-version patch) (merger-first patch) (merger-second patch)))) Modified: cl-darcs/trunk/read-patch.lisp ============================================================================== --- cl-darcs/trunk/read-patch.lisp (original) +++ cl-darcs/trunk/read-patch.lisp Sat Jun 10 18:28:47 2006 @@ -250,25 +250,26 @@ (let ((p1 (read-patch stream)) (p2 (read-patch stream))) (read-token stream) ; #\) - (let* ((is-merger1 (typep p1 'merger-patch)) - (is-merger2 (typep p2 'merger-patch)) - (undo - (cond - ((and is-merger1 is-merger2) - ;; TBD - nil - ) - ((and (not is-merger1) (not is-merger2)) - (invert-patch p1)) - ((and is-merger1 (not is-merger2)) - (make-instance 'composite-patch)) ;empty patch - ((and (not is-merger1) is-merger2) - (make-instance 'composite-patch - :patches (list (invert-patch p1) - (merger-undo p2))))))) - (make-instance 'merger-patch - :version version :first p1 :second p2 - :inverted inverted :undo undo))))) + (let ((merger (make-instance 'merger-patch + :version version :first p1 :second p2 + :inverted inverted))) + (let* ((is-merger1 (typep p1 'merger-patch)) + (is-merger2 (typep p2 'merger-patch))) + (setf (merger-undo merger) + (cond + ((and is-merger1 is-merger2) + (make-instance 'composite-patch + :patches (mapcar #'invert-patch + (cdr (unwind merger))))) + ((and (not is-merger1) (not is-merger2)) + (invert-patch p1)) + ((and is-merger1 (not is-merger2)) + (make-instance 'composite-patch)) ;empty patch + ((and (not is-merger1) is-merger2) + (make-instance 'composite-patch + :patches (list (invert-patch p1) + (merger-undo p2))))))) + merger)))) (defun read-token-replace (stream) "Read a token replacing patch." Added: cl-darcs/trunk/unwind.lisp ============================================================================== --- (empty file) +++ cl-darcs/trunk/unwind.lisp Sat Jun 10 18:28:47 2006 @@ -0,0 +1,112 @@ +(in-package :darcs) + +;; From PatchCommute.lhs + +(defmethod patch-unwindings ((patch merger-patch)) + (if (slot-boundp patch 'unwindings) + (merger-unwindings patch) + (unwind patch))) + +(defmethod patch-unwindings ((patch patch)) + (list patch)) + +(defun unwind (patch) + (let* ((p1 (merger-first patch)) + (p2 (merger-second patch)) + (p1-unwindings (patch-unwindings p1)) + (p2-unwindings (patch-unwindings p2))) + (assert (consp p1-unwindings)) + (assert (consp p2-unwindings)) + (setf (merger-unwindings patch) + (cons patch + (cons p1 + (reconcile-unwindings patch + (cdr p1-unwindings) + (cdr p2-unwindings))))))) + +(defun reconcile-unwindings (p p1s p2s) + (cond + ((null p1s) + p2s) + ((null p2s) + p1s) + (t + + ;; First, try to find permutations of the two lists p1s and p2s + ;; where the two head elements are equal. If we found one such + ;; permutation, put the head element at the head of the + ;; unwinding, and recursively process the tails. + ;; "-p" stands for "permutation" here. + (let ((equal-heads + (dolist (p1s-p (all-head-permutations p1s)) + (dolist (p2s-p (all-head-permutations p2s)) + (when (equal-patch + (car p1s-p) + (car p2s-p)) + (return (list p1s-p p2s-p))))))) + (cond + (equal-heads + (destructuring-bind (p1s-p p2s-p) equal-heads + (cons (car p1s-p) + (reconcile-unwindings p (cdr p1s-p) + (cdr p2s-p))))) + + (t + + ;; If we can't find any such permutation, take the first patch + ;; from either list, invert it, commute it through the other + ;; list, put the non-inverted patch at the head of the unwinding, + ;; and recursively process the tail of the one list and the + ;; commuted-through list. + (let ((p2s-c (nreverse (put-before (car p1s) (reverse p2s))))) + (if p2s-c + (cons (car p1s) (reconcile-unwindings p (cdr p1s) p2s-c)) + (let ((p1s-c (nreverse (put-before (car p2s) (reverse p1s))))) + (when p1s-c + (cons (car p2s) (reconcile-unwindings p p1s-c (cdr p2s))))))))))))) + +(defun put-before (p1 patches) + "Transform PATCHES such that P1 were applied before them. +Return nil if impossible. + +P1 is a patch whose context consists of PATCHES. It is inverted, +and commuted through PATCHES, to finally give a list of patches +whose context consists of P1. If any commutation fails, this +operation fails as well." + (destructuring-bind (&optional p2-c p1-c) (commute (invert-patch p1) (car patches)) + (and p2-c p1-c + (commute p1 p2-c) + (let ((rest (put-before p1-c (cdr patches)))) + (and rest (cons p2-c rest)))))) + +(defun all-head-permutations (ps) + "Return all possible permutations of PS. +PS is a list of patches in reverse order." + (reverse + (mapcar #'reverse + (remove-duplicates + (tail-permutations-normal-order ps) + :test (lambda (a b) + (equal-list #'equal-patch a b)))))) + +(defun tail-permutations-normal-order (ps) + (if (null ps) + ps + (let ((swapped-ps (swap-to-back-normal-order ps)) + (rest (mapcar + (lambda (p) (cons (car ps) p)) + (tail-permutations-normal-order (cdr ps))))) + (if swapped-ps ;separate () and :fail? + (cons swapped-ps rest) + rest)))) + +(defun swap-to-back-normal-order (ps) + ;; If there are zero or one element, just return. + (if (or (null (cdr ps)) (null (cddr ps))) + ps + (let ((commuted (commute (second ps) (first ps)))) + (when commuted ;XXX: separate failure? + (let ((rest (swap-to-back-normal-order + (cons (first commuted) (cddr ps))))) + (when rest + (cons (second commuted) rest))))))) From mhenoch at common-lisp.net Sun Jun 11 15:32:21 2006 From: mhenoch at common-lisp.net (mhenoch at common-lisp.net) Date: Sun, 11 Jun 2006 11:32:21 -0400 (EDT) Subject: [Cl-darcs-cvs] r8 - cl-darcs/trunk Message-ID: <20060611153221.0DFAA5C127@common-lisp.net> Author: mhenoch Date: Sun Jun 11 11:32:20 2006 New Revision: 8 Added: cl-darcs/trunk/equal.lisp Log: Forgot to add equal.lisp. Added: cl-darcs/trunk/equal.lisp ============================================================================== --- (empty file) +++ cl-darcs/trunk/equal.lisp Sun Jun 11 11:32:20 2006 @@ -0,0 +1,68 @@ +(in-package :darcs) + +(defun equal-list (predicate a b) + "Return true if lists A and B are equal according to PREDICATE. +That is, they have the same length, and for each corresponding +pair of elements PREDICATE returns true." + (and (= (length a) (length b)) + (catch 'not-equal + (mapc (lambda (x y) + (unless (funcall predicate x y) + (throw 'not-equal nil))) + a b) + t))) + +(defgeneric equal-patch (a b &optional really) + (:documentation "Return true if patches A and B are equal. +If REALLY is false, consider named patches with the same name +to be equal, regardless of content.") + (:method-combination and :most-specific-last)) + +(defmethod equal-patch :around ((a patch) (b patch) &optional really) + "If there are no methods for comparing A and B, they are not equal." + (declare (ignore really)) + (if (next-method-p) + (call-next-method) + nil)) + +(defmethod equal-patch and ((a file-patch) (b file-patch) &optional really) + "Compare two file patches. +Two file patches can be equal only if they are of the same type and +patch the same file." + (declare (ignore really)) + (and (eq (class-of a) (class-of b)) + (equal (patch-filename a) (patch-filename b)))) + +(defmethod equal-patch and ((a hunk-patch) (b hunk-patch) &optional really) + "Compare two hunk patches." + (declare (ignore really)) + (flet ((compare (accessor) + ;; We use equalp, to make it descend into the vaguely + ;; string-like arrays. + (equalp (funcall accessor a) (funcall accessor b)))) + (and (compare #'hunk-line-number) + (compare #'hunk-old-lines) + (compare #'hunk-new-lines)))) + +(defmethod equal-patch and ((a binary-patch) (b binary-patch) &optional really) + "Compare two binary patches." + (declare (ignore really)) + (and (equalp (binary-oldhex a) (binary-oldhex b)) + (equalp (binary-newhex a) (binary-newhex b)))) + +(defmethod equal-patch and ((a token-replace-patch) (b token-replace-patch) &optional really) + "Compare two token replacing patches." + (declare (ignore really)) + (flet ((compare (accessor) + ;; Here we use string=. + (string= (funcall accessor a) (funcall accessor b)))) + (and (compare #'token-regexp) + (compare #'old-token) + (compare #'new-token)))) + +(defmethod equal-patch and ((a merger-patch) (b merger-patch) &optional really) + "Compare two merger patches." + (and (string= (merger-version a) (merger-version b)) + (eql (merger-inverted a) (merger-inverted b)) + (equal-patch (merger-first a) (merger-first b) really) + (equal-patch (merger-second a) (merger-second b) really))) From mhenoch at common-lisp.net Sun Jun 11 18:56:03 2006 From: mhenoch at common-lisp.net (mhenoch at common-lisp.net) Date: Sun, 11 Jun 2006 14:56:03 -0400 (EDT) Subject: [Cl-darcs-cvs] r9 - cl-darcs/trunk Message-ID: <20060611185603.56D354610C@common-lisp.net> Author: mhenoch Date: Sun Jun 11 14:56:03 2006 New Revision: 9 Modified: cl-darcs/trunk/patchinfo.lisp Log: Fix invert-patchinfo - make it return the copy as well. Modified: cl-darcs/trunk/patchinfo.lisp ============================================================================== --- cl-darcs/trunk/patchinfo.lisp (original) +++ cl-darcs/trunk/patchinfo.lisp Sun Jun 11 14:56:03 2006 @@ -114,4 +114,5 @@ "Make a copy of PATCHINFO with the inverted flag toggled." (let ((copy (copy-patchinfo patchinfo))) (setf (patchinfo-inverted copy) - (not (patchinfo-inverted copy))))) + (not (patchinfo-inverted copy))) + copy)) From mhenoch at common-lisp.net Wed Jun 21 14:57:40 2006 From: mhenoch at common-lisp.net (mhenoch at common-lisp.net) Date: Wed, 21 Jun 2006 10:57:40 -0400 (EDT) Subject: [Cl-darcs-cvs] r10 - cl-darcs/trunk Message-ID: <20060621145740.6F70A7072@common-lisp.net> Author: mhenoch Date: Wed Jun 21 10:57:40 2006 New Revision: 10 Modified: cl-darcs/trunk/apply-patch.lisp Log: Correctly treat hunks in reverse order Modified: cl-darcs/trunk/apply-patch.lisp ============================================================================== --- cl-darcs/trunk/apply-patch.lisp (original) +++ cl-darcs/trunk/apply-patch.lisp Wed Jun 21 10:57:40 2006 @@ -212,25 +212,30 @@ "Apply a list of patches, attempting to optimize for adjacent hunks." (dformat "~&Looking for adjacent hunks...") (loop while patches - do - (etypecase (car patches) - (hunk-patch - (let ((filename (patch-filename (car patches)))) - (loop while (and (typep (car patches) 'hunk-patch) - (equal (patch-filename (car patches)) filename)) - collect (car patches) into hunks - do (setf patches (cdr patches)) - finally (loop - (restart-case - (progn - (apply-hunk-list hunks repodir) - (return)) - (retry-hunks () - :report (lambda (stream) - (format stream "Retry patch ~A to ~A" hunks filename)))))))) - (patch - (apply-patch (car patches) repodir) - (setf patches (cdr patches)))))) + do + (etypecase (car patches) + (hunk-patch + (let ((filename (patch-filename (car patches))) + (line-number 0)) + (loop while (and (typep (car patches) 'hunk-patch) + (equal (patch-filename (car patches)) filename) + (>= (hunk-line-number (car patches)) line-number)) + collect (car patches) into hunks + do (setf line-number (+ + (hunk-line-number (car patches)) + (length (hunk-new-lines (car patches))))) + (setf patches (cdr patches)) + finally (loop + (restart-case + (progn + (apply-hunk-list hunks repodir) + (return)) + (retry-hunks () + :report (lambda (stream) + (format stream "Retry patch ~A to ~A" hunks filename)))))))) + (patch + (apply-patch (car patches) repodir) + (setf patches (cdr patches)))))) (defun apply-hunk-list (hunks repodir) "Apply HUNKS to REPODIR. From mhenoch at common-lisp.net Sat Jun 24 11:24:24 2006 From: mhenoch at common-lisp.net (mhenoch at common-lisp.net) Date: Sat, 24 Jun 2006 07:24:24 -0400 (EDT) Subject: [Cl-darcs-cvs] r11 - cl-darcs/trunk Message-ID: <20060624112424.4BD6C2102F@common-lisp.net> Author: mhenoch Date: Sat Jun 24 07:24:23 2006 New Revision: 11 Modified: cl-darcs/trunk/unreadable-stream.lisp Log: Comment read-binary-line method of unreadable-stream. Modified: cl-darcs/trunk/unreadable-stream.lisp ============================================================================== --- cl-darcs/trunk/unreadable-stream.lisp (original) +++ cl-darcs/trunk/unreadable-stream.lisp Sat Jun 24 07:24:23 2006 @@ -101,7 +101,11 @@ ;; Otherwise, report that the sequence is full. end))) -#+nil (defmethod read-binary-line ((stream unreadable-stream) &optional (eof-error-p t) eof-value) +;; This method is meant as an optimization, but it actually makes +;; things slower. Need to investigate why... +#+nil +(defmethod read-binary-line :around ((stream unreadable-stream) &optional (eof-error-p t) eof-value) + "If possible, return a recently unread line." ;; If a line has been unread, we just return it. (with-slots (buffer) stream (let ((buffer-entry (car buffer))) From mhenoch at common-lisp.net Sat Jun 24 13:54:12 2006 From: mhenoch at common-lisp.net (mhenoch at common-lisp.net) Date: Sat, 24 Jun 2006 09:54:12 -0400 (EDT) Subject: [Cl-darcs-cvs] r12 - cl-darcs/trunk Message-ID: <20060624135412.E14881B001@common-lisp.net> Author: mhenoch Date: Sat Jun 24 09:54:12 2006 New Revision: 12 Modified: cl-darcs/trunk/util.lisp Log: Add comma to read-until docstring. Modified: cl-darcs/trunk/util.lisp ============================================================================== --- cl-darcs/trunk/util.lisp (original) +++ cl-darcs/trunk/util.lisp Sat Jun 24 09:54:12 2006 @@ -72,7 +72,7 @@ (defun read-until (delimiters stream &optional (eof-error-p t) eof-value) "Read from STREAM until encountering DELIMITERS. -DELIMITERS is an atom or a list of atoms, or a predicate function. +DELIMITERS is an atom, or a list of atoms, or a predicate function. Returns two values: - vector of elements read From mhenoch at common-lisp.net Sat Jun 24 15:59:29 2006 From: mhenoch at common-lisp.net (mhenoch at common-lisp.net) Date: Sat, 24 Jun 2006 11:59:29 -0400 (EDT) Subject: [Cl-darcs-cvs] r13 - cl-darcs/trunk Message-ID: <20060624155929.22D7439006@common-lisp.net> Author: mhenoch Date: Sat Jun 24 11:59:17 2006 New Revision: 13 Modified: cl-darcs/trunk/apply-patch.lisp cl-darcs/trunk/unreadable-stream.lisp Log: Read lines the same way darcs does. Modified: cl-darcs/trunk/apply-patch.lisp ============================================================================== --- cl-darcs/trunk/apply-patch.lisp (original) +++ cl-darcs/trunk/apply-patch.lisp Sat Jun 24 11:59:17 2006 @@ -33,7 +33,8 @@ (open ,filename-gensym :direction :input :if-does-not-exist :error - :element-type '(unsigned-byte 8)))) + :element-type '(unsigned-byte 8)) + :haskellish-lines t)) ;; Open a temporary file for writing. (with-temp-file (,outstreamvar :element-type '(unsigned-byte 8)) (progn , at body) Modified: cl-darcs/trunk/unreadable-stream.lisp ============================================================================== --- cl-darcs/trunk/unreadable-stream.lisp (original) +++ cl-darcs/trunk/unreadable-stream.lisp Sat Jun 24 11:59:17 2006 @@ -19,8 +19,20 @@ (defclass unreadable-stream (trivial-gray-streams:trivial-gray-stream-mixin trivial-gray-streams:fundamental-binary-input-stream) - ((stream :initarg :base-stream) - (buffer :initform nil)) + ((stream + :initarg :base-stream + :documentation "The stream wrapped by this unreadable-stream.") + (haskellish-lines + :initarg :haskellish-lines :initform nil + :documentation "If true, read lines as Haskell would read them. +That is, a line is a (possibly empty) list of characters delimited +by either newlines or end-of-file. In particular, if the file ends +with a newline, it has an extra empty last line in Haskell mode. + +This flag affects only `read-binary-line'.") + + (buffer :initform nil) + (at-end-of-file :initform nil)) (:documentation "A wrapper for a binary input stream. Unlimited \"unreading\" is allowed through UNREAD-BYTE and UNREAD-SEQUENCE.")) @@ -101,6 +113,30 @@ ;; Otherwise, report that the sequence is full. end))) +(defmethod read-binary-line ((stream unreadable-stream) &optional (eof-error-p t) eof-value) + "If stream is in \"Haskell mode\", treat newlines at end of file accordingly." + (if (not (slot-value stream 'haskellish-lines)) + (call-next-method) + ;; The delimiter between lines is a newline or end-of-file. + ;; Thus, if we have just returned the last newline-terminated + ;; line and stand before EOF, we can't just return EOF since + ;; there is an zero-length line between the last newline and the + ;; EOF. + (if (null (slot-value stream 'at-end-of-file)) + ;; So we haven't read EOF yet. That means that we can + ;; return at least one more line (though it may be + ;; zero-length). + (multiple-value-bind (line delim) + (read-until 10 stream nil :eof) + ;; If EOF follows after that line, note it. + (when (eql delim :eof) + (setf (slot-value stream 'at-end-of-file) t)) + line) + ;; If we have already set the EOF flag, act accordingly. + (if eof-error-p + (error 'end-of-file :stream stream) + eof-value)))) + ;; This method is meant as an optimization, but it actually makes ;; things slower. Need to investigate why... #+nil From mhenoch at common-lisp.net Sat Jun 24 18:47:29 2006 From: mhenoch at common-lisp.net (mhenoch at common-lisp.net) Date: Sat, 24 Jun 2006 14:47:29 -0400 (EDT) Subject: [Cl-darcs-cvs] r14 - cl-darcs/trunk Message-ID: <20060624184729.6DA4963037@common-lisp.net> Author: mhenoch Date: Sat Jun 24 14:47:24 2006 New Revision: 14 Modified: cl-darcs/trunk/prefs.lisp Log: Add {get,set}-preflist, write-default-prefs. Modified: cl-darcs/trunk/prefs.lisp ============================================================================== --- cl-darcs/trunk/prefs.lisp (original) +++ cl-darcs/trunk/prefs.lisp Sat Jun 24 14:47:24 2006 @@ -19,19 +19,13 @@ (defun read-prefs (upath) "Read all preferences from repository at UPATH. Return an alist with strings." - (let ((stream (ignore-errors - (open-upath - (upath-subdir upath '("_darcs" "prefs") "prefs")))) - alist) - (when stream - (with-open-stream (in stream) - (loop for line = (read-line in nil) - while line - do (let ((pos (position #\Space line))) - (when pos - (let ((name (subseq line 0 pos)) - (value (subseq line (1+ pos)))) - (push (cons name value) alist))))))) + (let (alist) + (loop for line in (get-preflist upath "prefs") + do (let ((pos (position #\Space line))) + (when pos + (let ((name (subseq line 0 pos)) + (value (subseq line (1+ pos)))) + (push (cons name value) alist))))) alist)) (defun get-pref (upath prefname) @@ -46,9 +40,68 @@ (if entry (setf (cdr entry) value) (push (cons prefname value) prefs)) - (with-open-file (out (upath-subdir repopath '("_darcs" "prefs") "prefs") - :direction :output - :if-exists :supersede - :if-does-not-exist :create) - (dolist (pref prefs) - (format out "~A ~A~%" (car pref) (cdr pref)))))) + (set-preflist repopath "prefs" + (mapcar (lambda (p) (format nil "~A ~A" (car p) (cdr p))) prefs)))) + +(defun get-preflist (upath filename) + "Get list of lines in preference file named by FILENAME in repository UPATH." + (let ((stream (ignore-errors + (open-upath + (upath-subdir upath '("_darcs" "prefs") filename))))) + (when stream + (with-open-stream (in stream) + (flet ((unimportantp (line) + (or (zerop (length line)) + (char= (elt line 0) #\#) + (eql (search "v v v v v v v" line) 0) + (eql (search "*************" line) 0) + (eql (search "^ ^ ^ ^ ^ ^ ^" line) 0)))) + (loop for line = (read-line in nil) + while line + unless (unimportantp line) collect line)))))) + +(defun set-preflist (upath filename preflist) + "Set preferences in FILENAME in repo UPATH to PREFLIST." + (with-open-file (out (upath-subdir upath '("_darcs" "prefs") filename) + :direction :output + :if-exists :supersede + :if-does-not-exist :create) + (dolist (pref preflist) + (format out "~A~%" pref)))) + +(defun write-default-prefs (repopath) + (default-boring repopath) + (default-binaries repopath) + (set-preflist repopath "motd" ())) + +(defun default-boring (repopath) + (set-preflist repopath "boring" + '("# Boring file regexps:" + "\\.hi$" + "\\.o$" "\\.o\\.cmd$" + "# *.ko files aren't boring by default because they might" + "# be Korean translations rather than kernel modules." + "# \\.ko$" + "\\.ko\\.cmd$" "\\.mod\\.c$" + "(^|/)\\.tmp_versions($|/)" "(^|/)CVS($|/)" "(^|/)RCS($|/)" "~$" + "#(^|/)\\.[^/]" "(^|/)_darcs($|/)" + "\\.bak$" "\\.BAK$" "\\.orig$" "(^|/)vssver\\.scc$" + "\\.swp$" "(^|/)MT($|/)" + "(^|/)\\{arch\\}($|/)" "(^|/).arch-ids($|/)" + "(^|/)," "\\.class$" "\\.prof$" "(^|/)\\.DS_Store$" + "(^|/)BitKeeper($|/)" "(^|/)ChangeSet($|/)" + "(^|/)\\.svn($|/)" "\\.py[co]$" "\\#" "\\.cvsignore$" + "(^|/)Thumbs\\.db$" + "(^|/)autom4te\\.cache($|/)"))) + +(defun default-binaries (repopath) + (set-preflist + repopath "binaries" + (cons "# Binary file regexps:" + (mapcan (lambda (ext) + (list (format nil "\\.~A$" ext) + (format nil "\\.~A$" (string-upcase ext)))) + '("png" "gz" "pdf" "jpg" "jpeg" "gif" "tif" + "tiff" "pnm" "pbm" "pgm" "ppm" "bmp" "mng" + "tar" "bz2" "z" "zip" "jar" "so" "a" + "tgz" "mpg" "mpeg" "iso" "exe" "doc"))))) From mhenoch at common-lisp.net Sat Jun 24 19:26:26 2006 From: mhenoch at common-lisp.net (mhenoch at common-lisp.net) Date: Sat, 24 Jun 2006 15:26:26 -0400 (EDT) Subject: [Cl-darcs-cvs] r15 - cl-darcs/trunk Message-ID: <20060624192626.F387669002@common-lisp.net> Author: mhenoch Date: Sat Jun 24 15:26:19 2006 New Revision: 15 Modified: cl-darcs/trunk/prefs.lisp Log: Add add-to-preflist and set-default-repo. Modified: cl-darcs/trunk/prefs.lisp ============================================================================== --- cl-darcs/trunk/prefs.lisp (original) +++ cl-darcs/trunk/prefs.lisp Sat Jun 24 15:26:19 2006 @@ -67,7 +67,18 @@ :if-exists :supersede :if-does-not-exist :create) (dolist (pref preflist) - (format out "~A~%" pref)))) + (write-line pref out)))) + +(defun add-to-preflist (upath filename pref) + "Add PREF to preferences in FILENAME in repo UPATH. +Do nothing if it's already there." + (let ((prefs (get-preflist upath filename))) + (unless (member pref prefs :test #'string=) + (with-open-file (out (upath-subdir upath '("_darcs" "prefs") filename) + :direction :output + :if-exists :append + :if-does-not-exist :create) + (write-line pref out))))) (defun write-default-prefs (repopath) (default-boring repopath) @@ -105,3 +116,7 @@ "tiff" "pnm" "pbm" "pgm" "ppm" "bmp" "mng" "tar" "bz2" "z" "zip" "jar" "so" "a" "tgz" "mpg" "mpeg" "iso" "exe" "doc"))))) + +(defun set-default-repo (repopath repostring) + (set-preflist repopath "defaultrepo" (list repostring)) + (add-to-preflist repopath "repos" repostring))