Source File package/package.ils

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