Coverage report: /home/ellis/comp/core/app/skel/comp/asd.lisp

Kind	Covered	All	%
expression	0	220	0.0
branch	0	0	nil

Key

Not instrumented

Conditionalized out

Executed

Not executed

Both branches taken

One branch taken

Neither branch taken

1

;;; lib/skel/comp/asd.lisp --- ASDF Components

2

3

;; ASDF/PARSE-DEFSYSTEM may come in handy for testing.

4

5

;; The problem with ASD files is that they're read-only afaik - eg there's no

6

;; 'write' methods implemented on ASD:SYSTEM objects. This makes it a bit

7

;; tedious because we obviously want to transform SK-LISP-SYSTEM objects

8

;; directly to SYSTEM, but also need to be able to write them out as discrete

9

;; files for portability. Probably will end up violating all that is DRY and

10

;; holy.

11

12

;;; Code:

13

(in-package :skel/comp/asd)

14

15

(defclass sk-lisp-system (sk-mod asdf:system)

16

;; these slots are inferred in ASDF:SYSTEM. Since we are primarily concerned

17

;; with generating ASDF:SYSTEM definitions rather than parsing them we restore them here.

18

((serial :initform nil :type boolean :accessor sk-lisp-system-serial)

19

(perform :initform nil :type list :accessor sk-lisp-system-perform)))

20

21

(defmethod name ((self sk-lisp-system)) (asdf::coerce-name self))

22

23

(defun read-system-definitions (system)

24

(with-open-file (file (asdf:system-source-file system))

25

(loop for x = (read file nil)

26

while x

27

collect x)))

28

29

(defun to-sk-system (system)

30

(let ((sys (change-class system 'sk-lisp-system)))

31

(setf (sk-lisp-system-serial sys) nil

32

(sk-lisp-system-perform sys) nil)

33

(id:update-id sys)

34

sys))

35

36

(defmethod sk-convert ((self asdf:system))

37

(to-sk-system self))

38

39

(defun find-sk-system (system)

40

(to-sk-system (asdf:find-system system)))

41

42

(defun parse-sk-lisp-system (name path &optional opts)

43

(to-sk-system (asdf::parse-component-form nil (list* :system name :pathname path opts))))

44

45

(defmethod sk-load ((self sk-lisp-system) &key force force-not verbose version)

46

(asdf:load-system self :force force :force-not force-not :verbose verbose :version version))

47

48

(defmethods sk-load-component

49

(((kind (eql :asd)) (form string) &optional (path (project-root)))

50

(sk-load-component kind (pathname form) path))

51

(((kind (eql :asd)) (form pathname) &optional (path (project-root)))

52

(declare (ignore kind))

53

(let* ((type (pathname-type form))

54

(name (namestring (if type (pathname-name form) form)))

55

(fname (if type form (make-pathname :name name :type "asd"))))

56

(parse-sk-lisp-system name (merge-pathnames fname path)))))

57

58

(defmethod sk-compile ((self sk-lisp-system) &key force force-not verbose version &allow-other-keys)

59

(asdf:compile-system self :force force :force-not force-not :verbose verbose :version version))

60

61

(defun sk-write-asd-components (module)

62

(etypecase module

63

(asdf:file-component

64

`(,(keywordicate (string-upcase (asdf:file-type module)))

65

,(pathname-name (asdf:component-relative-pathname module))

66

,@(when-let ((x (asdf::component-if-feature module)))

67

`(:if-feature ,x))

68

,@(when-let ((x (asdf::component-depends-on nil module)))

69

`(:depends-on ,x))))

70

(asdf:module

71

`(:module

72

,(asdf:component-name module)

73

,@(when-let ((x (asdf::component-if-feature module)))

74

`(:if-feature ,x))

75

,@(when-let ((x (asdf::component-depends-on nil module)))

76

`(:depends-on ,x))

77

,@(when-let ((x (asdf:module-components module)))

78

`(:components ,(mapcar #'sk-write-asd-components x)))))))

79

80

(defmethod sk-write-file ((self sk-lisp-system) &key path)

81

(let ((name (asdf:component-name self)))

82

(with-open-file (s path

83

:direction :output

84

:if-does-not-exist :create)

85

(format s ";;; ASDF definition for system ~A" name)

86

(let ((*print-case* :downcase))

87

(pprint `(defsystem ,name

88

:class sk-lisp-system

89

,@(when-let ((x (asdf:component-version self))) `(:version ,x))

90

,@(when-let ((x (asdf:system-depends-on self))) `(:depends-on ,x))

91

,@(when-let ((x (asdf:system-description self))) `(:description ,x))

92

                    ,@(when-let ((x (asdf:system-long-description self))) `(:long-description ,x))

93

,@(when-let ((x (asdf:system-author self))) `(:author ,x))

94

,@(when-let ((x (asdf:system-maintainer self))) `(:maintainer ,x))

95

,@(when-let ((x (asdf:system-mailto self))) `(:mailto ,x))

96

,@(when-let ((x (asdf::system-license self))) `(:license ,x))

97

,@(when-let ((x (asdf:system-homepage self))) `(:homepage ,x))

98

,@(when-let ((x (asdf:system-bug-tracker self))) `(:bug-tracker ,x))

99

,@(when-let ((x (asdf:system-source-control self))) `(:source-control ,x))

100

,@(when-let ((x (asdf::component-in-order-to self))) `(:in-order-to ,x))

101

                    ,@(when-let ((x (asdf::component-build-pathname self))) `(:build-pathname ,x))

102

                    ,@(when-let ((x (asdf::component-build-operation self))) `(:build-operation ,x))

103

,@(when-let ((x (asdf::component-entry-point self))) `(:entry-point ,x))

104

,@(when-let ((x (sk-lisp-system-perform self))) `(:perform ,x))

105

,@(when-let ((x (sk-lisp-system-serial self))) `(:serial ,x))

106

:components ,(mapcar #'sk-write-asd-components

107

(asdf:module-components self)))

108

s)

109

(terpri s)))))

110

111

;; (sk-write-file (find-sk-system :obj) :path "test")

112

;; (describe (parse-sk-lisp-system "skel" "/home/ellis/comp/core/lib/"))

113

114

(defmethod sk-read-file ((self sk-lisp-system) path)

115

(parse-sk-lisp-system (pathname-name path) (pathname-directory path)))