├── .gitignore ├── AUTHORS ├── LICENSE ├── Makefile ├── README.md ├── bin ├── .gitignore ├── .mkexec └── .mkexec-win ├── doc └── versions.smackspec.example ├── smack-nonposix.cm ├── smack-nonposix.mlb ├── smack.cm ├── smack.mlb ├── smackage.smackspec ├── smackage.smackspec.in ├── sources ├── sources.cm ├── sources.mlb ├── src ├── bullshit-symlink.smi ├── bullshit-symlink.sml ├── conductor.sig ├── conductor.smi ├── conductor.sml ├── configure.smi ├── configure.sml ├── curl-lib.smi ├── curl-lib.sml ├── fsutil.smi ├── fsutil.sml ├── get-git.smi ├── get-git.sml ├── go-nj-nonposix.sml ├── go-nj.sml ├── go.smi ├── go.sml ├── http-downloader.sig ├── install.smi ├── install.sml ├── main.smi ├── main.sml ├── poly_build.sml ├── poly_mlyacc.sml ├── poly_smlnj-lib.sml ├── posix-symlink.sml ├── protocol.smi ├── protocol.sml ├── semver.smi ├── semver.sml ├── smackage-path.smi ├── smackage-path.sml ├── smacklib.smi ├── smacklib.sml ├── spec.smi ├── spec.sml ├── version-index.smi ├── version-index.sml ├── version.smi └── version.sml ├── util ├── README ├── dict-list.smi ├── dict-list.sml ├── dict.sig ├── sort.smi ├── sort.sml ├── sources.cm └── sources.mlb └── version.sh /.gitignore: -------------------------------------------------------------------------------- 1 | *~ 2 | .cm 3 | /smack 4 | /bin/smackage 5 | /bin/.heap* 6 | *.o 7 | -------------------------------------------------------------------------------- /AUTHORS: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/standardml/smackage/3fc3be9c90fea3abfdff03b553ca772c931cd640/AUTHORS -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Smackage SML Package System 2 | 3 | Copyright (c) 2011, Smackage Authors (See AUTHORS file) 4 | All rights reserved. 5 | 6 | Redistribution and use in source and binary forms, with or without 7 | modification, are permitted provided that the following conditions are met: 8 | 9 | Redistributions of source code must retain the above copyright notice, this 10 | list of conditions and the following disclaimer. 11 | 12 | Redistributions in binary form must reproduce the above copyright notice, 13 | this list of conditions and the following disclaimer in the documentation 14 | and/or other materials provided with the distribution. 15 | 16 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 17 | AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 18 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 19 | ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE 20 | LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR 21 | CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF 22 | SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 23 | INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN 24 | CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) 25 | ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 26 | POSSIBILITY OF SUCH DAMAGE. 27 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | BIN=bin 2 | TARGET=$(BIN)/smackage 3 | 4 | MLTON=mlton 5 | 6 | SMLNJ=sml 7 | 8 | POLYML := $(shell { command -v poly || echo polyml; } 2>/dev/null) 9 | POLYML_LDFLAGS := $(shell { pkg-config --libs polyml || echo -lpolymain -lpolyml; } 2>/dev/null) 10 | 11 | MLKIT=mlkit 12 | 13 | SMLSHARP=smlsharp 14 | SMLSHARP_MODULES_=$(wildcard src/*.smi) $(wildcard util/*.smi) 15 | SMLSHARP_MODULES=$(SMLSHARP_MODULES_:.smi=.sml) 16 | SMLSHARP_CFLAGS=-O2 17 | SMLSHARP_LDFLAGS= 18 | smlsharp_sources:=$(SMLSHARP_MODULES) 19 | smlsharp_objects:=$(smlsharp_sources:.sml=.o) 20 | 21 | all: 22 | @echo "== Smackage Installation ==" 23 | @echo "Run 'make mlton', 'make smlnj', 'make polyml', 'make mlkit' or 'make smlsharp' on Linux/Unix/OSX." 24 | @echo "Run 'make win+smlnj' or 'make win+mlton' on Windows." 25 | @echo "In Smackage, then run 'make install' to install." 26 | false 27 | 28 | mlton: 29 | $(MLTON) -output $(TARGET) smack.mlb 30 | 31 | win+mlton: 32 | $(MLTON) -output $(TARGET) smack-nonposix.mlb 33 | 34 | smlnj: 35 | $(SMLNJ) src/go-nj.sml 36 | bin/.mkexec `which sml` `pwd` smackage 37 | 38 | win+smlnj: 39 | $(SMLNJ) src/go-nj-nonposix.sml 40 | bin/.mkexec-win `which sml` `pwd` smackage 41 | 42 | polyml: 43 | $(POLYML) < src/poly_build.sml 44 | $(CC) -o $(BIN)/smackage $(BIN)/polyml-smackage.o $(POLYML_LDFLAGS) 45 | 46 | mlkit: 47 | $(MLKIT) -o $(BIN)/smackage smack.mlb 48 | 49 | smlsharp: $(smlsharp_objects) 50 | $(SMLSHARP) $(SMLSHARP_LDFLAGS) $(SMLSHARP_FLAGS) -o $(TARGET) src/go.smi 51 | 52 | %.o: %.sml 53 | $(SMLSHARP) $(SMLSHARP_CFLAGS) $(SMLSHARP_FLAGS) -c -o $@ $< 54 | 55 | clean: 56 | rm -f $(BIN)/smackage 57 | rm -f $(smlsharp_objects) 58 | 59 | smackage-install: 60 | @echo "NOTICE: This is probably not the command you meant to run." 61 | @echo "If you are invoking this makefile through smackage by" 62 | @echo "running `smackage make smackage smackage-install', then in the" 63 | @echo "future you should run `smackage make smackage install' instead." 64 | @echo "" 65 | @echo "This version still works if you want to run `make' directly" 66 | @echo "instead of invoking it indirectly (`smackage make smackage')." 67 | @echo "However, the latter option is suggested." 68 | rm -f ../../../bin/smackage.new 69 | cp $(BIN)/smackage ../../../bin/smackage.new 70 | mv ../../../bin/smackage.new ../../../bin/smackage 71 | 72 | install: 73 | mkdir -p $(DESTDIR)/bin 74 | rm -f $(DESTDIR)/bin/smackage.new 75 | cp $(BIN)/smackage $(DESTDIR)/bin/smackage.new 76 | mv $(DESTDIR)/bin/smackage.new $(DESTDIR)/bin/smackage 77 | 78 | .PHONY: clean mlton smlnj polyml mlkit smlsharp 79 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | Smackage is a prototype package manager for Standard ML libraries. Right now 2 | it does only minimal installation; it is mainly designed to provide a 3 | standard way of getting Standard ML code that understands where other 4 | Standard ML code might be found on the filesystem. 5 | 6 | Installation 7 | ------------ 8 | Installation takes five steps, and the first and last two steps are 9 | optional. 10 | 11 | **Step 1: Pick a `SMACKAGE_HOME` directory (optional).** 12 | 13 | The `$SMACKAGE_HOME` directory is where Smackage will put all of its files. 14 | This will be `~/.smackage` by default if you don't do anything; see the 15 | section "The $SMACKAGE_HOME directory" towards the bottom if you'd like 16 | Smackage to put its files somewhere else. 17 | 18 | **Step 2: Set up your SML compilers to use Smackage.** 19 | 20 | You have to configure your SML compilers to find the code that Smackage 21 | will put on your system. This is a bit system-dependent; see the section 22 | "Setting up your SML path map" below for details. 23 | 24 | **Step 3: Download.** 25 | 26 | Finally, you can actually build Smackage with the following commands; the 27 | first `git clone...` command is just one of the ways you can get smackage 28 | onto your hard drive; an alternative would be to download one of the 29 | [tarred or zipped releases](https://github.com/standardml/smackage/tags). 30 | Note: the directory (probably named `smackage`) that you put the initial 31 | Smackage code into should *not* be the same as the `$SMACKAGE_HOME` 32 | directory. 33 | 34 | $ git clone https://github.com/standardml/smackage.git # or something 35 | $ cd smackage 36 | $ make mlton # (or `smlnj', or `win+smlnj' if you're in Cygwin) 37 | $ bin/smackage 38 | 39 | Smackage now lives in the `bin` subdirectory of the current directory. 40 | 41 | To install smackage in $SMACKAGE_HOME, 42 | 43 | $ DESTDIR=$SMACKAGE_HOME make install 44 | 45 | Now you can proceed to update your path and use smackage without having the build repository available. 46 | 47 | **Step 4: Update your PATH (optional).** 48 | 49 | Smackage-aware applications have a makefile option `install` that places 50 | a binary in `$SMACKAGE_HOME/bin` *IF* the makefile is invoked through 51 | `smackage make`. If you want to use Smackage to install applications, 52 | you should add `$SMACKAGE_HOME/bin` to your `PATH` environment variable. 53 | 54 | (Remember: don't literally add `$SMACKAGE_HOME/bin`, replace 55 | `$SMACKAGE_HOME` with the absolute path of whatever directory you picked 56 | in Step 1. So you'll really add something like 57 | `/Users/myusername/.smackage/bin` to your path.) 58 | 59 | **Step 5: Bootstrap (optional).** 60 | 61 | Smackage is a smackage-aware application! If you added 62 | `$SMACKAGE_HOME/bin` to your search path, then you can run the following: 63 | 64 | $ bin/smackage refresh 65 | $ bin/smackage make smackage mlton # or smlnj, or win+smlnj, etc 66 | $ bin/smackage make smackage install 67 | $ which smackage 68 | 69 | (Type `bin/smackage make smackage` to see all the possible installation 70 | options: polyml, win+mlton, mlkit, etc...) 71 | 72 | The last command, `which smackage`, should report that Smackage can be found 73 | at `$SMACKAGE_HOME/bin/smackage`. Now you've bootstrapped Smackage: you no 74 | longer need the current directory where you downloaded Smackage, you just 75 | need the `$SMACKAGE_HOME` directory. 76 | 77 | ### Referring to Smackage packages 78 | 79 | If you've performed all the steps described above, you will be able to 80 | refer to cmlib as `$SMACKAGE/cmlib/v1/cmlib.cm` (in SML/NJ .cm files) or as 81 | `$(SMACKAGE)/cmlib/v1/cmlib.mlb` (in .mlb files). 82 | 83 | You want to add `$SMACKAGE_HOME/bin` to your path if you want to use 84 | applications compiled through Smackage. 85 | 86 | ### Building Smackage packages 87 | 88 | Smackage doesn't have a uniform build process, at least not yet. Instead, we 89 | support a simple `smackage make` command. If you type 90 | `smackage make package blah blah blah`, smackage will try to run 91 | `make blah blah blah` in the directory where `package` lives. We suggest that 92 | if your tool compiles into binaries, say, you add a makefile option `install` that copies the 93 | created binaries to the directory `$(DESTDIR)/bin`, in the style 94 | described [here](http://www.gnu.org/prep/standards/html_node/DESTDIR.html). 95 | For instance, the following commands get and install [Twelf](http://twelf.org). 96 | 97 | $ smackage refresh 98 | $ smackage get twelf 99 | $ smackage make twelf smlnj # or mlton, ... 100 | $ smackage make twelf install 101 | 102 | If `$SMACKAGE_HOME/bin` is on your search path, you can then refer to the 103 | `twelf-server` binary like this: 104 | 105 | $ which twelf-server 106 | /Users/rjsimmon/.smackage/bin/twelf-server 107 | $ twelf-server 108 | Twelf 1.7.1+ (built 10/30/11 at 00:37:12 on concordia.wv.cc.cmu.edu) 109 | %% OK %% 110 | 111 | Setting up your SML path map 112 | ---------------------------- 113 | Smackage will live in a directory that we'll refer to 114 | as `$SMACKAGE_HOME` in this section. This directory is probably 115 | `~/.smackage`, but see the section on `$SMACKAGE_HOME` below for more 116 | information. Whenever you see the string `$SMACKAGE_HOME` in the text below, you 117 | should replace it with the appropriate absolute file path, for instance I 118 | wouldn't actually write 119 | 120 | SMACKAGE $SMACKAGE_HOME/lib 121 | 122 | in a pathconfig file for Standard ML of New Jersey; instead, I'd write 123 | 124 | SMACKAGE /Users/rjsimmon/.smackage/lib 125 | 126 | Make sure you use an absolute path - starting with "/", or whatever your system 127 | uses to refer to the file system root. 128 | 129 | ### Setting up SML/NJ (system-wide) 130 | 131 | Find the file `lib/pathconfig` in the installation directory for SML/NJ, and 132 | add the following line: 133 | 134 | SMACKAGE $SMACKAGE_HOME/lib 135 | 136 | ### Setting up SML/NJ (user-only) 137 | 138 | Create a file `~/.smlnj-pathconfig` containing the following line (or add 139 | the following line to `~/.smlnj-pathconfig` if it exists already): 140 | 141 | SMACKAGE $SMACKAGE_HOME/lib 142 | 143 | ### Setting up MLton (system-wide) 144 | 145 | Find the [MLBasis Path Map](http://mlton.org/MLBasisPathMap), stored 146 | in a file called `mlb-path-map`, usually somewhere like 147 | `/usr/lib/mlton/mlb-path-map` or 148 | `/usr/local/lib/mlton/mlb-path-map`, depending on your system. Add the line 149 | 150 | SMACKAGE $SMACKAGE_HOME/lib 151 | 152 | ### Setting up MLton (user-only) 153 | 154 | MLton allows mlb path variables to be set on the `mlton` command 155 | line. If you don't want to edit the global `mlb-path-map` file, you 156 | can pass the SMACKAGE path as a command line argument to `mlton`. Since 157 | doing this all the time is tedious and would break build scripts, you 158 | probably want to set up a wrapper script somewhere in your path that 159 | looks like: 160 | 161 | #!/bin/sh 162 | $MLTON_PATH -mlb-path-var 'SMACKAGE $SMACKAGE_HOME/lib' "$@" 163 | 164 | where `$MLTON_PATH` and `$SMACKAGE_HOME` are replaced with the appropriate 165 | paths. For example, on my system, I have a file `/home/sully/bin/mlton` 166 | that contains: 167 | 168 | #!/bin/sh 169 | /usr/bin/mlton -mlb-path-var 'SMACKAGE /home/sully/.smackage/lib' "$@" 170 | 171 | ### Setting up MLKit or SMLtoJs 172 | 173 | [MLKit](http://melsman.github.io/mlkit) and 174 | [SMLtoJs](http://www.smlserver.org/smltojs) support 175 | [.mlb-files](http://www.elsman.com/mlkit/mlbasisfiles.html) much like 176 | MLton. The only limitation is that MLKit and SMLtoJs do not support 177 | export filtering through the use of explicit MLB module bindings. 178 | 179 | To allow for MLKit or SMLtoJs to find a definition for the `$SMACKAGE` 180 | MLB path variable, add a line to the appropriate `mlb-path-map` file 181 | found in `~/.mlkit/`, `~/.smltojs/`, `/usr/local/mlkit/`, or 182 | `/usr/local/smltojs`: 183 | 184 | SMACKAGE $SMACKAGE_HOME/lib 185 | 186 | Be aware that when MLKit (or SMLtoJs) is compiling a package, it will 187 | write files within `MLB/` subfolders of the package's folder. This 188 | behavior may cause problems if you don't have write access to the 189 | `$SMACKAGE_HOME/lib` folder. 190 | 191 | The $SMACKAGE_HOME directory 192 | ---------------------------- 193 | Smackage has to figure out where it lives on the file system whenever it 194 | starts up; the installation instructions referred to the directory where 195 | smackage lives as `$SMACKAGE_HOME`. Smackage goes through the following process 196 | to try and determine `$SMACKAGE_HOME`: 197 | 198 | 1. If the `SMACKAGE_HOME` environment variable is defined, then smackage will 199 | always use that as `$SMACKAGE_HOME`. If this directory does not 200 | exist, smackage will try to create it. Otherwise, 201 | 2. If `/usr/local/smackage` exists, smackage will use that as 202 | `$SMACKAGE_HOME`. Otherwise, 203 | 3. If `/opt/smackage/` exists, smackage will use that as 204 | `$SMACKAGE_HOME`. Otherwise, 205 | 4. As a last resort, smackage will try to use `~/.smackage`, where `~` is 206 | defined by the `HOME` environment variable. If this directory does not 207 | exist, smackage will try to create it. 208 | -------------------------------------------------------------------------------- /bin/.gitignore: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/standardml/smackage/3fc3be9c90fea3abfdff03b553ca772c931cd640/bin/.gitignore -------------------------------------------------------------------------------- /bin/.mkexec: -------------------------------------------------------------------------------- 1 | #! /bin/sh 2 | # 3 | # Batch File Creator 4 | # 5 | # Arguments: 6 | # $1 = SMLNJ runtime 7 | # $2 = Directory of binaries and heap image 8 | # $3 = Name of executable (e.g. celf) 9 | cat > "$2/bin/$3" < "$2/bin/$3" < 4 | maintainer: Robert J. Simmons 5 | maintainer: Michael Sullivan 6 | keywords: package manager 7 | bug-url: https://github.com/standardml/smackage/issues 8 | platform: mlton 9 | build: make mlton 10 | install: mv bin/smackage ../../../bin/smackage 11 | platform: win+smlnj 12 | build: make win+smlnj 13 | install: mv bin/smackage ../../../bin/smackage 14 | platform: smlnj 15 | build: make smlnj 16 | install: mv bin/smackage ../../../bin/smackage 17 | platform: smlsharp 18 | build: make smlsharp 19 | install: mv bin/smackage ../../../bin/smackage 20 | platform: polyml 21 | build: make polyml 22 | install: mv bin/smackage ../../../bin/smackage 23 | -------------------------------------------------------------------------------- /smackage.smackspec.in: -------------------------------------------------------------------------------- 1 | provides: smackage ###VERSION### 2 | description: Smackage, a simple Standard ML package manager 3 | maintainer: Gian Perrone 4 | maintainer: Robert J. Simmons 5 | maintainer: Michael Sullivan 6 | keywords: package manager 7 | bug-url: https://github.com/standardml/smackage/issues 8 | platform: mlton 9 | build: make mlton 10 | install: mv bin/smackage ../../../bin/smackage 11 | platform: win+smlnj 12 | build: make win+smlnj 13 | install: mv bin/smackage ../../../bin/smackage 14 | platform: smlnj 15 | build: make smlnj 16 | install: mv bin/smackage ../../../bin/smackage 17 | platform: smlsharp 18 | build: make smlsharp 19 | install: mv bin/smackage ../../../bin/smackage 20 | platform: polyml 21 | build: make polyml 22 | install: mv bin/smackage ../../../bin/smackage 23 | -------------------------------------------------------------------------------- /sources: -------------------------------------------------------------------------------- 1 | bpltool git https://github.com/standardml/bpltool.git 2 | celf git https://github.com/clf/celf.git 3 | cmlib git https://github.com/standardml/cmlib.git 4 | elton git https://github.com/robsimmons/l10.git 5 | llf git https://github.com/clf/llf.git 6 | lollimon git https://github.com/clf/lollimon.git 7 | nanomq git https://github.com/gian/smlnanomq.git 8 | ollibot git https://github.com/clf/ollibot.git 9 | parcom git https://github.com/standardml/parcom.git 10 | preml git https://github.com/mortenbp/PreML.git 11 | qcheck git https://github.com/standardml/qcheck.git 12 | readline git https://github.com/standardml/readline.git 13 | smackage git https://github.com/standardml/smackage.git 14 | smbt git https://github.com/finrod/smbt.git 15 | smlcgi git https://github.com/standardml/smlcgi.git 16 | smldoc git https://github.com/standardml/SMLDoc.git 17 | smlnj git https://github.com/standardml/smlnj-installer.git 18 | smlpeg git https://github.com/standardml/SMLPEG.git 19 | sml-json git https://github.com/standardml/SML-JSON.git 20 | tom7-lib git https://github.com/robsimmons/sml-lib.git 21 | twelf git https://github.com/standardml/twelf.git 22 | unicode git https://github.com/melsman/unicode.git 23 | uri git https://github.com/finrod/uri.git 24 | mltonlib git https://github.com/MLton/mltonlib.git 25 | sml-db git https://github.com/kni/sml-db.git 26 | sml-ev git https://github.com/kni/sml-ev.git 27 | sml-net-server-ev git https://github.com/kni/sml-net-server-ev.git 28 | -------------------------------------------------------------------------------- /sources.cm: -------------------------------------------------------------------------------- 1 | Group is 2 | $/basis.cm 3 | util/sources.cm 4 | src/fsutil.sml 5 | 6 | (* Smackage data types *) 7 | src/protocol.sml 8 | src/semver.sml 9 | src/spec.sml 10 | 11 | (* Managing local data *) 12 | src/version-index.sml 13 | src/configure.sml 14 | (* src/install.sml *) 15 | 16 | (* Obtaining and manipulating code and packages *) 17 | src/get-git.sml 18 | src/conductor.sig 19 | src/conductor.sml 20 | src/http-downloader.sig 21 | src/curl-lib.sml 22 | -------------------------------------------------------------------------------- /sources.mlb: -------------------------------------------------------------------------------- 1 | 2 | $(SML_LIB)/basis/basis.mlb 3 | util/sources.mlb 4 | src/fsutil.sml 5 | 6 | (* Smackage data types *) 7 | src/protocol.sml 8 | src/semver.sml 9 | src/spec.sml 10 | 11 | (* Managing local data *) 12 | src/version-index.sml 13 | src/configure.sml 14 | (* src/install.sml *) 15 | 16 | (* Obtaining and manipulating code and packages *) 17 | src/get-git.sml 18 | src/conductor.sig 19 | src/conductor.sml 20 | src/http-downloader.sig 21 | src/curl-lib.sml 22 | -------------------------------------------------------------------------------- /src/bullshit-symlink.smi: -------------------------------------------------------------------------------- 1 | _require "basis.smi" 2 | structure Symlink = 3 | struct 4 | (* This scares me a lot. *) 5 | val remove: string -> unit 6 | val copyDir: string -> string -> unit 7 | val replaceOrCreateSymlink: string -> string -> unit 8 | end 9 | -------------------------------------------------------------------------------- /src/bullshit-symlink.sml: -------------------------------------------------------------------------------- 1 | (* This is a fake "symlink" implementation that works by copying the directory 2 | * tree. We need this on windows. Currently, we rely on unix utilities being 3 | * in the path, though. *) 4 | structure Symlink = 5 | struct 6 | (* This scares me a lot. *) 7 | fun remove s = 8 | if not (OS.Process.isSuccess (OS.Process.system ("rm -rf " ^ s))) 9 | then raise Fail "removing old version directory failed" else () 10 | 11 | fun copyDir dst src = 12 | let 13 | val print = fn _ => () (* comment this to debug *) 14 | val () = print ("Current directory: " ^ OS.FileSys.getDir () ^ "\n") 15 | val line = "cp -r " ^ src ^ " " ^ dst 16 | val () = print ("COPY: " ^ line ^ "\n") 17 | in 18 | if not (OS.Process.isSuccess (OS.Process.system line)) 19 | then raise Fail "copying version failed" else () 20 | end 21 | 22 | fun replaceOrCreateSymlink target link = 23 | let 24 | (* Delete the old directory if it exists *) 25 | val e = OS.FileSys.isDir link handle _ => false 26 | val _ = if e then remove link else () 27 | 28 | (* Create the new one *) 29 | val _ = copyDir link target 30 | in 31 | () 32 | end 33 | handle (Fail s) => (print (s ^ "\n"); raise Fail s) 34 | end 35 | -------------------------------------------------------------------------------- /src/conductor.sig: -------------------------------------------------------------------------------- 1 | (* CONDUCTOR is the interface between the "configuration"ey parts of smackage 2 | * and the raw, get-my-code parts. *) 3 | 4 | signature CONDUCTOR = 5 | sig 6 | (* get smackagePath packageName ver prot 7 | * Makes semantic version ver available within 8 | * the package directory ($smackagePath)/lib/($packageName)/v($ver). 9 | * It assumes this directory exists. *) 10 | val get: string -> string -> SemVer.semver -> Protocol.protocol -> unit 11 | 12 | (* poll name prot 13 | * Query the remote store for which tags are available. *) 14 | val poll: string -> Protocol.protocol -> Spec.spec list 15 | end 16 | 17 | -------------------------------------------------------------------------------- /src/conductor.smi: -------------------------------------------------------------------------------- 1 | _require "basis.smi" 2 | _require "conductor.sig" 3 | _require "protocol.smi" 4 | _require "semver.smi" 5 | _require "get-git.smi" 6 | _require "spec.smi" 7 | 8 | structure Conductor = 9 | struct 10 | (* get smackagePath packageName ver prot 11 | * Makes semantic version ver available within 12 | * the package directory ($smackagePath)/lib/($packageName)/v($ver). 13 | * It assumes this directory exists. *) 14 | val get: string -> string -> SemVer.semver -> Protocol.protocol -> unit 15 | 16 | (* poll name prot 17 | * Query the remote store for which tags are available. *) 18 | val poll: string -> Protocol.protocol -> Spec.spec list 19 | end 20 | 21 | 22 | -------------------------------------------------------------------------------- /src/conductor.sml: -------------------------------------------------------------------------------- 1 | 2 | structure Conductor:> CONDUCTOR = 3 | struct 4 | fun get smackagePath packageName ver prot = 5 | case prot of 6 | Protocol.Git { uri } => GetGit.get smackagePath packageName uri ver 7 | 8 | fun poll name prot = 9 | case prot of 10 | Protocol.Git { uri } => 11 | let fun prov (_, semver) = Spec.Provides (name, semver) 12 | in 13 | [ Spec.Remote prot :: map prov (GetGit.poll uri) ] 14 | end 15 | end 16 | 17 | 18 | -------------------------------------------------------------------------------- /src/configure.smi: -------------------------------------------------------------------------------- 1 | _require "basis.smi" 2 | _require "fsutil.smi" 3 | _require "version-index.smi" 4 | 5 | structure Configure = 6 | struct 7 | val smackHome: string ref 8 | 9 | val smackSources: string list ref 10 | 11 | val platform : string ref 12 | 13 | val compilers : string list ref 14 | 15 | val initSmackHome: unit -> unit 16 | val initFile: string -> string -> unit 17 | val initDir: string -> unit 18 | val readConfigFile: unit -> unit 19 | val guessPlatform: unit -> string 20 | val init: unit -> unit 21 | end 22 | -------------------------------------------------------------------------------- /src/configure.sml: -------------------------------------------------------------------------------- 1 | (** Stateful configuration, hopefully with sensible defaults *) 2 | structure Configure = 3 | struct 4 | fun // (dir, file) = OS.Path.joinDirFile { dir = dir, file = file } 5 | infix 5 // 6 | 7 | val smackHome = ref "" 8 | 9 | val smackSources: string list ref = ref [] 10 | 11 | val platform : string ref = ref "" 12 | 13 | val compilers : string list ref = ref [] 14 | 15 | (** Attempt to ascertain the smackage home directory. 16 | Resolved in this order: 17 | 18 | SMACKAGE_HOME environment variable 19 | /usr/local/smackage/ 20 | /opt/smackage/ 21 | ~/.smackage/ 22 | *) 23 | fun initSmackHome () = 24 | let 25 | val getEnv = OS.Process.getEnv 26 | fun tryDir (SOME s) = ((OS.FileSys.openDir s; true) handle _ => false) 27 | | tryDir NONE = false 28 | fun useThisDir dir = 29 | if tryDir (SOME dir) then smackHome := dir 30 | else ( print ( "NOTICE: dir `" 31 | ^ dir ^ "' doesn't exist, trying to create it.\n") 32 | ; OS.FileSys.mkDir dir 33 | handle _ => raise Fail "Couldn't create home directory" 34 | ; smackHome := dir) 35 | in 36 | if Option.isSome (getEnv "SMACKAGE_HOME") 37 | then (* $SMACKAGE_HOME is set, definitely go with that. *) 38 | useThisDir (valOf (getEnv "SMACKAGE_HOME")) 39 | else if tryDir (SOME "/usr/local/smackage") 40 | then smackHome := "/usr/local/smackage" 41 | else if tryDir (SOME "/opt/smackage") 42 | then smackHome := "/opt/smackage" 43 | else if Option.isSome (OS.Process.getEnv "HOME") 44 | then (* $HOME set, we're out of other options. Try ~/.smackage *) 45 | useThisDir (valOf (getEnv "HOME") // ".smackage") 46 | else raise Fail "Cannot find smackage home. Try setting SMACKAGE_HOME" 47 | end 48 | 49 | fun initFile fileName contents = 50 | let 51 | val filePath = 52 | OS.Path.joinDirFile { dir = !smackHome, file = fileName } 53 | 54 | fun create () = 55 | let 56 | val () = 57 | print ("NOTICE: file `" ^ fileName ^ "' doesn't exist,\ 58 | \ trying to create it.\n") 59 | val file = TextIO.openOut filePath 60 | in 61 | ( TextIO.output (file, contents) 62 | ; TextIO.closeOut file) 63 | end 64 | in 65 | if not (OS.FileSys.access (filePath, [])) 66 | then create () else 67 | if not (OS.FileSys.access (filePath, [ OS.FileSys.A_READ 68 | , OS.FileSys.A_WRITE ])) 69 | then raise Fail ("Can't read/write to `" ^ fileName 70 | ^ "' (run as sudo?)") 71 | else () 72 | end handle exn => 73 | ( print ("Error with `" ^ fileName ^ "' file.\n") 74 | ; raise exn) 75 | 76 | fun initDir dirName = 77 | let 78 | val dirPath = 79 | OS.Path.joinDirFile { dir = !smackHome, file = dirName } 80 | fun create () = 81 | let 82 | val () = 83 | print ("NOTICE: dir `" ^ dirName ^ "' doesn't exist,\ 84 | \ trying to create it.\n") 85 | in 86 | OS.FileSys.mkDir dirPath 87 | end 88 | in 89 | if not (OS.FileSys.access (dirPath, [])) 90 | then create () else 91 | if not (OS.FileSys.isDir dirPath) 92 | then raise Fail ("File `" ^ dirName 93 | ^ "' exists and is not a directory") 94 | else () 95 | end 96 | 97 | fun readConfigFile () = 98 | let 99 | val config = OS.Path.joinDirFile { dir = !smackHome, file = "config" } 100 | 101 | fun loop file = 102 | case Option.map 103 | (String.tokens Char.isSpace) 104 | (TextIO.inputLine file) of 105 | NONE => TextIO.closeIn file 106 | | SOME [] => loop file 107 | | SOME [ "source", f ] => 108 | ( smackSources := !smackSources @ [ f ] ; loop file) 109 | | SOME [ "platform", p ] => 110 | ( platform := p ; loop file) 111 | | SOME [ "compiler", cmp ] => 112 | ( compilers := !compilers @ [ cmp ] ; loop file) 113 | | SOME s => 114 | raise Fail ( "Bad configuration line: " 115 | ^ String.concatWith " " s ) 116 | in 117 | if not (OS.FileSys.access (config, [])) then () else 118 | if not (OS.FileSys.access (config, [ OS.FileSys.A_READ ])) 119 | then raise Fail "Config file exists but can't be read" 120 | else loop (TextIO.openIn config) 121 | end 122 | 123 | 124 | (** Attempt to guess an appropriate default 'platform' config value. 125 | Based on the output of 'uname -s'. Defaults to 'linux' if we can't 126 | guess, because that's probably safe for most POSIX-compliant systems. *) 127 | fun guessPlatform () = 128 | let 129 | val s = FSUtil.systemCleanLines "uname -s" 130 | in 131 | if null s then "win" else 132 | if String.isPrefix "Darwin" (hd s) then "osx" else 133 | if String.isPrefix "CYGWIN" (hd s) then "win" else "linux" 134 | end 135 | 136 | fun init () = 137 | ( initSmackHome () 138 | ; initFile "sources.local" 139 | "smackage git https://github.com/standardml/smackage.git\n" 140 | ; initFile "config" 141 | ("source " ^ ("lib" // "smackage" // "v1" // "sources") ^ "\n\ 142 | \compiler mlton\n\ 143 | \compiler smlnj\n\ 144 | \platform " ^ guessPlatform () ^ "\n") 145 | ; initFile "packages.installed" "smackage v1\n" 146 | ; initFile "versions.smackspec" "\n" 147 | ; initDir "lib" 148 | ; initDir "bin" 149 | ; readConfigFile () 150 | ; VersionIndex.init (!smackHome)) 151 | 152 | (* 153 | fun readConfig () = 154 | let 155 | val config = 156 | OS.FileSys.joinDirPath { dir = smackHome, file = "config" } 157 | in 158 | if OS.FileSys.access (config, [ OS.FileSys.A_READ ]) 159 | then 160 | else () 161 | end 162 | *) 163 | end 164 | -------------------------------------------------------------------------------- /src/curl-lib.smi: -------------------------------------------------------------------------------- 1 | _require "basis.smi" 2 | _require "http-downloader.sig" 3 | _require "fsutil.smi" 4 | 5 | structure CurlDownloader = 6 | struct 7 | exception HttpException of string 8 | type url = string 9 | type filename = string 10 | 11 | val retrieve : url -> filename -> unit 12 | val retrieveLines : url -> string list 13 | val retrieveCleanLines : url -> string list 14 | end 15 | 16 | -------------------------------------------------------------------------------- /src/curl-lib.sml: -------------------------------------------------------------------------------- 1 | (** A thin helper wrapping curl. Can retrieve files via HTTP. 2 | * This should probably be in a seperate library? 3 | * (Although it is kind of too bad to be worth doing that...) 4 | *) 5 | structure CurlDownloader : HTTP_DOWNLOADER = 6 | struct 7 | exception HttpException of string 8 | type url = string 9 | type filename = string 10 | 11 | fun retrieve url outputFile = 12 | if (OS.Process.isSuccess o OS.Process.system) 13 | ("curl -s " ^ url ^ " > " ^ outputFile) 14 | then () 15 | else raise HttpException "download fail (retrieve)" 16 | 17 | fun retrieveLines url = 18 | FSUtil.systemLines ("curl -s " ^ url) 19 | handle _ => raise HttpException "download fail (retrieveText)" 20 | 21 | fun retrieveCleanLines url = 22 | FSUtil.systemLines ("curl -s " ^ url) 23 | handle _ => raise HttpException "download fail (retrieveText)" 24 | end 25 | 26 | -------------------------------------------------------------------------------- /src/fsutil.smi: -------------------------------------------------------------------------------- 1 | _require "basis.smi" 2 | structure FSUtil = 3 | struct 4 | (* Write a series of lines to a file. Adds a newline to every string. *) 5 | val putLines: string -> string list -> unit 6 | 7 | (* ...Lines: Get the raw list of lines. *) 8 | (* ...CleanLines: Also trim leading whitespace, newlines, #comments. *) 9 | (* ...Stanzas: Also split up into empty-line separated segments. *) 10 | 11 | (* Read from a TextIO stream. *) 12 | val getLines: TextIO.instream -> string list 13 | val getCleanLines: TextIO.instream -> string list 14 | val getStanzas: TextIO.instream -> string list list 15 | 16 | (* Read from a system call. *) 17 | val systemLines: string -> string list 18 | val systemCleanLines: string -> string list 19 | val systemStanzas: string -> string list list 20 | end 21 | -------------------------------------------------------------------------------- /src/fsutil.sml: -------------------------------------------------------------------------------- 1 | structure FSUtil:> 2 | sig 3 | (* Write a series of lines to a file. Adds a newline to every string. *) 4 | val putLines: string -> string list -> unit 5 | 6 | (* ...Lines: Get the raw list of lines. *) 7 | (* ...CleanLines: Also trim leading whitespace, newlines, #comments. *) 8 | (* ...Stanzas: Also split up into empty-line separated segments. *) 9 | 10 | (* Read from a TextIO stream. *) 11 | val getLines: TextIO.instream -> string list 12 | val getCleanLines: TextIO.instream -> string list 13 | val getStanzas: TextIO.instream -> string list list 14 | 15 | (* Read from a system call. *) 16 | val systemLines: string -> string list 17 | val systemCleanLines: string -> string list 18 | val systemStanzas: string -> string list list 19 | end = 20 | struct 21 | fun putLines fileName lines = 22 | let 23 | val file = TextIO.openOut fileName 24 | fun loop lines = 25 | case lines of 26 | [] => TextIO.closeOut file 27 | | line :: lines => 28 | (TextIO.output (file, line ^ "\n"); loop lines) 29 | in 30 | loop lines 31 | handle exn => (TextIO.closeOut file handle _ => (); raise exn) 32 | end 33 | 34 | fun trim s = 35 | let 36 | fun trimStart (#" "::t) = trimStart t 37 | | trimStart (#"\t"::t) = trimStart t 38 | | trimStart l = l 39 | 40 | fun trimEnd (#"#"::t) accum = rev accum 41 | | trimEnd (#"\n"::t) accum = rev accum 42 | | trimEnd (h::t) accum = trimEnd t (h :: accum) 43 | | trimEnd [] accum = rev accum 44 | in 45 | String.implode (trimEnd (trimStart (String.explode s)) []) 46 | end 47 | 48 | fun getLines' trimmer splitter file = 49 | let 50 | fun loop accum stanzas = 51 | case TextIO.inputLine file of 52 | NONE => 53 | if null accum 54 | then (rev stanzas before TextIO.closeIn file) 55 | else (rev (rev accum :: stanzas) before TextIO.closeIn file) 56 | | SOME s => 57 | if splitter s 58 | then (if null accum 59 | then loop accum stanzas 60 | else loop [] (rev accum :: stanzas)) 61 | else loop (trimmer s :: accum) stanzas 62 | in 63 | loop [] [] 64 | handle exn => (TextIO.closeIn file handle _ => (); raise exn) 65 | end 66 | 67 | fun isEmpty [] = true 68 | | isEmpty (c :: cs) = if Char.isSpace c then isEmpty cs else false 69 | 70 | val getLines = hd o getLines' (fn x => x) (fn _ => false) 71 | val getCleanLines = hd o getLines' trim (fn _ => false) 72 | val getStanzas = getLines' trim (null o (String.tokens Char.isSpace)) 73 | 74 | fun systemLines' reader cmd = 75 | let 76 | val tmpName = OS.FileSys.tmpName () 77 | val cmd' = (cmd ^ " > " ^ tmpName) 78 | (* val () = print ("Running: `" ^ cmd' ^ "`\n") *) 79 | val () = 80 | if OS.Process.isSuccess (OS.Process.system cmd') 81 | then () else raise Fail ("System call failed: `" ^ cmd' ^ "'") 82 | val cleanup = fn () => OS.FileSys.remove tmpName 83 | in 84 | (reader (TextIO.openIn tmpName) before cleanup ()) 85 | handle exn => (cleanup () handle _ => (); raise exn) 86 | end 87 | 88 | val systemLines = systemLines' getLines 89 | val systemCleanLines = systemLines' getCleanLines 90 | val systemStanzas = systemLines' getStanzas 91 | 92 | end 93 | -------------------------------------------------------------------------------- /src/get-git.smi: -------------------------------------------------------------------------------- 1 | _require "basis.smi" 2 | _require "semver.smi" 3 | _require "fsutil.smi" 4 | 5 | structure GetGit = 6 | struct 7 | val systemSuccess: string -> unit 8 | val poll: string -> (string * SemVer.semver) list 9 | val chdirSuccess: string -> unit 10 | val download: string -> unit 11 | val get:string -> string -> string -> SemVer.semver -> unit 12 | end 13 | 14 | -------------------------------------------------------------------------------- /src/get-git.sml: -------------------------------------------------------------------------------- 1 | (* Manipulating packages with git *) 2 | (* Try running 'GetGit.poll "https://github.com/robsimmons/toy.git"' *) 3 | (* Robert J. Simmons *) 4 | 5 | structure GetGit = struct 6 | 7 | fun systemSuccess s = 8 | let (* val () = print ("Running: `" ^ s ^ "'\n") *) in 9 | if OS.Process.isSuccess (OS.Process.system s) then () 10 | else raise Fail ("System call `" ^ s ^ "' returned failure") 11 | end 12 | 13 | (*[ val poll: string -> (string * SemVer.semver) list ]*) 14 | (* List of X.Y.Z versions provided by a repository *) 15 | fun poll (gitAddr: string) = 16 | let 17 | fun eq c1 c2 = c1 = c2 18 | val input = FSUtil.systemLines ("git ls-remote " ^ gitAddr) 19 | handle _ => raise Fail "I/O error trying to access temporary file" 20 | exception Error of string 21 | fun process str = 22 | let exception Skip 23 | val (hash, remote) = 24 | case String.tokens Char.isSpace str of 25 | [ hash, remote ] => 26 | if size hash <> 40 27 | then raise Error "Bad hash returned from git ls-remote" 28 | else if String.isSuffix "^{}" remote 29 | then raise Skip (* Proposed bugfix for git tag -m "" 30 | - Oct 24 2011 RJS *) 31 | else (hash, String.tokens (eq #"/") remote) 32 | | _ => raise Error "Unexpected output from `git ls-remote'" 33 | 34 | val tag = 35 | case remote of 36 | [ "refs", "tags", tag ] => 37 | if String.sub (tag, 0) = #"v" 38 | then String.extract (tag, 1, NONE) 39 | else raise SemVer.InvalidVersion (* Not a version tag *) 40 | | _ => raise SemVer.InvalidVersion (* Not a tag at all *) 41 | in 42 | SOME (hash, SemVer.fromString tag) 43 | end handle Error s => raise Fail s 44 | | _ => NONE 45 | in 46 | List.mapPartial process input 47 | end 48 | 49 | fun chdirSuccess s = 50 | let (* val () = print ("Changing directory: `" ^ s ^ "'\n") *) in 51 | OS.FileSys.chDir s 52 | end 53 | 54 | fun download gitAddr = 55 | ( OS.FileSys.mkDir ("unstable") 56 | ; chdirSuccess ("unstable") 57 | ; systemSuccess ("git init --quiet") 58 | ; systemSuccess ("git remote add origin " ^ gitAddr)) 59 | 60 | (*[ val get: string -> string -> SemVer.semver -> unit ]*) 61 | fun get basePath projName gitAddr semver = 62 | let val olddir = OS.FileSys.getDir () in 63 | let 64 | val projPath' = OS.Path.joinDirFile { dir = basePath, file = "lib" } 65 | val projPath = OS.Path.joinDirFile { dir = projPath', file = projName } 66 | val () = if OS.FileSys.isDir projPath then () 67 | else raise Fail ("file `" ^ projName 68 | ^ "' exists and isn't a directory") 69 | val () = chdirSuccess projPath 70 | 71 | (* Get the repository in place if it's not there *) 72 | val repoPath = OS.Path.joinDirFile { dir = projPath, file = "unstable" } 73 | val () = if OS.FileSys.access (repoPath, []) 74 | then (if OS.FileSys.isDir repoPath then () 75 | else raise Fail "file `unstable' exists and isn't\ 76 | \ a directory") 77 | else download gitAddr 78 | 79 | (* Update the repository *) 80 | val () = chdirSuccess repoPath 81 | val () = systemSuccess ("git fetch origin master --tags --quiet") 82 | val () = print "Repository is updated\n" 83 | 84 | (* Output via cloning *) 85 | val ver = "v" ^ SemVer.toString semver 86 | val verPath = OS.Path.joinDirFile { dir = projPath, file = ver } 87 | val () = chdirSuccess verPath 88 | val () = systemSuccess ("git init --quiet") 89 | val () = systemSuccess ("git remote add origin " ^ (OS.Path.joinDirFile { dir = "..", file = "unstable" })) 90 | val () = systemSuccess ("git fetch --tags --quiet") 91 | val () = systemSuccess ("git checkout " ^ ver ^ " --quiet") 92 | 93 | (* Clean up *) 94 | val () = systemSuccess ( "rm -Rf .git" ) 95 | in 96 | chdirSuccess olddir 97 | end handle exn => (OS.FileSys.chDir olddir; raise exn) end 98 | end 99 | -------------------------------------------------------------------------------- /src/go-nj-nonposix.sml: -------------------------------------------------------------------------------- 1 | CM.make "smack-nonposix.cm"; 2 | SMLofNJ.exportFn ("bin/.heapimg", Smack.main); 3 | -------------------------------------------------------------------------------- /src/go-nj.sml: -------------------------------------------------------------------------------- 1 | CM.make "smack.cm"; 2 | SMLofNJ.exportFn ("bin/.heapimg", Smack.main); 3 | -------------------------------------------------------------------------------- /src/go.smi: -------------------------------------------------------------------------------- 1 | _require "basis.smi" 2 | _require "main.smi" 3 | -------------------------------------------------------------------------------- /src/go.sml: -------------------------------------------------------------------------------- 1 | val () = OS.Process.exit(Smack.main(CommandLine.name (), CommandLine.arguments ())) 2 | -------------------------------------------------------------------------------- /src/http-downloader.sig: -------------------------------------------------------------------------------- 1 | signature HTTP_DOWNLOADER = 2 | sig 3 | exception HttpException of string 4 | type url = string 5 | type filename = string 6 | 7 | val retrieve : url -> filename -> unit 8 | val retrieveLines : url -> string list 9 | val retrieveCleanLines : url -> string list 10 | end 11 | -------------------------------------------------------------------------------- /src/install.smi: -------------------------------------------------------------------------------- 1 | _require "basis.smi" 2 | _require "spec.smi" 3 | 4 | structure Install = 5 | struct 6 | exception InstallError of string 7 | 8 | (* These will fail silently if the package is not buildable 9 | or not installable, so it is safe to always call them. *) 10 | val build : (string * string list) -> Spec.spec -> unit 11 | val install : (string * string list) -> Spec.spec -> unit 12 | end 13 | -------------------------------------------------------------------------------- /src/install.sml: -------------------------------------------------------------------------------- 1 | signature INSTALL = 2 | sig 3 | exception InstallError of string 4 | 5 | (* These will fail silently if the package is not buildable 6 | or not installable, so it is safe to always call them. *) 7 | val build : (string * string list) -> Spec.spec -> unit 8 | val install : (string * string list) -> Spec.spec -> unit 9 | end 10 | 11 | (* The Install module is aware of platform-specific build and install specs *) 12 | structure Install : INSTALL = 13 | struct 14 | exception InstallError of string 15 | 16 | (* Platform is either of the form *, + or . 17 | the 'platform' argument is from a spec file, i.e., a 18 | platform: declaration. 19 | 20 | The 'compiler' line is a compiler we have (from config) that we would 21 | like to try to use to run this software. Therefore for a given compiler 22 | (e.g. 'mlton'), we check whether our current Configure.platform value, 23 | plus the spec platform we are currently are considering are compatible 24 | e.g., if we are on osx, then we need to find a platform spec like: 25 | osx+mlton, or 'mlton', or '*'. 26 | 27 | isSupported returns true if the given spec is such a spec. 28 | *) 29 | fun isSupported hostos compiler platform = 30 | let 31 | 32 | val f = String.fields (fn #"+" => true | _ => false) platform 33 | val (os,comp) = 34 | case f of ["*"] => (NONE,NONE) 35 | | [c] => (NONE,SOME c) 36 | | [os,c] => (SOME os, SOME c) 37 | | _ => raise 38 | Fail ("Invalid platform spec: `" ^ platform ^ "'") 39 | val os_supp = os = NONE orelse valOf os = hostos 40 | val comp_supp = comp = NONE orelse valOf comp = compiler 41 | in 42 | os_supp andalso comp_supp 43 | end 44 | 45 | (* Which platforms can we use to install/build this package? *) 46 | fun selectPlatforms (hostos,compilers) spec = 47 | let 48 | val platforms = 49 | List.foldr (op @) [] 50 | (List.map (fn x => List.filter (fn (y,_) => isSupported hostos y x) 51 | (Spec.platforms spec)) 52 | (compilers)) 53 | 54 | val _ = 55 | if length (Spec.platforms spec) > 0 andalso length platforms = 0 56 | then 57 | TextIO.output (TextIO.stdErr, 58 | "WARNING: the package you are installing does not have " ^ 59 | "an appropriate `platform:' section for your current " ^ 60 | "compiler/platform combination. Consider adjusting your " ^ 61 | "configuration settings in $SMACKAGE_HOME/config.\n" ^ 62 | "WARNING: Package will be downloaded but not installed\n") 63 | else () 64 | in 65 | platforms 66 | end 67 | 68 | (* We must already be in the working directory of the package version. 69 | 70 | Fails silently if this is not a platform with 'key:'. 71 | *) 72 | fun runHook key (hostos,compilers) spec = 73 | case selectPlatforms (hostos,compilers) spec of 74 | [] => () 75 | | ((platform,platSpec)::_) => 76 | let 77 | val cmd = Spec.key platSpec key 78 | (* TODO: Do some simple macro expansion here. 79 | e.g.: $(MLTON) -> absolute path to MLton 80 | $(SMLNJ) -> path to SMLNJ 81 | $(PLATFORM) -> selected platform 82 | $(SMACKAGE_HOME) -> smackage_home 83 | $(BIN) -> smackage binary path 84 | $(LIB) -> smackage library path? 85 | etc etc. 86 | *) 87 | val cmd' = String.concat cmd 88 | val _ = print ("NOTICE: selected platform `" ^ platform ^ "'\n") 89 | val _ = print (key ^ ": " ^ cmd' ^ "\n") 90 | in 91 | if OS.Process.isSuccess (OS.Process.system cmd') then () 92 | else raise InstallError ("Hook `"^key^"' failed.") 93 | end handle (Spec.SpecError e) => () 94 | 95 | val build = runHook "build" 96 | val install = runHook "install" 97 | end 98 | -------------------------------------------------------------------------------- /src/main.smi: -------------------------------------------------------------------------------- 1 | _require "basis.smi" 2 | _require "spec.smi" 3 | _require "protocol.smi" 4 | _require "version.smi" 5 | _require "semver.smi" 6 | _require "fsutil.smi" 7 | _require "version-index.smi" 8 | _require "smacklib.smi" 9 | _require "conductor.smi" 10 | _require "smackage-path.smi" 11 | _require "configure.smi" 12 | 13 | structure Smack = 14 | struct 15 | exception SmackExn of string 16 | exception ArgsError of string * string 17 | val main: string * string list -> int 18 | end 19 | 20 | 21 | -------------------------------------------------------------------------------- /src/main.sml: -------------------------------------------------------------------------------- 1 | structure Smack = 2 | struct 3 | exception SmackExn of string 4 | 5 | infix 5 // 6 | fun (dir // file) = OS.Path.joinDirFile { dir = dir, file = file } 7 | 8 | type packages = unit SemConstrDict.dict StringDict.dict 9 | 10 | fun addPackage (dict: packages) pkg semconstr = 11 | StringDict.insertMerge dict pkg 12 | (SemConstrDict.singleton semconstr ()) 13 | (fn dict => SemConstrDict.insert dict semconstr ()) 14 | 15 | fun readPackagesInstalled (): packages = 16 | let 17 | val packagesInstalled = 18 | OS.Path.joinDirFile { dir = !Configure.smackHome 19 | , file = "packages.installed"} 20 | fun folder (line, dict) = 21 | case String.tokens Char.isSpace line of 22 | [] => dict 23 | | [ pkg, semconstr ] => 24 | addPackage dict pkg (SemVer.constrFromString semconstr) 25 | | _ => raise Fail ( "Bad package line: `" ^ line ^ "'") 26 | in 27 | List.foldr folder StringDict.empty 28 | (FSUtil.getCleanLines (TextIO.openIn packagesInstalled)) 29 | end 30 | 31 | fun writePackagesInstalled (dict: packages) = 32 | let 33 | val packagesInstalled = 34 | OS.Path.joinDirFile { dir = !Configure.smackHome 35 | , file = "packages.installed"} 36 | fun mapper (pkg, semconstrs) = 37 | map (fn (sc, ()) => pkg ^ " " ^ SemVer.constrToString sc) 38 | (SemConstrDict.toList semconstrs) 39 | in 40 | FSUtil.putLines packagesInstalled 41 | ( "# This file was automatically generated by smackage." 42 | :: "# It holds every package explicitly installed by the user with a" 43 | :: "# `smackage install' command, and determines which packages are" 44 | :: "# accessed and directly updated by `smackage update'." 45 | :: "" 46 | :: List.concat (map mapper (StringDict.toList dict))) 47 | end 48 | 49 | 50 | (** Resolve the dependencies of a particular, newly-downloaded package. *) 51 | fun resolveDependencies pkg ver = 52 | let exception NoDeps in let 53 | val specFile = 54 | !Configure.smackHome // "lib" // pkg // ("v" ^ SemVer.toString ver) 55 | // (pkg ^ ".smackspec") 56 | val () = if OS.FileSys.access (specFile, []) then () else raise NoDeps 57 | 58 | val deps = Spec.requires (Spec.fromFile specFile) 59 | val ltoi = Int.toString o length 60 | in 61 | ( if null deps then raise NoDeps else () 62 | ; if length deps = 1 then print "Resolving 1 dependency\n" 63 | else print ("Resolving " ^ ltoi deps ^ " dependencies\n") 64 | (* XXX here's the place to shortcut-stop if we have an acceptable 65 | * version installed (issue #4) *) 66 | ; app (fn (pkg, spec, _) => 67 | ignore (get false false pkg (SOME spec))) deps 68 | ; print ("Done resolving dependencies for `" ^ pkg ^ "'\n")) 69 | end handle NoDeps => () end 70 | 71 | (** Obtain a package with a given name and version specification. 72 | NONE means "the latest version." Specifications are handled by 73 | SemVer.intelligentSelect. 74 | 75 | Raises SmackExn in the event that no acceptable version of the package 76 | is available. 77 | 78 | silentMode tells 'get' to not report what it is doing assuming 79 | everything is going well. This allows us to have 'refresh' 80 | not output confusing messages about selecting smackage versions. 81 | 82 | *) 83 | and get silentMode isTopLevel pkg specStr = 84 | let 85 | fun maybePrint s = if silentMode then () else print s 86 | 87 | val () = 88 | if VersionIndex.isKnown pkg then () 89 | else raise SmackExn 90 | ( "I don't know about the package `" ^ pkg 91 | ^ "', run `smackage refresh'?") 92 | 93 | val (spec, ver) = 94 | VersionIndex.getBest pkg specStr 95 | handle _ => 96 | raise SmackExn 97 | ("No acceptable version of `" ^ pkg 98 | ^ (case specStr of 99 | NONE => "" 100 | | SOME s => " " ^ SemVer.constrToString s) 101 | ^ "' found, try `smackage refresh'?") 102 | 103 | val () = 104 | if not isTopLevel then () 105 | else writePackagesInstalled 106 | (addPackage (readPackagesInstalled ()) pkg spec) 107 | 108 | val name = pkg ^ " " ^ SemVer.toString ver 109 | val () = 110 | if Option.isSome specStr then () 111 | else print ( "No major version specified, picked v" 112 | ^ SemVer.constrToString spec ^ ".\n") 113 | val () = maybePrint ( "Selected `" ^ name ^ "'.\n") 114 | 115 | val proto = 116 | case VersionIndex.getProtocol pkg ver of 117 | SOME p => p 118 | | NONE => raise SmackExn 119 | ("Installation method for `" ^ name ^ "' not found") 120 | in 121 | ( if SmackLib.download (!Configure.smackHome) (pkg,ver,proto) 122 | then maybePrint ( "Package `" ^ name ^ "' already installed.\n") 123 | else ( maybePrint ( "Package `" ^ name ^ "' downloaded.\n") 124 | ; resolveDependencies pkg ver (* 125 | ; (if runHooks then 126 | (SmackLib.build 127 | (!Configure.smackHome) 128 | (!Configure.platform,!Configure.compilers) 129 | (pkg,ver) 130 | ; SmackLib.install 131 | (!Configure.smackHome) 132 | (!Configure.platform,!Configure.compilers) 133 | (pkg,ver)) else ()) 134 | *)) 135 | ; OS.Process.success) 136 | end 137 | 138 | (** List the packages currently installed. *) 139 | fun listInstalled () = 140 | let 141 | val libRoot = !Configure.smackHome // "lib" 142 | fun printver ver = 143 | print (" Version: " ^ SemVer.toString ver ^ "\n") 144 | fun read dir = 145 | case OS.FileSys.readDir dir of 146 | NONE => OS.FileSys.closeDir dir 147 | | SOME pkg => 148 | ( print ("Package " ^ pkg ^ ":") 149 | ; case SmackLib.versions (!Configure.smackHome) pkg of 150 | [] => print " (no versions installed)\n" 151 | | vers => (print "\n"; app printver vers) 152 | ; read dir) 153 | in 154 | if OS.FileSys.access (libRoot, []) 155 | then read (OS.FileSys.openDir libRoot) 156 | else () 157 | end 158 | 159 | 160 | (** Search for a package in the index, with an optional version. 161 | FIXME: currently ignoring version. 162 | *) 163 | fun search name version = 164 | let 165 | val _ = VersionIndex.init (!Configure.smackHome) 166 | val res = VersionIndex.search name 167 | val _ = if length res = 0 then print "No packages found.\n" else () 168 | val _ = List.app 169 | (fn (n,dict) => 170 | SemVerDict.app 171 | (fn (v, p) => 172 | print (n ^ " " ^ SemVer.toString v ^ " (from " ^ 173 | Protocol.toString p ^ ")\n")) dict) res 174 | in 175 | () 176 | end 177 | 178 | (** Display metadata for a given package, plus installed status. 179 | FIXME: Doesn't really do this, but displaying all versions is a start. 180 | *) 181 | fun info name version = 182 | let 183 | val _ = print "Candidates:\n" 184 | val candidates = VersionIndex.getAll name NONE 185 | val _ = List.app 186 | (fn v => 187 | let 188 | val _ = print (name ^ " " ^ SemVer.toString v) 189 | val s = SOME (SmackagePath.packageMetadata 190 | (!Configure.smackHome) (name,v)) 191 | handle (Spec.SpecError s) => 192 | (print ("Spec Error: " ^ s ^ "\n"); NONE) 193 | | (SmackagePath.Metadata s) => NONE 194 | 195 | val _ = case s of NONE => print "\n\n" 196 | | SOME sp => 197 | print (" (installed)\n\n" ^ 198 | Spec.toString sp ^ "\n") 199 | in () end) candidates 200 | in 201 | () 202 | end 203 | 204 | (** Ouput a path for a given package, for integration with smbt. 205 | It is important for smbt's purposes that indicative status 206 | codes are returned, so we return OS.Process.success 207 | or OS.Process.failure here. **) 208 | fun pathinfo pkg spec = 209 | let 210 | val ver = SemVer.constrFromString spec 211 | val (spec, semver) = 212 | case SemVer.intelligentSelect (SOME ver) 213 | (SmackLib.versions (!Configure.smackHome) pkg) of 214 | NONE => 215 | raise SmackExn 216 | ("No acceptable version of `" ^ pkg 217 | ^ (SemVer.constrToString ver) 218 | ^ "' around, try getting one with `smackage get'?") 219 | | SOME (spec, semver) => (spec, semver) 220 | 221 | val specStr = "v" ^ SemVer.toString semver 222 | 223 | val path = (!Configure.smackHome // "lib" // pkg // specStr) 224 | 225 | in 226 | if OS.FileSys.access (path, []) then 227 | (print (path ^ "\n"); OS.Process.success) 228 | else 229 | (print ("Smackage: No acceptable version of `" ^ pkg ^ "\n"); OS.Process.failure) 230 | end 231 | 232 | fun update () = 233 | let 234 | val pkgs = readPackagesInstalled () 235 | 236 | fun update1 (pkg, vers) = 237 | SemConstrDict.app 238 | (fn (semconst, _) => ignore (get false false pkg (SOME semconst))) 239 | vers 240 | 241 | fun reportBest (pkg, _) = 242 | let 243 | val (_, semver) = VersionIndex.getBest pkg NONE 244 | in 245 | if SmackLib.exists (!Configure.smackHome) (pkg, semver) then () 246 | else print ("NOTICE: `" ^ pkg ^ " v" ^ SemVer.toString semver 247 | ^ "' is available, run `smackage get " 248 | ^ pkg ^ "' to get it.\n") 249 | end 250 | in 251 | ( if not (StringDict.isEmpty pkgs) then () 252 | else print "Nothing to update!\nPerhaps you should use\ 253 | \ `smackage get ' to get something first?\n" 254 | ; StringDict.app update1 pkgs 255 | ; StringDict.app reportBest pkgs 256 | ; OS.Process.success) 257 | end 258 | 259 | fun readSourcesLocal () = 260 | let 261 | val sourcesLocal = 262 | OS.Path.joinDirFile { dir = !Configure.smackHome 263 | , file = "sources.local"} 264 | fun folder (line, dict) = 265 | case String.tokens Char.isSpace line of 266 | [] => dict 267 | | [ pkg', prot', uri' ] => 268 | StringDict.insert dict pkg' 269 | (Protocol.fromString (prot' ^ " " ^ uri')) 270 | | _ => raise Fail ( "Bad source line: `" ^ line ^ "'") 271 | in 272 | List.foldr folder StringDict.empty 273 | (FSUtil.getCleanLines (TextIO.openIn sourcesLocal)) 274 | end 275 | 276 | fun writeSourcesLocal dict = 277 | let 278 | val sourcesLocal = 279 | OS.Path.joinDirFile { dir = !Configure.smackHome 280 | , file = "sources.local"} 281 | in 282 | FSUtil.putLines sourcesLocal 283 | ( "# This file was automatically generated by smackage." 284 | :: "# You can edit it directly or edit it with the smackage tool:" 285 | :: "# `smackage source ' adds a source, and" 286 | :: "# `smackage unsource ' removes a source." 287 | :: "" 288 | :: map (fn (source, prot) => source ^ " " ^ Protocol.toString prot) 289 | (StringDict.toList dict)) 290 | end 291 | 292 | 293 | fun runCmd pkg spec args = 294 | let 295 | val oldDir = OS.FileSys.getDir () 296 | val (spec, semver) = 297 | case SemVer.intelligentSelect spec 298 | (SmackLib.versions (!Configure.smackHome) pkg) of 299 | NONE => 300 | raise SmackExn 301 | ("No acceptable version of `" ^ pkg 302 | ^ (case spec of 303 | NONE => "" 304 | | SOME s => " " ^ SemVer.constrToString s) 305 | ^ "' around, try getting one with `smackage get'?") 306 | | SOME (spec, semver) => (spec, semver) 307 | val specStr = "v" ^ SemVer.toString semver 308 | val cmd = String.concatWith " " args 309 | in 310 | ( OS.FileSys.chDir (!Configure.smackHome // "lib" // pkg // specStr) 311 | ; print ("In directory: `" ^ OS.FileSys.getDir () ^ "'\n") 312 | ; print ("smackage is preparing to run `" ^ cmd ^ "'\n") 313 | ; OS.Process.system cmd 314 | ; OS.FileSys.chDir oldDir 315 | ; OS.Process.success) 316 | handle exn => (OS.FileSys.chDir oldDir; raise exn) 317 | end 318 | 319 | (* Referesh the versions.smackspec file based one existing sources. *) 320 | fun refresh warn = 321 | let val oldDir = OS.FileSys.getDir () in 322 | let 323 | val () = OS.FileSys.chDir (!Configure.smackHome) 324 | 325 | val versionSpackspec = "versions.smackspec" 326 | val output = TextIO.openOut versionSpackspec 327 | 328 | fun emit s = TextIO.output (output, s) 329 | 330 | fun poll line = 331 | let in 332 | case String.tokens Char.isSpace line of 333 | [] => () 334 | | [ pkg', prot', uri' ] => 335 | app (fn spec => emit (Spec.toString spec ^ "\n\n")) 336 | (Conductor.poll pkg' 337 | (Protocol.fromString (prot' ^ " " ^ uri'))) 338 | | _ => raise Fail ( "Bad source line: `" ^ line ^ "'") 339 | end 340 | handle exn => 341 | print ("WARNING: When trying to pull source `" ^ line 342 | ^ "', got the following error \n\t\"" 343 | ^ exnMessage exn 344 | ^ "\"\nIf this line is in sources.local, you may need to run\n\ 345 | \`smackage unsource' to remove it.\n") 346 | 347 | fun dofile fileName = 348 | app poll (FSUtil.getCleanLines (TextIO.openIn fileName)) 349 | handle _ => if not warn then () 350 | else print ("WARNING: error reading " ^ fileName ^ "\n") 351 | in 352 | ( app dofile (!Configure.smackSources @ [ "sources.local" ]) 353 | ; TextIO.closeOut output 354 | ; OS.FileSys.chDir oldDir 355 | ; VersionIndex.init (!Configure.smackHome)) 356 | end handle exn => (OS.FileSys.chDir oldDir; raise exn) end 357 | 358 | (* We should think about whether there's a better way to distributed 359 | the "blessed" sources list to separate "selfupdate" from 360 | "refresh." As it is, I can't really figure out a less-wasteful way 361 | to do a "total" refresh than to re-download smackage's sources. *) 362 | fun selfupdate () = 363 | ( refresh false 364 | ; ignore (get true false "smackage" (SOME (SemVer.constrFromString "v1"))) 365 | ; refresh true 366 | ; OS.Process.success) 367 | 368 | 369 | (* Manipulate the sources.local source spec file *) 370 | fun source pkg prot = 371 | let 372 | val dict = readSourcesLocal () 373 | val dict' = StringDict.insert dict pkg prot 374 | in 375 | ( case StringDict.find dict pkg of 376 | NONE => () 377 | | SOME prot' => 378 | if EQUAL = Protocol.compare (prot, prot') then () 379 | else print ( "WARNING: overwriting source spec\nOLD: " 380 | ^ pkg ^ " " ^ Protocol.toString prot' ^ "\nNEW: " 381 | ^ pkg ^ " " ^ Protocol.toString prot ^ "\n") 382 | ; writeSourcesLocal dict' 383 | ; OS.Process.success) 384 | end 385 | 386 | (* Manipulate the sources.local source spec file *) 387 | fun unsource pkg = 388 | let 389 | val dict = readSourcesLocal () 390 | val dict' = StringDict.remove dict pkg 391 | in 392 | ( case StringDict.find dict pkg of 393 | NONE => print ("WARNING: Package `" ^ pkg ^ "' not in sources.local.") 394 | | SOME prot' => () 395 | ; writeSourcesLocal dict' 396 | ; OS.Process.success) 397 | end 398 | 399 | val usage = 400 | "Smackage " ^ Version.version ^ "\n" ^ 401 | "Usage: smackage [args]\n\ 402 | \Commands, with and [optional] arguments:\n\ 403 | \\texec [version] \tRuns `cmd ...' in the specified\n\ 404 | \\t\t\t\t\tpackage's directory\n\ 405 | \\tget [version]\t\tObtain the named package\n\ 406 | \\thelp\t\t\t\tDisplay this usage and exit\n\ 407 | \\tinfo [version]\t\tDisplay package information.\n\ 408 | \\tlist\t\t\t\tList installed packages\n\ 409 | \\tmake [version] [args...]\tRuns `make [args ...]' in the\n\ 410 | \\t\t\t\t\tspecified package's directory\n\ 411 | \\tpathinfo \tOutputs 's filesystem path\n\ 412 | \\trefresh\t\t\t\tRefresh the package index\n\ 413 | \\tsearch \t\t\tFind an appropriate package\n\ 414 | \\tsource \tAdd a smackage source to sources.local\n\ 415 | \\tupdate \t\t\t\tUpdate all packages\n\ 416 | \\tunsource \t\t\tRemove a source from sources.local\n" 417 | 418 | exception ArgsError of string * string 419 | fun main (name, args) = 420 | let 421 | val () = Configure.init () 422 | fun runCmdNotMake pkg spec rest = 423 | let 424 | fun confirm () = 425 | let 426 | val () = print ("Are you sure you want to proceed? [Y/n]: ") 427 | val () = TextIO.flushOut TextIO.stdOut 428 | in case String.tokens Char.isSpace 429 | (valOf (TextIO.inputLine TextIO.stdIn)) of 430 | [] => () 431 | | (str :: _) => 432 | if String.isPrefix "y" str 433 | orelse String.isPrefix "Y" str 434 | then () 435 | else if String.isPrefix "n" str 436 | orelse String.isPrefix "N" str 437 | then raise SmackExn "User cancelled command" 438 | else (print "I don't understand that.\n"; confirm ()) 439 | end 440 | in 441 | ( if "make" = hd rest 442 | then ( print ("WARNING: It is suggested that you run\n\ 443 | \`" ^ CommandLine.name () ^ " make " 444 | ^ String.concatWith " " (pkg :: tl rest) 445 | ^ "'\nrather than invoking make with `" 446 | ^ CommandLine.name () ^ " exec'.\n") 447 | ; confirm ()) 448 | else () 449 | ; runCmd pkg spec rest) 450 | handle Option => raise SmackExn "User cancelled command" 451 | end 452 | in 453 | case args of 454 | [] => (print usage; OS.Process.success) 455 | | ("--help"::_) => (print usage; OS.Process.success) 456 | | ("-h"::_) => (print usage; OS.Process.success) 457 | | ("help"::_) => (print usage; OS.Process.success) 458 | 459 | | ["exec", pkg, cmd] => runCmdNotMake pkg NONE [ cmd ] 460 | | ("exec" :: pkg :: maybe_spec :: rest) => 461 | let 462 | val (spec, rest) = 463 | (SOME (SemVer.constrFromString maybe_spec), rest) 464 | handle _ => (NONE, maybe_spec :: rest) 465 | in runCmdNotMake pkg spec rest 466 | end 467 | | ("exec" :: _) => 468 | raise ArgsError ("exec", "requires at least two arguments") 469 | 470 | | ["get",pkg] => get false true pkg NONE 471 | | ["get",pkg,ver] => 472 | get false true pkg (SOME (SemVer.constrFromString ver)) 473 | | ("get" :: _) => 474 | raise ArgsError ("get", "requires one or two arguments") 475 | 476 | | ["info",pkg] => (info pkg ""; OS.Process.success) 477 | | ["info",pkg,ver] => (info pkg ver; OS.Process.success) 478 | | ("info" :: _) => 479 | raise ArgsError ("info", "requires one or two arguments") 480 | 481 | | ("install" :: args) => 482 | raise ArgsError ("install", "not a command\n\ 483 | \Did you want to run `" ^ CommandLine.name () ^ " get " 484 | ^ String.concatWith " " args ^ "'?") 485 | 486 | | ["list"] => (listInstalled(); OS.Process.success) 487 | | ("list" :: _) => 488 | raise ArgsError ("list", "does not expect arguments") 489 | 490 | | ["pathinfo"] => 491 | raise ArgsError ("pathinfo", "requires two arguments") 492 | | ["pathinfo",pkg,ver] => pathinfo pkg ver 493 | 494 | | ["make"] => raise ArgsError ("make", "requires arguments") 495 | | ["make", pkg] => 496 | runCmd pkg NONE [ "make", "DESTDIR=" ^ !Configure.smackHome] 497 | | ("make" :: pkg :: maybe_spec :: rest) => 498 | let 499 | val (spec, rest) = 500 | (SOME (SemVer.constrFromString maybe_spec), rest) 501 | handle _ => (NONE, maybe_spec :: rest) 502 | in 503 | runCmd pkg spec 504 | ("make" :: "DESTDIR=" ^ !Configure.smackHome :: rest) 505 | end 506 | 507 | | ["refresh"] => selfupdate () 508 | | ("refresh" :: _) => 509 | raise ArgsError ("refresh", "does not expect arguments") 510 | 511 | | ["search",pkg] => (search pkg ""; OS.Process.success) 512 | | ["search",pkg,ver] => (search pkg ver; OS.Process.success) 513 | | ("search" :: _) => 514 | raise ArgsError ("search", "expects one or two arguments") 515 | 516 | | ["source",pkg,prot,url] => 517 | source pkg (Protocol.fromString (prot ^ " " ^ url)) 518 | | ("source" :: _) => 519 | raise ArgsError ("source", "expects exactly three arguments") 520 | 521 | | ["update"] => update () 522 | | ("update" :: args) => 523 | raise ArgsError ("update", "does not expect arguments\n\ 524 | \Did you want to run `" ^ CommandLine.name () ^ " get " 525 | ^ String.concatWith " " args ^ "'?") 526 | 527 | | ["unsource",pkg] => unsource pkg 528 | | ("unsource" :: _) => 529 | raise ArgsError ("unsource", "expectes exactly one argument") 530 | 531 | | (str :: _) => raise ArgsError (str, "is an unknown command") 532 | end handle 533 | (SmackExn s) => 534 | ( TextIO.output (TextIO.stdErr, "\nERROR: " ^ s ^ "\n\n") 535 | ; OS.Process.failure) 536 | | (Fail s) => 537 | ( TextIO.output (TextIO.stdErr, "\nERROR: " ^ s ^ "\n\n") 538 | ; OS.Process.failure) 539 | | (Spec.SpecError s) => 540 | ( TextIO.output (TextIO.stdErr, "\nERROR: " ^ s ^ "\n\n") 541 | ; OS.Process.failure) 542 | | (ArgsError (cmd, s)) => 543 | ( TextIO.output (TextIO.stdErr, "\nERROR: `" 544 | ^ CommandLine.name () 545 | ^ " " ^ cmd ^ "' " ^ s ^ "\n\n") 546 | ; print usage 547 | ; OS.Process.failure) 548 | | exn => 549 | ( TextIO.output (TextIO.stdErr, "\nUNEXPECTED ERROR: " 550 | ^ exnMessage exn ^ "\n\n") 551 | ; OS.Process.failure) 552 | end 553 | 554 | 555 | -------------------------------------------------------------------------------- /src/poly_build.sml: -------------------------------------------------------------------------------- 1 | use "src/poly_mlyacc.sml"; 2 | use "src/poly_smlnj-lib.sml"; 3 | use "src/posix-symlink.sml"; 4 | use "src/semver.sml"; 5 | use "src/protocol.sml"; 6 | use "util/sort.sml"; 7 | use "util/dict.sig"; 8 | use "util/dict-list.sml"; 9 | use "src/fsutil.sml"; 10 | use "src/version.sml"; 11 | use "src/spec.sml"; 12 | use "src/version-index.sml"; 13 | use "src/get-git.sml"; 14 | use "src/get-http.sml"; 15 | use "src/install.sml"; 16 | use "src/conductor.sig"; 17 | use "src/conductor.sml"; 18 | use "src/smackage-path.sml"; 19 | use "src/smacklib.sml"; 20 | use "src/configure.sml"; 21 | use "src/main.sml"; 22 | fun polyMain () = OS.Process.exit(Smack.main(CommandLine.name (), CommandLine.arguments ())); 23 | PolyML.export ("bin/polyml-smackage", polyMain); 24 | -------------------------------------------------------------------------------- /src/poly_mlyacc.sml: -------------------------------------------------------------------------------- 1 | (* Taken from http://www.tbrk.org/software/poly_smlnj-lib.html for use in 2 | smackage *) 3 | local 4 | val root = "/usr/local/lib/mlton/sml" 5 | val mlyacc = [ 6 | "base.sig", 7 | "join.sml", 8 | "lrtable.sml", 9 | "stream.sml", 10 | "parser2.sml", 11 | ""] 12 | in 13 | val _ = List.app (fn"" => () | s => use(root^"/mlyacc-lib/"^s)) mlyacc 14 | end; 15 | -------------------------------------------------------------------------------- /src/poly_smlnj-lib.sml: -------------------------------------------------------------------------------- 1 | (* Taken from http://www.tbrk.org/software/poly_smlnj-lib.html for use in 2 | smackage *) 3 | structure Word31 = Word; 4 | structure Int32 = Int; 5 | structure Unsafe = struct 6 | structure CharVector = CharVector 7 | structure Array = Array 8 | structure Vector = Vector 9 | structure Word8Array = 10 | struct 11 | open Word8Array 12 | fun create length = array(length, 0w0) 13 | end 14 | end; 15 | local 16 | val root = "/usr/local/lib/mlton/sml" 17 | 18 | val util = [ 19 | "ord-key-sig.sml", 20 | "ord-set-sig.sml", 21 | "lib-base-sig.sml", 22 | "lib-base.sml", 23 | "list-set-fn.sml", 24 | "ord-map-sig.sml", 25 | "list-map-fn.sml", 26 | "int-binary-set.sml", 27 | "int-binary-map.sml", 28 | "prime-sizes.sml", 29 | "dynamic-array-sig.sml", 30 | "dynamic-array.sml", 31 | "io-util-sig.sml", 32 | "splaytree-sig.sml", 33 | "splaytree.sml", 34 | "splay-set-fn.sml", 35 | "splay-map-fn.sml", 36 | "ansi-term.sml", 37 | "io-util.sml", 38 | "plist-sig.sml", 39 | "getopt-sig.sml", 40 | "getopt.sml", 41 | "interval-domain-sig.sml", 42 | "interval-set-sig.sml", 43 | "parser-comb-sig.sml", 44 | "atom-sig.sml", 45 | "hash-string.sml", 46 | "atom.sml", 47 | "format-sig.sml", 48 | "real-format.sml", 49 | "fmt-fields.sml", 50 | "format.sml", 51 | "priority-sig.sml", 52 | "hash-key-sig.sml", 53 | "mono-hash-table-sig.sml", 54 | "hash-table-rep.sml", 55 | "int-hash-table.sml", 56 | "bit-array-sig.sml", 57 | "redblack-set-fn.sml", 58 | "atom-redblack-set.sml", 59 | "atom-set.sml", 60 | "redblack-map-fn.sml", 61 | "atom-redblack-map.sml", 62 | "atom-map.sml", 63 | "plist.sml", 64 | "char-map-sig.sml", 65 | "char-map.sml", 66 | "list-xprod-sig.sml", 67 | "graph-scc-sig.sml", 68 | "graph-scc-fn.sml", 69 | "hash-table-fn.sml", 70 | "atom-table.sml", 71 | "list-format-sig.sml", 72 | "list-format.sml", 73 | "bit-vector-sig.sml", 74 | "parser-comb.sml", 75 | "mono-hash2-table-sig.sml", 76 | "interval-set-fn.sml", 77 | "word-redblack-set.sml", 78 | "word-redblack-map.sml", 79 | "int-list-set.sml", 80 | "int-list-map.sml", 81 | "path-util-sig.sml", 82 | "path-util.sml", 83 | "binary-set-fn.sml", 84 | "binary-map-fn.sml", 85 | "random-sig.sml", 86 | "random.sml", 87 | "real-order-stats.sml", 88 | "univariate-stats.sml", 89 | "bit-array.sml", 90 | "mono-array-fn.sml", 91 | "bsearch-fn.sml", 92 | "mono-dynamic-array-sig.sml", 93 | "format-comb-sig.sml", 94 | "format-comb.sml", 95 | "queue-sig.sml", 96 | "fifo-sig.sml", 97 | "fifo.sml", 98 | "queue.sml", 99 | "hash2-table-fn.sml", 100 | "word-hash-table.sml", 101 | "keyword-fn.sml", 102 | "mono-priorityq-sig.sml", 103 | "left-priorityq-fn.sml", 104 | "hash-table-sig.sml", 105 | "hash-table.sml", 106 | "dynamic-array-fn.sml", 107 | "mono-array-sort-sig.sml", 108 | "int-redblack-set.sml", 109 | "int-redblack-map.sml", 110 | "array-sort-sig.sml", 111 | "array-qsort.sml", 112 | "uref-sig.sml", 113 | "simple-uref.sml", 114 | "listsort-sig.sml", 115 | "list-mergesort.sml", 116 | "array-qsort-fn.sml", 117 | "atom-binary-set.sml", 118 | "atom-binary-map.sml", 119 | "utf8-sig.sml", 120 | "utf8.sml", 121 | "uref.sml", 122 | "scan-sig.sml", 123 | "scan.sml", 124 | "rand-sig.sml", 125 | "rand.sml", 126 | "list-xprod.sml", 127 | ""] 128 | 129 | val controls = [ 130 | "controls-sig.sml", 131 | "control-reps.sml", 132 | "controls.sml", 133 | "control-set-sig.sml", 134 | "control-set.sml", 135 | "registry-sig.sml", 136 | "control-util-sig.sml", 137 | "control-util.sml", 138 | "registry.sml", 139 | ""] 140 | 141 | val hashcons = [ 142 | "hash-cons-sig.sml", 143 | "hash-cons.sml", 144 | "hash-cons-set-sig.sml", 145 | "hash-cons-map-sig.sml", 146 | "hash-cons-set.sml", 147 | "hash-cons-map.sml", 148 | "hash-cons-ground-fn.sml", 149 | "hash-cons-string.sml", 150 | "hash-cons-atom.sml", 151 | ""] 152 | 153 | val html = [ 154 | "html-sig.sml", 155 | "html.sml", 156 | "make-html.sml", 157 | "html-defaults.sml", 158 | "html-error-sig.sml", 159 | "check-html-fn.sml", 160 | "html-attr-vals.sml", 161 | "html-attrs-sig.sml", 162 | "html-gram.sig", 163 | "html-elements-fn.sml", 164 | "html-lex.sml", 165 | "html-gram.sml", 166 | "html-attrs-fn.sml", 167 | "html-parser-fn.sml", 168 | "pr-html.sml", 169 | ""] 170 | 171 | val inet = [ 172 | "sock-util-sig.sml", 173 | "sock-util.sml", 174 | "unix-sock-util.sml", 175 | ""] 176 | 177 | val pp = [ 178 | "src/pp-stream-sig.sml", 179 | "src/pp-debug-fn.sml", 180 | "src/pp-device-sig.sml", 181 | "devices/simple-textio-dev.sml", 182 | "src/pp-token-sig.sml", 183 | "src/pp-stream-fn.sml", 184 | "src/pp-desc-sig.sml", 185 | "src/pp-desc-fn.sml", 186 | "devices/string-token.sml", 187 | "devices/textio-pp.sml", 188 | "devices/ansi-term-dev.sml", 189 | "devices/html-dev.sml", 190 | "devices/ansi-term-pp.sml", 191 | ""] 192 | 193 | val reactive = [ 194 | "reactive-sig.sml", 195 | "instruction.sml", 196 | "machine.sml", 197 | "reactive.sml", 198 | ""] 199 | 200 | val regexp = [ 201 | "Glue/match-tree.sml", 202 | "FrontEnd/syntax-sig.sml", 203 | "FrontEnd/syntax.sml", 204 | "BackEnd/engine-sig.sml", 205 | "BackEnd/fsm.sml", 206 | "BackEnd/dfa-engine.sml", 207 | "Glue/regexp-sig.sml", 208 | "FrontEnd/parser-sig.sml", 209 | "Glue/regexp-fn.sml", 210 | "FrontEnd/awk-syntax.sml", 211 | "BackEnd/bt-engine.sml", 212 | ""] 213 | 214 | val unix = [ 215 | "unix-env-sig.sml", 216 | "unix-env.sml", 217 | ""] 218 | 219 | fun dol ("",_) =() 220 | | dol (dn,l) =List.app(fn "" => () 221 | | s => use(root^"/smlnj-lib/"^dn^"/"^s)) l 222 | in 223 | val _ = List.app dol [ 224 | ("Util", util), 225 | ("Controls", controls), 226 | ("HashCons", hashcons), 227 | ("HTML", html), 228 | ("INet", inet), 229 | ("PP", pp), 230 | ("Reactive", reactive), 231 | ("RegExp", regexp), 232 | ("Unix", unix), 233 | ("", [])] 234 | end; 235 | -------------------------------------------------------------------------------- /src/posix-symlink.sml: -------------------------------------------------------------------------------- 1 | structure Symlink = 2 | struct 3 | fun replaceOrCreateSymlink dst link = 4 | let 5 | (* Delete the old link if it exists *) 6 | val e = OS.FileSys.isLink link handle _ => false 7 | val _ = 8 | (if e then OS.FileSys.remove link else ()) 9 | handle _ => () 10 | 11 | (* Create the new one *) 12 | val _ = Posix.FileSys.symlink {old = dst, new = link} 13 | in 14 | () 15 | end 16 | end 17 | -------------------------------------------------------------------------------- /src/protocol.smi: -------------------------------------------------------------------------------- 1 | _require "basis.smi" 2 | 3 | structure Protocol = 4 | struct 5 | datatype protocol = Git of { uri: string } 6 | type t = protocol 7 | 8 | val toString: t -> string 9 | val fromString: string -> t 10 | val compare: t * t -> General.order 11 | end 12 | 13 | -------------------------------------------------------------------------------- /src/protocol.sml: -------------------------------------------------------------------------------- 1 | 2 | structure Protocol = 3 | struct 4 | datatype protocol = Git of { uri: string } 5 | type t = protocol 6 | 7 | fun toString prot = 8 | case prot of 9 | Git { uri } => "git " ^ uri 10 | 11 | fun fromString s = 12 | case String.tokens Char.isSpace s of 13 | [ "git", s ] => Git { uri = s } 14 | | _ => raise Fail ("Unknown protocol: `" ^ s ^ "`") 15 | 16 | fun compare (Git {uri}, Git {uri = uri'}) = String.compare (uri, uri') 17 | end 18 | 19 | -------------------------------------------------------------------------------- /src/semver.smi: -------------------------------------------------------------------------------- 1 | _require "basis.smi" 2 | 3 | (* signature SEMVER = *) 4 | (* sig *) 5 | (* eqtype semver (* v0.2.4beta, v1.2.3, etc... *) *) 6 | (* type t = semver *) 7 | (* type constraint (* v1, v1.2, v2.3.6, v3.1.6, etc... *) *) 8 | 9 | (* exception InvalidVersion *) 10 | 11 | (* val constrFromString : string -> constraint *) 12 | (* val constrToString : constraint -> string *) 13 | (* val compareConstr : constraint * constraint -> order *) 14 | 15 | (* val fromString : string -> semver *) 16 | (* val major : semver -> constraint *) 17 | (* val minor : semver -> constraint *) 18 | (* val exact : semver -> constraint *) 19 | (* val toString : semver -> string *) 20 | (* val eq : semver * semver -> bool *) 21 | (* val compare : semver * semver -> order *) 22 | (* val satisfies : constraint -> semver -> bool *) 23 | (* val < : semver * semver -> bool *) 24 | (* val <= : semver * semver -> bool *) 25 | (* val >= : semver * semver -> bool *) 26 | (* val > : semver * semver -> bool *) 27 | (* val allPaths : semver -> string list *) 28 | 29 | (* (* intelligentSelect is a way of resolving a partially-specified semantic *) 30 | (* * version which makes sense to Rob at the time. *) 31 | (* * *) 32 | (* * It will prefer tags with special versions over tags with *) 33 | (* * no versions (so `intelligentSelect NONE [ v2.0.0beta, v1.9.3 ]' will *) 34 | (* * return `SOME (v1.9.3, "1")') but will prefer nothing to something (so *) 35 | (* * `intelligentSelect (SOME v2) [ 2.0.0beta, 1.9.3 ]' will return *) 36 | (* * `SOME (2.0.0beta, 2)') *) 37 | (* * *) 38 | (* * The returned constraint is equal to the given constraint if an initial *) 39 | (* * constraint was given, and is the major version of the returned semvar *) 40 | (* * if no initial constraint was given. *) *) 41 | (* val intelligentSelect : *) 42 | (* constraint option -> semver list -> (constraint * semver) option *) 43 | (* end *) 44 | 45 | structure SemVer = 46 | struct 47 | type semver(=boxed) (* v0.2.4beta, v1.2.3, etc... *) 48 | type t = semver 49 | type constraint(=boxed) (* v1, v1.2, v2.3.6, v3.1.6, etc... *) 50 | 51 | exception InvalidVersion 52 | 53 | val constrFromString : string -> constraint 54 | val constrToString : constraint -> string 55 | val compareConstr : constraint * constraint -> order 56 | 57 | val fromString : string -> semver 58 | val major : semver -> constraint 59 | val minor : semver -> constraint 60 | val exact : semver -> constraint 61 | val toString : semver -> string 62 | val eq : semver * semver -> bool 63 | val compare : semver * semver -> order 64 | val satisfies : constraint -> semver -> bool 65 | val < : semver * semver -> bool 66 | val <= : semver * semver -> bool 67 | val >= : semver * semver -> bool 68 | val > : semver * semver -> bool 69 | val allPaths : semver -> string list 70 | 71 | (* intelligentSelect is a way of resolving a partially-specified semantic 72 | * version which makes sense to Rob at the time. 73 | * 74 | * It will prefer tags with special versions over tags with 75 | * no versions (so `intelligentSelect NONE [ v2.0.0beta, v1.9.3 ]' will 76 | * return `SOME (v1.9.3, "1")') but will prefer nothing to something (so 77 | * `intelligentSelect (SOME v2) [ 2.0.0beta, 1.9.3 ]' will return 78 | * `SOME (2.0.0beta, 2)') 79 | * 80 | * The returned constraint is equal to the given constraint if an initial 81 | * constraint was given, and is the major version of the returned semvar 82 | * if no initial constraint was given. *) 83 | val intelligentSelect : 84 | constraint option -> semver list -> (constraint * semver) option 85 | end 86 | -------------------------------------------------------------------------------- /src/semver.sml: -------------------------------------------------------------------------------- 1 | signature SEMVER = 2 | sig 3 | eqtype semver (* v0.2.4beta, v1.2.3, etc... *) 4 | type t = semver 5 | type constraint (* v1, v1.2, v2.3.6, v3.1.6, etc... *) 6 | 7 | exception InvalidVersion 8 | 9 | val constrFromString : string -> constraint 10 | val constrToString : constraint -> string 11 | val compareConstr : constraint * constraint -> order 12 | 13 | val fromString : string -> semver 14 | val major : semver -> constraint 15 | val minor : semver -> constraint 16 | val exact : semver -> constraint 17 | val toString : semver -> string 18 | val eq : semver * semver -> bool 19 | val compare : semver * semver -> order 20 | val satisfies : constraint -> semver -> bool 21 | val < : semver * semver -> bool 22 | val <= : semver * semver -> bool 23 | val >= : semver * semver -> bool 24 | val > : semver * semver -> bool 25 | val allPaths : semver -> string list 26 | 27 | (* intelligentSelect is a way of resolving a partially-specified semantic 28 | * version which makes sense to Rob at the time. 29 | * 30 | * It will prefer tags with special versions over tags with 31 | * no versions (so `intelligentSelect NONE [ v2.0.0beta, v1.9.3 ]' will 32 | * return `SOME (v1.9.3, "1")') but will prefer nothing to something (so 33 | * `intelligentSelect (SOME v2) [ 2.0.0beta, 1.9.3 ]' will return 34 | * `SOME (2.0.0beta, 2)') 35 | * 36 | * The returned constraint is equal to the given constraint if an initial 37 | * constraint was given, and is the major version of the returned semvar 38 | * if no initial constraint was given. *) 39 | val intelligentSelect : 40 | constraint option -> semver list -> (constraint * semver) option 41 | end 42 | 43 | structure SemVer:> SEMVER = 44 | struct 45 | type semver = int * int * int * string option 46 | type t = semver 47 | type constraint = int * int option * int option * string option 48 | 49 | exception InvalidVersion 50 | 51 | fun compareConstr ((maj1, min1, pat1, s1), (maj2, min2, pat2, s2)) = 52 | case (Int.compare (maj1, maj2), min1, min2) of 53 | (LESS, _, _) => LESS 54 | | (GREATER, _, _) => GREATER 55 | | (EQUAL, NONE, NONE) => EQUAL 56 | | (EQUAL, NONE, SOME _) => LESS 57 | | (EQUAL, SOME _, NONE) => GREATER 58 | | (EQUAL, SOME min1, SOME min2) => 59 | (case (Int.compare (min1, min2), pat1, pat2) of 60 | (LESS, _, _) => LESS 61 | | (GREATER, _, _) => GREATER 62 | | (EQUAL, NONE, NONE) => EQUAL 63 | | (EQUAL, NONE, SOME _) => LESS 64 | | (EQUAL, SOME _, NONE) => GREATER 65 | | (EQUAL, SOME pat1, SOME pat2) => 66 | (case (Int.compare (pat1, pat2), s1, s2) of 67 | (LESS, _, _) => LESS 68 | | (GREATER, _, _) => GREATER 69 | | (EQUAL, NONE, NONE) => EQUAL 70 | | (EQUAL, NONE, SOME _) => GREATER 71 | | (EQUAL, SOME _, NONE) => LESS 72 | | (EQUAL, SOME s1, SOME s2) => String.compare (s1, s2))) 73 | 74 | 75 | fun eq (x: semver, y) = x = y 76 | 77 | fun major (major, _, _, _) = (major, NONE, NONE, NONE) 78 | fun minor (major, minor, _, _) = (major, SOME minor, NONE, NONE) 79 | fun exact (major, minor, patch, special) = 80 | (major, SOME minor, SOME patch, special) 81 | 82 | fun fromString' s = 83 | let 84 | fun fail () = raise Fail ("`" ^ s ^ "` not a valid semantic version") 85 | 86 | val s' = 87 | case String.tokens Char.isSpace s of 88 | [ s ] => 89 | if String.sub (s,0) = #"v" 90 | then String.extract (s, 1, NONE) 91 | else s 92 | | _ => fail () 93 | 94 | val f = String.fields (fn #"." => true | _ => false) s' 95 | 96 | fun vtoi i = 97 | case Int.fromString i of 98 | NONE => fail () 99 | | SOME v => v 100 | in 101 | case f of 102 | [ major ] => (vtoi major, NONE, NONE, NONE) 103 | | [ major, minor ] => (vtoi major, SOME (vtoi minor), NONE, NONE) 104 | | [ major, minor, patch ] => 105 | let 106 | fun until [] = [] 107 | | until (h::t) = if Char.isDigit h then h :: until t else [] 108 | val patchN = String.implode (until (String.explode patch)) 109 | val special = 110 | if patch = patchN then NONE 111 | else SOME (String.extract (patch, size patchN, NONE)) 112 | in 113 | (vtoi major, SOME (vtoi minor), SOME (vtoi patchN), special) 114 | end 115 | | _ => fail () 116 | end 117 | 118 | fun constrFromString s = fromString' s 119 | 120 | fun fromString s = 121 | case fromString' s of 122 | (major, SOME minor, SOME patch, special) => 123 | (major, minor, patch, special) 124 | | _ => raise Fail ("`" ^ s ^ "` is an incomplete semantic version") 125 | 126 | val ts = Int.toString 127 | 128 | fun toString (ma,mi,pa,s) = 129 | ts ma ^ "." ^ ts mi ^ "." ^ ts pa ^ 130 | (if s = NONE then "" else valOf s) 131 | 132 | fun constrToString (major, NONE, _, _) = ts major 133 | | constrToString (major, SOME minor, NONE, _) = ts major ^ "." ^ ts minor 134 | | constrToString (major, SOME minor, SOME patch, NONE) = 135 | ts major ^ "." ^ ts minor ^ "." ^ ts patch 136 | | constrToString (major, SOME minor, SOME patch, SOME special) = 137 | ts major ^ "." ^ ts minor ^ "." ^ ts patch ^ special 138 | 139 | fun compare ((ma,mi,pa,st),(ma',mi',pa',st')) = 140 | if ma < ma' then LESS else 141 | if ma > ma' then GREATER else 142 | if mi < mi' then LESS else 143 | if mi > mi' then GREATER else 144 | if pa < pa' then LESS else 145 | if pa > pa' then GREATER else 146 | (case (st,st') of 147 | (NONE,NONE) => EQUAL 148 | | (SOME _,NONE) => LESS 149 | | (NONE,SOME _) => GREATER 150 | | (SOME a, SOME b) => 151 | if a = b then EQUAL else 152 | if String.<(a,b) then LESS else GREATER) 153 | 154 | fun a < b = compare (a,b) = LESS 155 | fun a <= b = compare (a,b) <> GREATER 156 | fun a >= b = compare (a,b) <> LESS 157 | fun a > b = compare (a,b) = GREATER 158 | fun max a b = if b > a then b else a 159 | 160 | (* Does a version number meet the specification? *) 161 | fun satisfies spec (ver: semver) = 162 | case spec of 163 | (major, NONE, _, _) => 164 | (#1 ver = major) 165 | | (major, SOME minor, NONE, _) => 166 | (#1 ver = major andalso #2 ver = minor) 167 | | (major, SOME minor, SOME patch, NONE) => 168 | (#1 ver = major andalso #2 ver = minor andalso #3 ver = patch) 169 | | (major, SOME minor, SOME patch, SOME special) => 170 | (#1 ver = major 171 | andalso #2 ver = minor 172 | andalso #3 ver = patch 173 | andalso isSome (#4 ver) 174 | andalso String.isPrefix special (valOf (#4 ver))) 175 | 176 | (** Enumerate the various paths that this version could give rise to. 177 | e.g., for version 1.6.2beta1, we could potentially have these paths: 178 | v1, v1.6, v1.6.2beta1 *) 179 | fun allPaths (v as (ma,mi,pa,ps)) = 180 | ["v" ^ Int.toString ma, 181 | "v" ^ Int.toString ma ^ "." ^ Int.toString mi, 182 | "v" ^ toString v] 183 | 184 | 185 | fun intelligentSelect spec vers = 186 | let 187 | val satisfies = 188 | case spec of 189 | NONE => (fn _ => true) 190 | | SOME spec => satisfies spec 191 | 192 | fun best NONE ver = 193 | if satisfies ver then SOME ver else NONE 194 | | best (SOME oldBest) ver = 195 | if satisfies ver 196 | then (case (#4 oldBest, #4 ver) of 197 | (NONE, NONE) => SOME (max oldBest ver) 198 | | (SOME _, SOME _) => SOME (max oldBest ver) 199 | | (_, NONE) => SOME ver 200 | | (NONE, _) => SOME oldBest) 201 | else SOME oldBest 202 | 203 | fun process best [] = best 204 | | process oldBest (ver :: vers) = process (best oldBest ver) vers 205 | in 206 | case (process NONE vers, spec) of 207 | (NONE, _) => NONE 208 | | (SOME ver, NONE) => SOME (major ver, ver) 209 | | (SOME ver, SOME spec) => SOME (spec, ver) 210 | end 211 | end 212 | -------------------------------------------------------------------------------- /src/smackage-path.smi: -------------------------------------------------------------------------------- 1 | _require "basis.smi" 2 | _require "semver.smi" 3 | _require "spec.smi" 4 | _require "../util/sort.smi" 5 | _require "bullshit-symlink.smi" 6 | 7 | structure SmackagePath = 8 | struct 9 | exception Metadata of string 10 | val installedVersions: string -> string -> SemVer.t list 11 | val installedSatisfying: string -> string -> SemVer.constraint -> SemVer.t list 12 | val packageMetadata: string -> string * SemVer.t -> Spec.spec 13 | val createPackagePaths: string -> string * SemVer.t -> unit 14 | val createVersionLinks: string -> string * SemVer.t -> string list 15 | end 16 | 17 | -------------------------------------------------------------------------------- /src/smackage-path.sml: -------------------------------------------------------------------------------- 1 | (** Deal with filesystem elements in a sensible way. 2 | 3 | FIXME: This is heavily dependent on symlinks working. Windows will need some 4 | deeper thought. 5 | *) 6 | structure SmackagePath = 7 | struct 8 | exception Metadata of string 9 | 10 | (** Retrieve a list of currently installed versions of pkg. 11 | We do this by listing the directory, and ignoring everything 12 | that's not a valid semantic version. This ignores the symlinks 13 | like v1 and v1.6, and only gets the full versions like v1.6.2. 14 | 15 | The result *MUST* be sorted in descending order. 16 | *) 17 | fun installedVersions smackage_root pkg = 18 | let 19 | val pkgDir' = OS.Path.joinDirFile {dir = smackage_root, file = "lib"} 20 | val pkgDir = OS.Path.joinDirFile {dir = pkgDir', file = pkg} 21 | val dh = OS.FileSys.openDir pkgDir 22 | fun untilNone () = 23 | let 24 | val v = OS.FileSys.readDir dh 25 | in 26 | if v = NONE then [] else (valOf v) :: untilNone () 27 | end 28 | val values = untilNone () 29 | val _ = OS.FileSys.closeDir dh 30 | in 31 | InsertionSort.sort SemVer.compare 32 | (List.mapPartial 33 | (fn x => SOME (SemVer.fromString x) handle _ => NONE) values) 34 | end 35 | 36 | (** Return me the latest installed version satisfying a given constraint 37 | in descending version order. *) 38 | fun installedSatisfying smackage_root pkg constr = 39 | let 40 | val cand = installedVersions smackage_root pkg 41 | in 42 | List.filter (SemVer.satisfies constr) cand 43 | end 44 | 45 | (** Get the metadata for a currently-installed package *) 46 | fun packageMetadata smackage_root (pkg,ver) = 47 | let 48 | val pkgDir' = OS.Path.joinDirFile {dir = smackage_root, file = "lib"} 49 | val pkgDir'' = OS.Path.joinDirFile {dir = pkgDir', file = pkg} 50 | val pkgDir = OS.Path.joinDirFile 51 | {dir = pkgDir'', file = "v" ^ SemVer.toString ver} 52 | val specFile = OS.Path.joinDirFile {dir=pkgDir,file=pkg ^ ".smackspec"} 53 | 54 | in 55 | if not (OS.FileSys.access (specFile, [])) 56 | then raise Metadata ("Spec file not found: " ^ specFile) else 57 | if not (OS.FileSys.access (specFile, [ OS.FileSys.A_READ ])) 58 | then raise Metadata "Spec file exists but can't be read" 59 | else Spec.fromFile specFile 60 | handle (Spec.SpecError s) => raise Fail ("Spec error: " ^ s) 61 | end 62 | 63 | 64 | (** Create the empty directory for pkg at a given version, and 65 | don't create the symlinks yet. 66 | 67 | Instead, call createVersionLinks *after* you've checked out the 68 | source. This will make non-posix platforms behave correctly. 69 | 70 | 71 | 72 | This will leave the current working directory as the newly created 73 | directory for this package. 74 | *) 75 | fun createPackagePaths smackage_root (pkg,ver) = 76 | let 77 | val pkgDir' = OS.Path.joinDirFile {dir = smackage_root, file = "lib"} 78 | 79 | val _ = if not (OS.FileSys.access (pkgDir', [])) then 80 | OS.FileSys.mkDir pkgDir' else () 81 | 82 | val pkgDir = OS.Path.joinDirFile {dir = pkgDir', file = pkg} 83 | (* Create the top-level package directory if it doesn't exist *) 84 | val _ = OS.FileSys.isDir pkgDir handle _ => 85 | (OS.FileSys.mkDir pkgDir; true) 86 | val _ = OS.FileSys.chDir pkgDir 87 | 88 | val versionDir = "v" ^ SemVer.toString ver 89 | val _ = OS.FileSys.mkDir 90 | (OS.Path.joinDirFile {dir=pkgDir, file=versionDir}) handle _ => () 91 | 92 | val _ = OS.FileSys.chDir versionDir 93 | in 94 | () 95 | end 96 | 97 | (* Create major and minor version links to the concrete version. 98 | 99 | The question we face is whether the new package we are installing 100 | should replace some other as the target of a version symlink. 101 | 102 | FIXME: There is very little error handling in here at the moment. 103 | This is somewhat intentional, as an exception anywhere should bail out 104 | the whole process. 105 | *) 106 | fun createVersionLinks smackage_root (pkg,ver) = 107 | let 108 | val pkgDir' = OS.Path.joinDirFile {dir = smackage_root, file = "lib"} 109 | val pkgDir = OS.Path.joinDirFile {dir = pkgDir', file = pkg} 110 | val _ = OS.FileSys.chDir pkgDir 111 | 112 | val versionDir = "v" ^ SemVer.toString ver 113 | 114 | val newPaths = map (fn x => 115 | OS.Path.joinDirFile {dir = pkg, file = x}) 116 | (SemVer.allPaths ver) 117 | val existing = 118 | List.filter (fn x => not (SemVer.eq(x, ver))) (installedVersions smackage_root pkg) 119 | 120 | val majorPrefix = SemVer.constrToString (SemVer.major ver) 121 | val majors = 122 | List.filter 123 | (fn x => String.isPrefix majorPrefix (SemVer.toString x)) 124 | existing 125 | val symlinks = 126 | if length majors = 0 orelse SemVer.< (hd majors, ver) 127 | then ["v" ^ majorPrefix] else [] 128 | 129 | val minorPrefix = SemVer.constrToString (SemVer.minor ver) 130 | val minors = List.filter 131 | (fn x => String.isPrefix minorPrefix (SemVer.toString x)) existing 132 | 133 | val symlinks' = symlinks @ 134 | (if length minors = 0 orelse SemVer.< (hd minors, ver) 135 | then ["v" ^ minorPrefix] else []) 136 | 137 | val _ = List.app (Symlink.replaceOrCreateSymlink versionDir) symlinks' 138 | 139 | val _ = OS.FileSys.chDir versionDir 140 | in 141 | ["v" ^ SemVer.toString ver] @ symlinks @ symlinks' 142 | end 143 | end 144 | 145 | -------------------------------------------------------------------------------- /src/smacklib.smi: -------------------------------------------------------------------------------- 1 | _require "basis.smi" 2 | _require "semver.smi" 3 | _require "protocol.smi" 4 | _require "spec.smi" 5 | _require "smackage-path.smi" 6 | _require "conductor.smi" 7 | 8 | structure SmackLib = 9 | struct 10 | (** Ensure that a package is present in the library; returns true if it 11 | ** was already there *) 12 | val download : string -> string * SemVer.semver * Protocol.protocol -> bool 13 | 14 | (** Checks for a package's existance without modifying anything. *) 15 | val exists : string -> string * SemVer.semver -> bool 16 | 17 | (* 18 | (** Build a previously downloaded package by invoking a command 19 | specified as 'build:' in the spec file. *) 20 | val build : string -> (string * string list) -> 21 | (string * SemVer.semver) -> unit; 22 | 23 | (** Install a previously downloaded package by invoking a command 24 | specified as 'install:' in the spec file. *) 25 | val install : string -> (string * string list) -> 26 | (string * SemVer.semver) -> unit; 27 | *) 28 | 29 | (** Returns a list of installed versions *) 30 | (* XXX should probably be sorted, relies on the filesystem for this now *) 31 | val versions : string -> string -> SemVer.semver list 32 | 33 | (** Returns the smackspec for a particular smackage package *) 34 | val info : string -> string * SemVer.semver -> Spec.spec 35 | end 36 | -------------------------------------------------------------------------------- /src/smacklib.sml: -------------------------------------------------------------------------------- 1 | signature SMACKLIB = 2 | sig 3 | (** Ensure that a package is present in the library; returns true if it 4 | ** was already there *) 5 | val download : string -> string * SemVer.semver * Protocol.protocol -> bool 6 | 7 | (** Checks for a package's existance without modifying anything. *) 8 | val exists : string -> string * SemVer.semver -> bool 9 | 10 | (* 11 | (** Build a previously downloaded package by invoking a command 12 | specified as 'build:' in the spec file. *) 13 | val build : string -> (string * string list) -> 14 | (string * SemVer.semver) -> unit; 15 | 16 | (** Install a previously downloaded package by invoking a command 17 | specified as 'install:' in the spec file. *) 18 | val install : string -> (string * string list) -> 19 | (string * SemVer.semver) -> unit; 20 | *) 21 | 22 | (** Returns a list of installed versions *) 23 | (* XXX should probably be sorted, relies on the filesystem for this now *) 24 | val versions : string -> string -> SemVer.semver list 25 | 26 | (** Returns the smackspec for a particular smackage package *) 27 | val info : string -> string * SemVer.semver -> Spec.spec 28 | end 29 | 30 | structure SmackLib : SMACKLIB = 31 | struct 32 | fun // (dir, file) = OS.Path.joinDirFile { dir = dir, file = file } 33 | infix 5 // 34 | 35 | fun exists smackage_root (pkg, ver) = 36 | let 37 | val pkgRoot = smackage_root // "lib" // pkg 38 | val verString = "v" ^ SemVer.toString ver 39 | in 40 | OS.FileSys.access (pkgRoot, []) 41 | andalso 42 | OS.FileSys.access (pkgRoot // verString, []) 43 | end 44 | 45 | fun download smackage_root (pkg, ver, prot) = 46 | if exists smackage_root (pkg, ver) 47 | then true 48 | else ( SmackagePath.createPackagePaths smackage_root (pkg,ver) 49 | ; Conductor.get smackage_root pkg ver prot 50 | ; SmackagePath.createVersionLinks smackage_root (pkg,ver) 51 | ; false) 52 | 53 | (* 54 | fun build smackage_root host (pkg,ver) = 55 | let 56 | val pkgDir = (smackage_root // "lib" // pkg // "v"^SemVer.toString ver) 57 | 58 | val spec = Spec.fromFile (pkgDir // (pkg ^ ".smackspec")) 59 | 60 | val _ = OS.FileSys.chDir pkgDir 61 | in 62 | Install.build host spec 63 | end handle (Spec.SpecError _) => () (* Silently fail if there is no spec. *) 64 | 65 | fun install smackage_root host (pkg,ver) = 66 | let 67 | val pkgDir = (smackage_root // "lib" // pkg // "v"^SemVer.toString ver) 68 | 69 | val spec = Spec.fromFile (pkgDir // (pkg ^ ".smackspec")) 70 | 71 | val _ = OS.FileSys.chDir pkgDir 72 | in 73 | Install.install host spec 74 | end handle (Spec.SpecError _) => () (* Silently fail if there is no spec. *) 75 | 76 | fun uninstall smackage_root (pkg,ver) = raise Fail "Not implemented" 77 | *) 78 | 79 | fun versions smackage_root pkg = 80 | let 81 | val pkgRoot = smackage_root // "lib" // pkg 82 | fun read dir accum = 83 | case OS.FileSys.readDir dir of 84 | NONE => rev accum before OS.FileSys.closeDir dir 85 | | SOME file => 86 | if String.isPrefix "v" file 87 | andalso 3 = length (String.tokens (fn x => x = #".") file) 88 | then read dir (SemVer.fromString file :: accum) 89 | else read dir accum 90 | in 91 | if OS.FileSys.access (pkgRoot, []) 92 | then read (OS.FileSys.openDir pkgRoot) [] 93 | else [] 94 | end 95 | 96 | fun info smackage_root (pkg,ver) = 97 | let 98 | val file = 99 | ( smackage_root 100 | // "lib" 101 | // pkg 102 | // ("v" ^ SemVer.toString ver) 103 | // (pkg ^ ".smackspec")) 104 | in 105 | Spec.fromFile file 106 | end handle (Spec.SpecError s) => raise Fail ("Spec error: " ^ s) 107 | end 108 | -------------------------------------------------------------------------------- /src/spec.smi: -------------------------------------------------------------------------------- 1 | _require "basis.smi" 2 | _require "semver.smi" 3 | _require "protocol.smi" 4 | _require "../util/dict-list.smi" 5 | _require "fsutil.smi" 6 | 7 | structure SemVerDict = 8 | struct 9 | type key = SemVer.t 10 | type 'a dict(=boxed) 11 | 12 | exception Absent 13 | 14 | val empty : 'a dict 15 | val singleton : key -> 'a -> 'a dict 16 | val insert : 'a dict -> key -> 'a -> 'a dict 17 | val remove : 'a dict -> key -> 'a dict 18 | val find : 'a dict -> key -> 'a option 19 | val lookup : 'a dict -> key -> 'a 20 | val union : 'a dict -> 'a dict -> (key * 'a * 'a -> 'a) -> 'a dict 21 | 22 | val operate : 'a dict -> key -> (unit -> 'a) -> ('a -> 'a) -> 'a option * 'a * 'a dict 23 | val insertMerge : 'a dict -> key -> 'a -> ('a -> 'a) -> 'a dict 24 | 25 | val isEmpty : 'a dict -> bool 26 | val member : 'a dict -> key -> bool 27 | val size : 'a dict -> int 28 | 29 | val toList : 'a dict -> (key * 'a) list 30 | val domain : 'a dict -> key list 31 | val map : ('a -> 'b) -> 'a dict -> 'b dict 32 | val foldl : (key * 'a * 'b -> 'b) -> 'b -> 'a dict -> 'b 33 | val foldr : (key * 'a * 'b -> 'b) -> 'b -> 'a dict -> 'b 34 | val app : (key * 'a -> unit) -> 'a dict -> unit 35 | 36 | end 37 | structure SemConstrDict = 38 | struct 39 | type key = SemVer.constraint 40 | type 'a dict(=boxed) 41 | 42 | exception Absent 43 | 44 | val empty : 'a dict 45 | val singleton : key -> 'a -> 'a dict 46 | val insert : 'a dict -> key -> 'a -> 'a dict 47 | val remove : 'a dict -> key -> 'a dict 48 | val find : 'a dict -> key -> 'a option 49 | val lookup : 'a dict -> key -> 'a 50 | val union : 'a dict -> 'a dict -> (key * 'a * 'a -> 'a) -> 'a dict 51 | 52 | val operate : 'a dict -> key -> (unit -> 'a) -> ('a -> 'a) -> 'a option * 'a * 'a dict 53 | val insertMerge : 'a dict -> key -> 'a -> ('a -> 'a) -> 'a dict 54 | 55 | val isEmpty : 'a dict -> bool 56 | val member : 'a dict -> key -> bool 57 | val size : 'a dict -> int 58 | 59 | val toList : 'a dict -> (key * 'a) list 60 | val domain : 'a dict -> key list 61 | val map : ('a -> 'b) -> 'a dict -> 'b dict 62 | val foldl : (key * 'a * 'b -> 'b) -> 'b -> 'a dict -> 'b 63 | val foldr : (key * 'a * 'b -> 'b) -> 'b -> 'a dict -> 'b 64 | val app : (key * 'a -> unit) -> 'a dict -> unit 65 | end 66 | structure StringDict = 67 | struct 68 | type key = string 69 | type 'a dict(=boxed) 70 | 71 | exception Absent 72 | 73 | val empty : 'a dict 74 | val singleton : key -> 'a -> 'a dict 75 | val insert : 'a dict -> key -> 'a -> 'a dict 76 | val remove : 'a dict -> key -> 'a dict 77 | val find : 'a dict -> key -> 'a option 78 | val lookup : 'a dict -> key -> 'a 79 | val union : 'a dict -> 'a dict -> (key * 'a * 'a -> 'a) -> 'a dict 80 | 81 | val operate : 'a dict -> key -> (unit -> 'a) -> ('a -> 'a) -> 'a option * 'a * 'a dict 82 | val insertMerge : 'a dict -> key -> 'a -> ('a -> 'a) -> 'a dict 83 | 84 | val isEmpty : 'a dict -> bool 85 | val member : 'a dict -> key -> bool 86 | val size : 'a dict -> int 87 | 88 | val toList : 'a dict -> (key * 'a) list 89 | val domain : 'a dict -> key list 90 | val map : ('a -> 'b) -> 'a dict -> 'b dict 91 | val foldl : (key * 'a * 'b -> 'b) -> 'b -> 'a dict -> 'b 92 | val foldr : (key * 'a * 'b -> 'b) -> 'b -> 'a dict -> 'b 93 | val app : (key * 'a -> unit) -> 'a dict -> unit 94 | end 95 | 96 | structure Spec = 97 | struct 98 | exception SpecError of string 99 | 100 | datatype spec_entry = 101 | Provides of string * SemVer.semver 102 | | Description of string 103 | | Requires of string * SemVer.constraint * SemVer.semver option 104 | | Maintainer of string 105 | | Remote of Protocol.protocol 106 | | License of string 107 | | Platform of string 108 | | Key of string * string 109 | 110 | type spec = spec_entry list 111 | 112 | (* Parse a smackspec file (every line should be an empty string or a valid 113 | * spec_entry, such as one would get from FSUtil.getLines) *) 114 | val parse: string list -> spec 115 | val fromFile: string -> spec 116 | val toString: spec -> string 117 | 118 | (* Interprets the spec as a packages file, get the requirements *) 119 | val key: spec -> string -> string list 120 | val platforms: spec -> (string * spec) list 121 | val provides: spec -> string * SemVer.semver 122 | val remote: spec -> Protocol.protocol 123 | val requires: 124 | spec -> (string * SemVer.constraint * SemVer.semver option) list 125 | 126 | (* Interprests a series of specs as a versions.smackspec file *) 127 | val toVersionIndex: 128 | spec list -> Protocol.protocol SemVerDict.dict StringDict.dict 129 | end 130 | -------------------------------------------------------------------------------- /src/spec.sml: -------------------------------------------------------------------------------- 1 | (* 2 | This defines the data structure and syntax for smackage package definitions 3 | (smackspec files). The general syntax is a flat key/value format, eg: 4 | 5 | provides: test 1.2.3beta 6 | description: This is a sample smackspec file. 7 | remote: git https://example.org/test.git 8 | requires: smacklib >= 1.2.3 9 | requires: ioextras 0.0.45 10 | 11 | The following keys are supported: 12 | 13 | description: ANY_STRING 14 | remote: TYPE URL 15 | requires: PACKAGE_NAME PARTIAL_SEMVER [optional: (MINIMAL_SEMVER)] 16 | comment: ANY_STRING 17 | maintainer: FULL_NAME 18 | keywords: KEYWORD_1 KEYWORD_2 KEYWORD_3 19 | upstream-version: VERSION 20 | upstream-url: URL 21 | documentation-url: URL 22 | bug-url: URL 23 | license: CANONICAL_LICENSE_NAME 24 | platform: SML_PLATFORM 25 | build: COMMAND 26 | test: COMMAND 27 | install: COMMAND 28 | uninstall: COMMAND 29 | documentation: COMMAND 30 | 31 | See https://github.com/standardml/smackage/wiki/Smackspec for more 32 | information. Please note that the parser is rather lax at the moment; it 33 | will accept url values that aren't really URLs, etc. This will likely 34 | change in the future. 35 | *) 36 | 37 | structure SemVerDict = ListDict (structure Key = SemVer) 38 | structure SemConstrDict = 39 | ListDict 40 | (structure Key = 41 | struct 42 | type t = SemVer.constraint 43 | val compare = SemVer.compareConstr 44 | end) 45 | structure StringDict = 46 | ListDict 47 | (structure Key = struct type t = string val compare = String.compare end) 48 | 49 | signature SPEC = 50 | sig 51 | exception SpecError of string 52 | 53 | datatype spec_entry = 54 | Provides of string * SemVer.semver 55 | | Description of string 56 | | Requires of string * SemVer.constraint * SemVer.semver option 57 | | Maintainer of string 58 | | Remote of Protocol.protocol 59 | | License of string 60 | | Platform of string 61 | | Key of string * string 62 | 63 | type spec = spec_entry list 64 | 65 | (* Parse a smackspec file (every line should be an empty string or a valid 66 | * spec_entry, such as one would get from FSUtil.getLines) *) 67 | val parse: string list -> spec 68 | val fromFile: string -> spec 69 | val toString: spec -> string 70 | 71 | (* Interprets the spec as a packages file, get the requirements *) 72 | val key: spec -> string -> string list 73 | val platforms: spec -> (string * spec) list 74 | val provides: spec -> string * SemVer.semver 75 | val remote: spec -> Protocol.protocol 76 | val requires: 77 | spec -> (string * SemVer.constraint * SemVer.semver option) list 78 | 79 | (* Interprests a series of specs as a versions.smackspec file *) 80 | val toVersionIndex: 81 | spec list -> Protocol.protocol SemVerDict.dict StringDict.dict 82 | end 83 | 84 | 85 | structure Spec:> SPEC = 86 | struct 87 | exception SpecError of string 88 | 89 | datatype spec_entry = 90 | Provides of string * SemVer.semver 91 | | Description of string 92 | | Requires of string * SemVer.constraint * SemVer.semver option 93 | | Maintainer of string 94 | | Remote of Protocol.protocol 95 | | License of string 96 | | Platform of string 97 | | Key of string * string (* We just push all the unused keys in here *) 98 | 99 | type spec = spec_entry list 100 | 101 | (* Like String.fields, but split at most once *) 102 | fun splitOnce delim s = 103 | case CharVector.findi (fn (_, c) => c = delim) s of 104 | NONE => (s, NONE) 105 | | SOME (i, _) => 106 | (String.extract (s,0,SOME i), SOME (String.extract (s,i+1,NONE))) 107 | 108 | fun parsePackage s = 109 | case String.tokens Char.isSpace s of 110 | [pkg, ver] => (pkg, SemVer.fromString ver) 111 | | _ => raise SpecError ("Invalid 'provides:' content: `" ^ s ^ "'") 112 | 113 | fun parseRequires s = 114 | case String.tokens Char.isSpace s of 115 | [pkg, con] => (pkg, SemVer.constrFromString con, NONE) 116 | | [pkg, con, min] => 117 | if #"(" = String.sub (min, 0) 118 | andalso #")" = String.sub (min, size min - 1) 119 | then ( pkg 120 | , SemVer.constrFromString con 121 | , SOME (SemVer.fromString 122 | (String.substring (min, 1, size min - 2)))) 123 | else raise SpecError ("Invalid minimal version: `" ^ min ^ "'") 124 | | _ => raise SpecError ("Invalid 'requires:' content: `" ^ s ^ "'") 125 | 126 | fun parseLine "" = NONE 127 | | parseLine line = 128 | let 129 | val (key, value) = 130 | case splitOnce #":" line of 131 | (key, SOME value) => (key, value) 132 | | _ => raise SpecError ("Malformed line in spec: `" ^ line ^ "'") 133 | val () = 134 | if CharVector.all (fn c => Char.isAlphaNum c orelse c = #"-") key 135 | then () 136 | else raise SpecError ("Invalid key in spec: `"^key^"'") 137 | in case (key,value) of 138 | ("provides",v) => SOME (Provides (parsePackage v)) 139 | | ("description",v) => SOME (Description v) 140 | | ("requires",v) => SOME (Requires (parseRequires v)) 141 | | ("maintainer",v) => SOME (Maintainer v) 142 | | ("remote",v) => SOME (Remote (Protocol.fromString v)) 143 | | ("license",v) => SOME (License v) 144 | | ("platform",v) => SOME (Platform v) 145 | | (k,v) => SOME (Key (k,v)) 146 | end 147 | 148 | fun parse lines = List.mapPartial parseLine lines 149 | 150 | val fromFile = parse o FSUtil.getCleanLines o TextIO.openIn 151 | 152 | fun toString' (Provides (s,v)) = 153 | "provides: " ^ s ^ " " ^ SemVer.toString v 154 | | toString' (Description s) = 155 | "description: " ^ s 156 | | toString' (Requires (p,v,min)) = 157 | ( "requires: " ^ p ^ " " ^ SemVer.constrToString v 158 | ^ (case min of NONE => "" | SOME v => "(" ^ SemVer.toString v ^ ")")) 159 | | toString' (Maintainer s) = 160 | "maintainer: " ^ s 161 | | toString' (Remote p) = 162 | "remote: " ^ Protocol.toString p 163 | | toString' (License s) = 164 | "license: " ^ s 165 | | toString' (Platform s) = 166 | "platform: " ^ s 167 | | toString' (Key (k,v)) = k ^ ": " ^ v 168 | 169 | fun toString spec = String.concatWith "\n" (map toString' spec) 170 | 171 | (* Helper functions *) 172 | 173 | fun key s key = 174 | let fun key' (key', v) = if key = key' then SOME v else NONE 175 | in 176 | List.mapPartial (fn (Key kv) => key' kv | _ => NONE) s 177 | end 178 | 179 | fun provides s = 180 | case List.mapPartial (fn (Provides v) => SOME v | _ => NONE) s of 181 | [] => raise SpecError "Missing `provides:' line in spec" 182 | | [ v ] => v 183 | | _ => raise SpecError "Multiple `provides:' lines in spec" 184 | 185 | fun platforms [] = [] 186 | | platforms (Platform p :: t) = 187 | let 188 | fun loop [] s accum plats = rev ((s, rev accum) :: plats) 189 | | loop (Platform p :: t) s accum plats = 190 | loop t p [] ((s, rev accum) :: plats) 191 | | loop (h :: t) s accum plats = 192 | loop t s (h :: accum) plats 193 | in 194 | loop t p [] [] 195 | end 196 | | platforms (h::t) = platforms t 197 | 198 | fun remote s = 199 | case List.mapPartial (fn (Remote v) => SOME v | _ => NONE) s of 200 | [] => raise SpecError "Missing `remote:' line in spec" 201 | | [ v ] => v 202 | | _ => raise SpecError "Multiple `remote:' lines in spec" 203 | 204 | val requires = 205 | List.mapPartial (fn (Requires v) => SOME v | _ => NONE) 206 | 207 | fun toVersionIndex (spec: spec list) = 208 | let 209 | fun folder (spec, dict) = 210 | let 211 | val remote = remote spec 212 | val provides = 213 | List.mapPartial (fn (Provides v) => SOME v | _ => NONE) spec 214 | in 215 | List.foldr 216 | (fn ((pkg, semver), dict) => 217 | StringDict.insertMerge dict pkg 218 | (SemVerDict.singleton semver remote) 219 | (fn dict => SemVerDict.insert dict semver remote)) 220 | dict 221 | provides 222 | end 223 | in 224 | List.foldl folder StringDict.empty spec 225 | end 226 | end 227 | -------------------------------------------------------------------------------- /src/version-index.smi: -------------------------------------------------------------------------------- 1 | _require "basis.smi" 2 | _require "protocol.smi" 3 | _require "semver.smi" 4 | _require "spec.smi" 5 | _require "fsutil.smi" 6 | 7 | structure VersionIndex = 8 | struct 9 | (* Initialization, expects the value of $SMACKAGE_HOME, where the 10 | * file versions.smackspec already exists. *) 11 | val init: string -> unit 12 | 13 | (* Do we know anything about this package? *) 14 | val isKnown: string -> bool 15 | 16 | (* How do we obtain this (version of this) package? *) 17 | val getProtocol: string -> SemVer.semver -> Protocol.protocol option 18 | 19 | (* Query for versions of packages (straightforwardly and heuristicly) *) 20 | val getAll: 21 | string -> SemVer.constraint option -> SemVer.semver list 22 | val getLatest: 23 | string -> SemVer.constraint option -> SemVer.constraint * SemVer.semver 24 | val getBest: 25 | string -> SemVer.constraint option -> SemVer.constraint * SemVer.semver 26 | 27 | (* Rough search for a package name *) 28 | val search : string -> (string * Protocol.protocol SemVerDict.dict) list 29 | end 30 | 31 | -------------------------------------------------------------------------------- /src/version-index.sml: -------------------------------------------------------------------------------- 1 | (* Interface to the stored $SMACKAGE_HOME/versions.smackspec file *) 2 | 3 | structure VersionIndex:> 4 | sig 5 | (* Initialization, expects the value of $SMACKAGE_HOME, where the 6 | * file versions.smackspec already exists. *) 7 | val init: string -> unit 8 | 9 | (* Do we know anything about this package? *) 10 | val isKnown: string -> bool 11 | 12 | (* How do we obtain this (version of this) package? *) 13 | val getProtocol: string -> SemVer.semver -> Protocol.protocol option 14 | 15 | (* Query for versions of packages (straightforwardly and heuristicly) *) 16 | val getAll: 17 | string -> SemVer.constraint option -> SemVer.semver list 18 | val getLatest: 19 | string -> SemVer.constraint option -> SemVer.constraint * SemVer.semver 20 | val getBest: 21 | string -> SemVer.constraint option -> SemVer.constraint * SemVer.semver 22 | 23 | (* Rough search for a package name *) 24 | val search : string -> (string * Protocol.protocol SemVerDict.dict) list 25 | end = 26 | struct 27 | fun // (dir, file) = OS.Path.joinDirFile { dir = dir, file = file } 28 | infix 5 // 29 | 30 | val versionIndex: Protocol.protocol SemVerDict.dict StringDict.dict ref = 31 | ref StringDict.empty 32 | 33 | fun init smackage_root = 34 | let 35 | val specstanzas = 36 | FSUtil.getStanzas 37 | (TextIO.openIn (smackage_root // "versions.smackspec")) 38 | in 39 | versionIndex := Spec.toVersionIndex (map Spec.parse specstanzas) 40 | end 41 | 42 | fun isKnown pkg = StringDict.member (!versionIndex) pkg 43 | 44 | fun queryVersions pkg = 45 | case StringDict.find (!versionIndex) pkg of 46 | NONE => [] 47 | | SOME dict => SemVerDict.domain dict 48 | 49 | fun getProtocol pkg ver = 50 | Option.mapPartial (fn dict => SemVerDict.find dict ver) 51 | (StringDict.find (!versionIndex) pkg) 52 | 53 | fun name pkg NONE = pkg 54 | | name pkg (SOME spec) = pkg ^ " " ^ SemVer.constrToString spec 55 | 56 | fun getAll pkg NONE = queryVersions pkg 57 | | getAll pkg (SOME spec) = 58 | List.filter (SemVer.satisfies spec) (queryVersions pkg) 59 | 60 | fun getLatest pkg constraint = 61 | let 62 | val cand = queryVersions pkg 63 | val cand' = 64 | case constraint of 65 | NONE => cand 66 | | SOME spec => List.filter (SemVer.satisfies spec) cand 67 | val () = if length cand > 0 then () 68 | else raise Fail ("Could not satisfy constraint `" 69 | ^ name pkg constraint ^ "`") 70 | val best = 71 | List.foldl (fn (v,v') => if SemVer.>(v,v') then v else v') 72 | (hd cand) cand 73 | in 74 | ( (case constraint of NONE => SemVer.major best | SOME spec => spec) 75 | , best) 76 | end 77 | 78 | fun getBest pkg constraint = 79 | let in 80 | case SemVer.intelligentSelect constraint (queryVersions pkg) of 81 | NONE => raise Fail ("Could not satisfy constraint `" 82 | ^ name pkg constraint ^ "`") 83 | | SOME (ver, spec) => (ver, spec) 84 | end 85 | 86 | fun search query = 87 | List.filter 88 | (fn (pkg, versions) => String.isSubstring query pkg) 89 | (StringDict.toList (!versionIndex)) 90 | end 91 | 92 | -------------------------------------------------------------------------------- /src/version.smi: -------------------------------------------------------------------------------- 1 | (* Generated by version.sh *) 2 | structure Version = 3 | struct 4 | val version: string 5 | end 6 | 7 | -------------------------------------------------------------------------------- /src/version.sml: -------------------------------------------------------------------------------- 1 | (* Generated by version.sh *) 2 | structure Version = 3 | struct 4 | val version = "1.4.5" 5 | end 6 | 7 | -------------------------------------------------------------------------------- /util/README: -------------------------------------------------------------------------------- 1 | Smackage would eventually like to enjoy the bounty of smackage itself - being 2 | able to rely on other sources of library code! But unless we're distributing 3 | binaries, this leads to a problematic bootstrapping problem. This directory is 4 | where we put code that we should be able to get via smackage someday, mostly 5 | taken from CMlib. -------------------------------------------------------------------------------- /util/dict-list.smi: -------------------------------------------------------------------------------- 1 | _require "basis.smi" 2 | _require "dict.sig" 3 | 4 | functor ListDict (X: sig structure Key : sig type t val compare: t * t -> order end end) 5 | = 6 | struct 7 | 8 | type key = X.Key.t 9 | type 'a dict(=boxed) 10 | 11 | exception Absent 12 | 13 | val empty : 'a dict 14 | val singleton : key -> 'a -> 'a dict 15 | val insert : 'a dict -> key -> 'a -> 'a dict 16 | val remove : 'a dict -> key -> 'a dict 17 | val find : 'a dict -> key -> 'a option 18 | val lookup : 'a dict -> key -> 'a 19 | val union : 'a dict -> 'a dict -> (key * 'a * 'a -> 'a) -> 'a dict 20 | 21 | val operate : 'a dict -> key -> (unit -> 'a) -> ('a -> 'a) -> 'a option * 'a * 'a dict 22 | val insertMerge : 'a dict -> key -> 'a -> ('a -> 'a) -> 'a dict 23 | 24 | val isEmpty : 'a dict -> bool 25 | val member : 'a dict -> key -> bool 26 | val size : 'a dict -> int 27 | 28 | val toList : 'a dict -> (key * 'a) list 29 | val domain : 'a dict -> key list 30 | val map : ('a -> 'b) -> 'a dict -> 'b dict 31 | val foldl : (key * 'a * 'b -> 'b) -> 'b -> 'a dict -> 'b 32 | val foldr : (key * 'a * 'b -> 'b) -> 'b -> 'a dict -> 'b 33 | val app : (key * 'a -> unit) -> 'a dict -> unit 34 | 35 | end 36 | -------------------------------------------------------------------------------- /util/dict-list.sml: -------------------------------------------------------------------------------- 1 | 2 | functor ListDict (structure Key : sig type t val compare: t * t -> order end) 3 | :> DICT where type key = Key.t 4 | = 5 | struct 6 | 7 | type key = Key.t 8 | type 'a dict = (key * 'a) list 9 | 10 | exception Absent 11 | 12 | val empty = [] 13 | 14 | val isEmpty = null 15 | 16 | fun singleton key x = [(key, x)] 17 | 18 | fun insert l key x = 19 | (case l of 20 | [] => [(key, x)] 21 | | (key', y) :: rest => 22 | (case Key.compare (key, key') of 23 | LESS => 24 | (key, x) :: l 25 | | EQUAL => 26 | (key, x) :: rest 27 | | GREATER => 28 | (key', y) :: insert rest key x)) 29 | 30 | fun remove l key = 31 | (case l of 32 | [] => [] 33 | | (key', y) :: rest => 34 | (case Key.compare (key, key') of 35 | LESS => l 36 | | EQUAL => rest 37 | | GREATER => 38 | (key', y) :: remove rest key)) 39 | 40 | fun operate l key absentf presentf = 41 | (case l of 42 | [] => 43 | let 44 | val x = absentf () 45 | in 46 | (NONE, x, [(key, x)]) 47 | end 48 | | (key', y) :: rest => 49 | (case Key.compare (key, key') of 50 | LESS => 51 | let 52 | val x = absentf () 53 | in 54 | (NONE, x, (key, x) :: l) 55 | end 56 | | EQUAL => 57 | let 58 | val x = presentf y 59 | in 60 | (SOME y, x, (key, x) :: rest) 61 | end 62 | | GREATER => 63 | let 64 | val (ante, post, rest') = operate rest key absentf presentf 65 | in 66 | (ante, post, (key', y) :: rest') 67 | end)) 68 | 69 | fun insertMerge dict key x f = 70 | #3 (operate dict key (fn () => x) f) 71 | 72 | fun find l key = 73 | (case l of 74 | [] => 75 | NONE 76 | | (key', x) :: rest => 77 | (case Key.compare (key, key') of 78 | LESS => 79 | NONE 80 | | EQUAL => 81 | SOME x 82 | | GREATER => 83 | find rest key)) 84 | 85 | fun lookup l key = 86 | (case l of 87 | [] => 88 | raise Absent 89 | | (key', x) :: rest => 90 | (case Key.compare (key, key') of 91 | LESS => 92 | raise Absent 93 | | EQUAL => 94 | x 95 | | GREATER => 96 | lookup rest key)) 97 | 98 | fun member l key = 99 | (case l of 100 | [] => 101 | false 102 | | (key', _) :: rest => 103 | (case Key.compare (key, key') of 104 | LESS => 105 | false 106 | | EQUAL => 107 | true 108 | | GREATER => 109 | member rest key)) 110 | 111 | val size = length 112 | 113 | fun union l1 l2 f = 114 | (case (l1, l2) of 115 | ([], _) => 116 | l2 117 | | (_, []) => 118 | l1 119 | | ((entry1 as (key1, x1)) :: rest1, (entry2 as (key2, x2)) :: rest2) => 120 | (case Key.compare (key1, key2) of 121 | LESS => 122 | entry1 :: union rest1 l2 f 123 | | GREATER => 124 | entry2 :: union l1 rest2 f 125 | | EQUAL => 126 | (key1, f (key1, x1, x2)) :: union rest1 rest2 f)) 127 | 128 | fun toList l = l 129 | 130 | fun domain l = List.map (fn (key, _) => key) l 131 | 132 | fun map f l = List.map (fn (key, x) => (key, f x)) l 133 | 134 | fun foldl f base l = List.foldl (fn ((key, x), y) => f (key, x, y)) base l 135 | 136 | fun foldr f base l = List.foldr (fn ((key, x), y) => f (key, x, y)) base l 137 | 138 | val app = List.app 139 | 140 | end 141 | -------------------------------------------------------------------------------- /util/dict.sig: -------------------------------------------------------------------------------- 1 | 2 | signature DICT = 3 | sig 4 | 5 | type key 6 | type 'a dict 7 | 8 | exception Absent 9 | 10 | val empty : 'a dict 11 | val singleton : key -> 'a -> 'a dict 12 | val insert : 'a dict -> key -> 'a -> 'a dict 13 | val remove : 'a dict -> key -> 'a dict 14 | val find : 'a dict -> key -> 'a option 15 | val lookup : 'a dict -> key -> 'a 16 | val union : 'a dict -> 'a dict -> (key * 'a * 'a -> 'a) -> 'a dict 17 | 18 | val operate : 'a dict -> key -> (unit -> 'a) -> ('a -> 'a) -> 'a option * 'a * 'a dict 19 | val insertMerge : 'a dict -> key -> 'a -> ('a -> 'a) -> 'a dict 20 | 21 | val isEmpty : 'a dict -> bool 22 | val member : 'a dict -> key -> bool 23 | val size : 'a dict -> int 24 | 25 | val toList : 'a dict -> (key * 'a) list 26 | val domain : 'a dict -> key list 27 | val map : ('a -> 'b) -> 'a dict -> 'b dict 28 | val foldl : (key * 'a * 'b -> 'b) -> 'b -> 'a dict -> 'b 29 | val foldr : (key * 'a * 'b -> 'b) -> 'b -> 'a dict -> 'b 30 | val app : (key * 'a -> unit) -> 'a dict -> unit 31 | 32 | end 33 | -------------------------------------------------------------------------------- /util/sort.smi: -------------------------------------------------------------------------------- 1 | _require "basis.smi" 2 | 3 | structure InsertionSort = 4 | struct 5 | val sort: ('a * 'a -> order) -> 'a list -> 'a list 6 | end 7 | -------------------------------------------------------------------------------- /util/sort.sml: -------------------------------------------------------------------------------- 1 | 2 | signature SORT = 3 | sig 4 | val sort: ('a * 'a -> order) -> 'a list -> 'a list 5 | end 6 | 7 | (* Not totally stupid. We're mostly re-sorting mostly sorted lists, and this 8 | * implementation should be O(n) in that case. *) 9 | structure InsertionSort:> SORT = 10 | struct 11 | fun sort compare = 12 | let 13 | (* Insert takes a reverse-sorted list and inserts x into it. *) 14 | fun insert x [] = [ x ] 15 | | insert x (y :: ys) = 16 | (case compare (x, y) of 17 | LESS => y :: insert x ys 18 | | _ => x :: y :: ys) 19 | 20 | fun loop sorted [] = rev sorted 21 | | loop sorted (x :: unsorted) = loop (insert x sorted) unsorted 22 | in 23 | loop [] 24 | end 25 | end 26 | -------------------------------------------------------------------------------- /util/sources.cm: -------------------------------------------------------------------------------- 1 | Group is 2 | $/basis.cm 3 | sort.sml 4 | dict.sig 5 | dict-list.sml 6 | -------------------------------------------------------------------------------- /util/sources.mlb: -------------------------------------------------------------------------------- 1 | 2 | $(SML_LIB)/basis/basis.mlb 3 | sort.sml 4 | dict.sig 5 | dict-list.sml 6 | 7 | -------------------------------------------------------------------------------- /version.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | # version.sh 4 | # 5 | # Generates src/version.sml and smackage.smackspec based on the current version 6 | # Usage: version.sh X.Y.Z 7 | # gdpe, Nov 2 2011 8 | 9 | if [ $# -ne 1 ] 10 | then 11 | echo "Usage: version.sh X.Y.Z" 12 | exit 1 13 | fi 14 | 15 | 16 | cat smackage.smackspec.in | sed "s/###VERSION###/$1/" > smackage.smackspec 17 | echo "(* Generated by version.sh *)\n\ 18 | structure Version = \n\ 19 | struct\n\ 20 | val version = \"$1\"\n\ 21 | end\n" > src/version.sml 22 | 23 | echo "Generated files." 24 | echo "Now run 'git commit -a -m \"bump to v$1\"; git tag v$1'" 25 | 26 | --------------------------------------------------------------------------------