Source File package/package.ils

    1 ;;; package.ils --- Lightweight package system
    2 
    3 ;; Copyright (C) 2012  Damien Diederen
    4 
    5 ;; @author Damien Diederen <dd@crosstwine.com>
    6 
    7 ;; All Rights Reserved.
    8 ;;
    9 ;; NOTICE: All information, intellectual and technical concepts
   10 ;; contained herein are, and remain the property of Damien Diederen
   11 ;; and his suppliers, if any.  Dissemination of this information or
   12 ;; reproduction of this material is strictly forbidden unless prior
   13 ;; written permission is obtained from Damien Diederen.
   14 
   15 ;;; Commentary:
   16 
   17 ;; Package package implements a lightweight package system for SKILL.
   18 ;; It generally favors convention over configuration.
   19 ;;
   20 ;; A package is a directory which contains a SKILL or SKILL++ file
   21 ;; with the same base name (<directory>.{il,ils}), which in turn
   22 ;; begins with a comment header formatted in a specific way.  A
   23 ;; minimal package foo would consist in a single file:
   24 ;;
   25 ;;     foo/foo.il
   26 ;;
   27 ;; with a single-line header:
   28 ;;
   29 ;;     ;;; foo.il --- Minimal package
   30 ;;
   31 ;; More complex packages may contain @-prefixed metadata tags in the
   32 ;; header comment, each beginning with:
   33 ;;
   34 ;;     ;; @<tag-name>
   35 ;;
   36 ;; The following tags are defined:
   37 ;;
   38 ;;     ;; @author   A.U.Thor <author@example.com>
   39 ;;     ;; @requires bar, baz
   40 ;;     ;; @load     a.il, b.ils, ...
   41 ;;
   42 ;; @author states the name and email address of an author of the
   43 ;; package.  If there are multiple authors, repeat the tag for each of
   44 ;; them.
   45 ;;
   46 ;; @requires and @load are discussed with the
   47 ;; VedaPackageFilesystemInfo class.
   48 ;;
   49 ;; Packages are normally searched for in two locations relative to the
   50 ;; execution directory: pkg/ and ../, in that order.
   51 
   52 ;;; Code:
   53 
   54 ;; Class VedaPackageAbstractInfo holds information that is common to
   55 ;; all packages, independently of their underlying representation.
   56 (defclass VedaPackageAbstractInfo ()
   57   (;; The name of the package, as understood by the Info/Load
   58    ;; functions.
   59    (name
   60     @initarg name
   61     @reader GetName)
   62    ;; The package's synopsis.
   63    (description
   64     @initarg description
   65     @reader GetDescription)
   66    ;; A (possibly empty) list of package authors strings, each having
   67    ;; the following form (cf. name-addr production in RFC 5322):
   68    ;;
   69    ;;     Human-readable Name <email@example.com>
   70    (authors
   71     @initarg authors
   72     @reader GetAuthors)))
   73 
   74 ;; Class VedaPackageFilesystemInfo describes filesystem-based packages
   75 ;; as "natively" implemented by this package.
   76 (defclass VedaPackageFilesystemInfo (VedaPackageAbstractInfo)
   77   (;; The directory of the search path in which the package was found,
   78    ;; a /-terminated string.
   79    (base
   80     @initarg base
   81     @reader GetBaseDir)
   82    ;; The titular file containing package information.
   83    (header
   84     @initarg header
   85     @reader GetHeaderFilename)
   86    ;; A list of other packages required by this package.  The contents
   87    ;; of this field can be controlled via the @requires tag, e.g.:
   88    ;;
   89    ;;     ;; @requires bar, baz
   90    (requires
   91     @initarg requires
   92     @reader GetPackageRequires)
   93    ;; The package's source files, in load order.
   94    ;;
   95    ;; The contents of this field can be controlled via the @load tag,
   96    ;; e.g.:
   97    ;;
   98    ;;     ;; @load foo.il, bar.ils
   99    ;;
  100    ;; or
  101    ;;
  102    ;;     ;; @load foo.il, bar.ils, ...
  103    ;;
  104    ;; where the ellipsis means that any other source file founds in
  105    ;; the package's directory are to be loaded after foo.il and
  106    ;; bar.ils (in an undefined order).
  107    (sources
  108     @initarg sources
  109     @reader GetSourceFilenames)
  110    ;; Package test files, in load order.
  111    (tests
  112     @initarg tests
  113     @reader GetTestFilenames)))
  114 
  115 ;; printObject formats unreadable VedaPackageFilesystemInfo instances
  116 ;; for diagnostic purposes.
  117 (defmethod printObject ((pi VedaPackageFilesystemInfo) @optional (port poport))
  118   (fprintf port "#<%s %L; base: %L>"
  119            (className (classOf pi)) pi->name pi->base))
  120 
  121 ;; Class VedaPackageSearchOptions holds options that are used for
  122 ;; locating packages; cf. PackageLoad and PackageInfo.
  123 (defclass VedaPackageSearchOptions ()
  124   (;; The list of /-terminated directories which are searched (in
  125    ;; order) for packages.  Non-anchored directories are relative to
  126    ;; the execution directory.
  127    ;;
  128    ;; Defaults to searching pkg/ then ../.
  129    (searchPath
  130     @initarg searchPath
  131     @initform '("pkg/" "../")
  132     @reader GetSearchPath
  133     @writer SetSearchPath)))
  134 
  135 ;; Class VedaPackageLoadOptions holds options that are used when
  136 ;; loading packages; cf. PackageLoad.
  137 (defclass VedaPackageLoadOptions (VedaPackageSearchOptions)
  138   (;; When t, honor the package's @requires tag.  Otherwise, a
  139    ;; (possibly) empty list of packages which are to be required
  140    ;; before the target.
  141    ;;
  142    ;; Defaults to t.
  143    (requires
  144     @initarg requires
  145     @initform t
  146     @reader GetRequires
  147     @writer SetRequires)
  148    ;; When t, reset the table of loaded packages before loading the
  149    ;; target.  Otherwise, a (possibly) empty list of package names to
  150    ;; be evicted from the table of loaded packages before loading the
  151    ;; target.
  152    ;;
  153    ;; Defaults to nil.
  154    (forceReload
  155     @initarg forceReload
  156     @initform nil
  157     @reader GetForceReload
  158     @writer SetForceReload)))
  159 
  160 ;; Scope/hide utility functions and related data.
  161 (let ()
  162   ;; Export exports function fn as a global symbol with the
  163   ;; VedaPackage prefix.
  164   (defun Export (suffix fn)
  165     (putd (concat 'VedaPackage suffix) fn))
  166 
  167   ;; Default options used by Load/Info, if not overriden by ?options.
  168   (define defaultOptions
  169       (makeInstance 'VedaPackageLoadOptions))
  170 
  171   ;; FilesLoader returns a function which loads the provided list of
  172   ;; filenames in order.  If ?dir is non-nil, it is prepended to each
  173   ;; file before attempting the load operation.
  174   (defun FilesLoader (filenames @key dir)
  175     (lambda (@rest _ignored)
  176       (foreach filename filenames
  177         (when dir
  178           (setq filename (strcat dir filename)))
  179         (load filename))
  180       t))
  181 
  182   ;; Trim returns a substring of string, with all characters in
  183   ;; characterBag stripped off the beginning, or off the end if
  184   ;; ?fromEndP is true.
  185   ;;
  186   ;; If no characters need to be trimmed, string is returned.
  187   (defun Trim (characterBag string @key fromEndP)
  188     (let ((a 1)
  189           (n (strlen string)))
  190       (let ((b n)
  191             (i (if fromEndP n a)))
  192         (while (and (a <= b)
  193                     (nindex characterBag (getchar string i)))
  194           (setq i (if fromEndP
  195                       (setq b (b - 1))
  196                       (setq a (a + 1)))))
  197         (cond
  198           ((and (onep a) (equal b n))
  199            string)
  200           (t
  201            (substring string a (b - a + 1)))))))
  202 
  203   ;; Prefix characters which are ignored at the beginning of line
  204   ;; comment headers.
  205   (define lineCommentTrimBag
  206       "; \t")
  207 
  208   ;; Prefix characters which are ignored at the beginning of block
  209   ;; comment headers.
  210   (define blockCommentTrimBag
  211       "* \t")
  212 
  213   ;; ParseDescriptionLine parses a package's description line, which
  214   ;; is the first line in the package's titular file and has one of
  215   ;; the following formats:
  216   ;;
  217   ;;     ;;; <filename> --- <description>
  218   ;;
  219   ;;     /* <filename> --- <description>
  220   ;;
  221   ;; If the line does not match one of the required syntaxes, this
  222   ;; function returns nil.  Otherwise, it returns a list of two
  223   ;; elements: a string of characters to be trimmed on subsequent
  224   ;; lines, and the description.
  225   (defun ParseDescriptionLine (line filename)
  226     ;; FIXME: Should preserve tabs and multiple spaces.
  227     (letseq ((pieces (parseString line " \t\n"))
  228              (bag (cond
  229                     ((equal (car pieces) ";;;") lineCommentTrimBag)
  230                     ((equal (car pieces) "/*")  blockCommentTrimBag))))
  231       (when (and bag
  232                  (equal (cadr pieces) filename)
  233                  (equal (caddr pieces) "---"))
  234         (list bag (buildString (nthcdr 3 pieces))))))
  235 
  236   ;; PrefixP returns the length of needle if it is a prefix of
  237   ;; haystack, nil otherwise.
  238   (defun PrefixP (needle haystack)
  239     (let ((n (strlen needle)))
  240       (when (n <= (strlen haystack))
  241         (let ((i 1))
  242           (while (and i (i <= n))
  243             (setq i (when (eq (getchar needle i) (getchar haystack i))
  244                       (i + 1))))
  245           i))))
  246 
  247   ;; SuffixP returns the index of the last character before needle in
  248   ;; haystack when the former is a suffix of the latter.  Otherwise,
  249   ;; returns nil.
  250   (defun SuffixP (needle haystack)
  251     (let ((n (strlen needle))
  252           (m (strlen haystack)))
  253       (when (n <= m)
  254         (let ((i 1)
  255               (offset (m - n)))
  256           (while (and i (i <= n))
  257             (setq i (when (eq (getchar needle i)
  258                               (getchar haystack (offset + i)))
  259                       (i + 1))))
  260           (when i
  261             offset)))))
  262 
  263   ;; Tries and trim a specific mark, which may preceded by any number
  264   ;; of the characters in trimBag, at the beginning of line.  Returns
  265   ;; the remainder of line if successful, and nil otherwise.
  266   (defun TrimMark (trimBag line mark)
  267     (letseq ((trimmed (Trim trimBag line))
  268              (i (PrefixP mark trimmed)))
  269       (when i
  270         (substring trimmed i))))
  271 
  272   ;; ParseHeader tries and parses the comment header of the file
  273   ;; located at path, and whose base name is filename.  It either
  274   ;; returns a DPL to be interpreted by PackageInfoFromBase, or nil if
  275   ;; the file was either unreadable or could not be parsed as a
  276   ;; package descriptor.
  277   (defun ParseHeader (path filename)
  278     (let ((port (infile path)))
  279       (when port
  280         (let ((info (list nil 'header filename))
  281               (authors nil)
  282               (line nil)
  283               (desc nil)
  284               (it nil)
  285               (donep nil))
  286           (while (and (not donep) (gets line port))
  287             (cond
  288               ((equal line "\n")
  289                ;; Continue.
  290                )
  291               ((not (or desc (setq desc (ParseDescriptionLine line filename))))
  292                (setq info nil)
  293                (setq donep nil))
  294               ;; TODO: Understand RFC-2822-style continuation lines.
  295               ((setq it (TrimMark (car desc) line "@load"))
  296                (info->load = (parseString it ", \t\n")))
  297               ((setq it (TrimMark (car desc) line "@requires"))
  298                (info->requires = (parseString it ", \t\n")))
  299               ((setq it (TrimMark (car desc) line "@author"))
  300                (letseq ((s1 (Trim " \t\n" it))
  301                         (s2 (Trim " \t\n" s1 ?fromEndP t)))
  302                  (push s2 authors)))
  303               ;; These key-looking subtitles mark the (premature) end
  304               ;; of parsed header.
  305               ((or (TrimMark (car desc) line "Commentary:")
  306                    (TrimMark (car desc) line "Code:")
  307                    (when (eq (car desc) blockCommentTrimBag)
  308                      (nindex line "*/")))
  309                (setq donep t))))
  310           (close port)
  311           (when info
  312             (info->description = (cadr desc))
  313             (info->authors = (reverse authors))
  314             info)))))
  315 
  316   ;; The ellipsis marker is used at the end of Load directives to
  317   ;; indicate that the other source files ought to be loaded, too.
  318   (define ellipsis
  319       "...")
  320 
  321   ;; ProcessLoadDirective checks that each entry in directive is also
  322   ;; present in files or is a trailing ellipsis.  Returns a list of
  323   ;; three values: the files from directive, whether a trailing
  324   ;; ellipsis was present, and the rest of the files.
  325   (defun ProcessLoadDirective (directive files)
  326     (let ((files (copy files))
  327           (ellipsisp nil))
  328       (let ((loads (foreach maplist dtail directive
  329                      (let ((file (car dtail)))
  330                        (cond
  331                          ((let ((ftail (member file files)))
  332                             (when ftail
  333                               (rplaca ftail nil)
  334                               file)))
  335                          ((and (equal file ellipsis)
  336                                (null (cdr dtail)))
  337                           (setq ellipsisp t)
  338                           nil)
  339                          (t
  340                           (error "No such file: %L; Load header: %L"
  341                                  file directive)))))))
  342         (list (remove nil loads) ellipsisp (remove nil files)))))
  343 
  344   ;; ClassifyFiles saves the files which match one of the subsets in a
  345   ;; correspondingly-named slot of a fresh DPL (Cf. fileSubsets
  346   ;; variable for an example of subset designators), and returns the
  347   ;; DPL.
  348   (defun ClassifyFiles (files subsets)
  349     (let ((dpl (list nil)))
  350       (foreach file files
  351         (exists subset subsets
  352           (let ((suffixes (car subset)))
  353             (exists suffix suffixes
  354               (when (SuffixP suffix file)
  355                 (letseq ((key (cadr subset))
  356                          (accum (get dpl key)))
  357                   (putprop dpl (cons file accum) key)))))))
  358       dpl))
  359 
  360   ;; fileSubsets holds subset designators for test and source files.
  361   (define fileSubsets
  362       '(;; Files ending with these two suffixes are test files.
  363         (("-test.ils" "-test.il") tests)
  364         ;; Files ending in .ils or .il and which are not considered
  365         ;; test files are source files.
  366         ((".ils" ".il")           sources)))
  367 
  368   ;; Helper function for PackageInfoFromBase.
  369   (defun FinalizePackageInfo (base pkg headerInfo loads ellipsisp files)
  370     (letseq ((filesInfo (ClassifyFiles files fileSubsets))
  371              (sources (cond
  372                         ((and loads ellipsisp)
  373                          (append loads filesInfo->sources))
  374                         (loads)
  375                         (t
  376                          filesInfo->sources))))
  377       (makeInstance 'VedaPackageFilesystemInfo
  378                     ?name pkg
  379                     ?description headerInfo->description
  380                     ?authors headerInfo->authors
  381                     ?base base
  382                     ?header headerInfo->header
  383                     ?requires headerInfo->requires
  384                     ?sources sources
  385                     ?tests filesInfo->tests)))
  386 
  387   ;; PackageInfoFromBase returns file-based information about package
  388   ;; pkg (contained below base, and for which some header info has
  389   ;; been found).  It combines the header and file-gathered data into
  390   ;; a fresh instance of VedaPackageFilesystemInfo.
  391   (defun PackageInfoFromBase (base pkg headerInfo)
  392     (letseq ((dir (strcat base pkg "/"))
  393              (files (getDirFiles dir)))
  394       (apply FinalizePackageInfo base pkg headerInfo
  395              (if headerInfo->load
  396                  (ProcessLoadDirective headerInfo->load files)
  397                  (list nil t files)))))
  398 
  399   ;; PackageInfoFromFilesystem tries and find package pkg under one of
  400   ;; the bases, which are filesystem directory names.  It returns a
  401   ;; fresh instance of VedaPackageFilesystemInfo if found, nil
  402   ;; otherwise.
  403   ;;
  404   ;; Cf. PackageInfoFromBase for more information.
  405   (defun PackageInfoFromFilesystem (pkg bases)
  406     (let (info)
  407       (exists base bases
  408         (let ((dir (strcat base pkg)))
  409           (exists suffix '(".il" ".ils")
  410             (letseq ((filename (strcat pkg suffix))
  411                      (path (strcat dir "/" filename))
  412                      (headerInfo (ParseHeader path filename)))
  413               (when headerInfo
  414                 (setq info (PackageInfoFromBase base pkg headerInfo)))))))
  415       info))
  416 
  417   ;; PackageInfo returns metadata about the package named by the
  418   ;; string pkg, either by querying a hook or by searching a number of
  419   ;; preset filesystem bases.
  420   ;;
  421   ;; It returns a concrete subclass of VedaPackageAbstractInfo, or nil
  422   ;; if not found.
  423   ;;
  424   ;; ?options, if non-nil, must be an instance of
  425   ;; VedaPackageSearchOptions. If nil, a default-initialized instance
  426   ;; is used.
  427   ;;
  428   ;; The hook, if present, must be named VedaPackageInfoHook and is
  429   ;; invoked as:
  430   ;;
  431   ;;     (VedaPackageInfoHook pkg)
  432   ;;
  433   ;; where pkg is the package name.
  434   (defun PackageInfo (pkg @key options)
  435     (cond
  436       ((isCallable 'VedaPackageInfoHook)
  437        (funcall 'VedaPackageInfoHook pkg))
  438       (t
  439        (let ((options (or options defaultOptions)))
  440          (PackageInfoFromFilesystem pkg (GetSearchPath options))))))
  441 
  442   (Export 'Info PackageInfo)
  443 
  444   ;; LoaderFromPackageInfo returns a function which will load a
  445   ;; specific subset of the package described by info, an instance of
  446   ;; VedaPackageFilesystemInfo.
  447   (defun LoaderFromPackageInfo (info subset)
  448     (let (files)
  449       (when (setq files (get info subset))
  450         (let ((dir (strcat info->base info->name "/")))
  451           (FilesLoader files ?dir dir)))))
  452 
  453   ;; LoadSubsetFromPackageInfo loads a specific subset of the package
  454   ;; described by info, an instance of VedaPackageFilesystemInfo.
  455   (defun LoadSubsetFromPackageInfo (info subset)
  456     (let ((loader (LoaderFromPackageInfo info subset)))
  457       (if loader
  458           (funcall loader ?subset subset)
  459           (error "Don't know how to load %s from package %L."
  460                  subset info)))
  461     t)
  462 
  463   ;; Recursive helper for RequirePackage.
  464   (defun RequirePackageRec (pkg loaded options noPackageRequiresP)
  465     (let (info)
  466       (cond
  467         ((arrayref loaded pkg))
  468         ((setq info (PackageInfo pkg ?options options))
  469          (unless noPackageRequiresP
  470            (foreach require info->requires
  471              (RequirePackageRec require loaded options noPackageRequiresP)))
  472          (LoadSubsetFromPackageInfo info 'sources)
  473          (setarray loaded pkg info))
  474         (t
  475          (error "Package %L not found." pkg)))))
  476 
  477   ;; RequirePackage loads the sources from pkg if and only if it is
  478   ;; not already indexed in the loaded table.  Each package mentioned
  479   ;; in options->requires is "RequirePackage'd" before this one, as is
  480   ;; any package mentioned in @requires--unless inhibited by the
  481   ;; noPackageRequiresP option.
  482   (defun RequirePackage (pkg loaded options)
  483     (letseq ((requires (GetRequires options))
  484              (noPackageRequiresP (neq requires t)))
  485       (when (pairp requires)
  486         (foreach require requires
  487           (RequirePackageRec require loaded options noPackageRequiresP)))
  488       (RequirePackageRec pkg loaded options noPackageRequiresP)))
  489 
  490   ;; MakeLoadedTable returns a table pre-populated with the packages
  491   ;; contained in preloaded, which are considered as "magically
  492   ;; preloaded."  (This is used to work around builtins and files
  493   ;; loaded during bootstrap.)
  494   (defun MakeLoadedTable (preloaded)
  495     (let ((loaded (makeTable 'loaded nil)))
  496       (foreach pkg preloaded
  497         (let ((info (PackageInfo pkg)))
  498           (setarray loaded pkg info)))
  499       loaded))
  500 
  501   ;; The table of loaded packages.
  502   (define defaultLoadedTable
  503       (MakeLoadedTable '("package")))
  504 
  505   ;; PackageLoad loads the sources of the package named by the string
  506   ;; pkg, as well as its dependencies, as necessary or requested via
  507   ;; the ?options argument.
  508   ;;
  509   ;; ?options, if non-nil, must be an instance of
  510   ;; VedaPackageLoadOptions.  If nil, a default-initialized instance
  511   ;; is used.
  512   ;;
  513   ;; The PackageInfo function is used for locating the package and its
  514   ;; dependencies, using the same ?options argument as PackageLoad.
  515   ;; An error is raised if one of the packages cannot be found.
  516   ;;
  517   ;; The function returns the concrete subclass of
  518   ;; VedaPackageAbstractInfo corresponding to pkg.
  519   (defun PackageLoad (pkg @key options)
  520     (letseq ((options (or options defaultOptions))
  521              (forceReload (GetForceReload options)))
  522       (cond
  523         ((eq forceReload t)
  524          (setq defaultLoadedTable
  525                (MakeLoadedTable nil)))
  526         ((pairp forceReload)
  527          (foreach pkg forceReload
  528            (remove pkg defaultLoadedTable))))
  529       (RequirePackage pkg defaultLoadedTable options)))
  530 
  531   (Export 'Load PackageLoad))
  532 
  533 ;;; package.ils ends here