diff options
| author | 2019-06-01 10:38:28 -0400 | |
|---|---|---|
| committer | 2019-06-01 10:38:28 -0400 | |
| commit | 3d76d988c308de2fbcd4e35182a89c7bf6760623 (patch) | |
| tree | b2af212c6f4d2a2662adaeedd943922122427aa4 /tools | |
| parent | Hint utf8 output on windows console. (diff) | |
More work on installation and moving files around.
Move all installed libraries into auxlib.
Move all installed executable scripts into auxbin.
Diffstat (limited to 'tools')
| -rw-r--r-- | tools/bars.janet | 55 | ||||
| -rw-r--r-- | tools/cook.janet | 368 | ||||
| -rw-r--r-- | tools/highlight.janet | 198 | ||||
| -rwxr-xr-x | tools/jpm | 41 |
4 files changed, 0 insertions, 662 deletions
diff --git a/tools/bars.janet b/tools/bars.janet deleted file mode 100644 index c0e4d3fd..00000000 --- a/tools/bars.janet +++ /dev/null @@ -1,55 +0,0 @@ -# A flexible templater for janet. Compiles -# templates to janet functions that produce buffers. - -(defn template - "Compile a template string into a function" - [source] - - # State for compilation machine - (def p (parser/new)) - (def forms @[]) - - (defn parse-chunk - "Parse a string and push produced values to forms." - [chunk] - (parser/consume p chunk) - (while (parser/has-more p) - (array/push forms (parser/produce p))) - (if (= :error (parser/status p)) - (error (parser/error p)))) - - (defn code-chunk - "Parse all the forms in str and return them - in a tuple prefixed with 'do." - [str] - (parse-chunk str) - true) - - (defn string-chunk - "Insert string chunk into parser" - [str] - (parser/insert p str) - (parse-chunk "") - true) - - # Run peg - (def grammar - ~{:code-chunk (* "{%" (drop (cmt '(any (if-not "%}" 1)) ,code-chunk)) "%}") - :main-chunk (drop (cmt '(any (if-not "{%" 1)) ,string-chunk)) - :main (any (+ :code-chunk :main-chunk (error "")))}) - (def parts (peg/match grammar source)) - - # Check errors in template and parser - (unless parts (error "invalid template syntax")) - (parse-chunk "\n") - (case (parser/status p) - :pending (error (string "unfinished parser state " (parser/state p))) - :error (error (parser/error p))) - - # Make ast from forms - (def ast ~(fn [&opt params] (default params @{}) (,buffer ,;forms))) - - (def ctor (compile ast (fiber/getenv (fiber/current)) source)) - (if-not (function? ctor) - (error (string "could not compile template"))) - (ctor)) diff --git a/tools/cook.janet b/tools/cook.janet deleted file mode 100644 index 173578f4..00000000 --- a/tools/cook.janet +++ /dev/null @@ -1,368 +0,0 @@ -### cook.janet -### -### Library to help build janet natives and other -### build artifacts. -### -### Copyright 2019 © Calvin Rose - -# -# Basic Path Settings -# - -# Windows is the OS outlier -(def- is-win (= (os/which) :windows)) -(def- is-mac (= (os/which) :macos)) -(def- sep (if is-win "\\" "/")) -(def- objext (if is-win ".obj" ".o")) -(def- modext (if is-win ".dll" ".so")) - -# -# Rule Engine -# - -(defn- getrules [] - (def rules (dyn :rules)) - (if rules rules (setdyn :rules @{}))) - -(defn- gettarget [target] - (def item ((getrules) target)) - (unless item (error (string "No rule for target " target))) - item) - -(defn- rule-impl - [target deps thunk &opt phony] - (put (getrules) target @[(array/slice deps) thunk phony])) - -(defmacro rule - "Add a rule to the rule graph." - [target deps & body] - ~(,rule-impl ,target ,deps (fn [] nil ,;body))) - -(defmacro phony - "Add a phony rule to the rule graph. A phony rule will run every time - (it is always considered out of date). Phony rules are good for defining - user facing tasks." - [target deps & body] - ~(,rule-impl ,target ,deps (fn [] nil ,;body) true)) - -(defn add-dep - "Add a dependency to an existing rule. Useful for extending phony - rules or extending the dependency graph of existing rules." - [target dep] - (def [deps] (gettarget target)) - (array/push deps dep)) - -(defn- add-thunk - [target more] - (def item (gettarget target)) - (def [_ thunk] item) - (put item 1 (fn [] (more) (thunk)))) - -(defmacro add-body - "Add recipe code to an existing rule. This makes existing rules do more but - does not modify the dependency graph." - [target & body] - ~(,add-thunk ,target (fn [] ,;body))) - -(defn- needs-build - [dest src] - (let [mod-dest (os/stat dest :modified) - mod-src (os/stat src :modified)] - (< mod-dest mod-src))) - -(defn- needs-build-some - [dest sources] - (def f (file/open dest)) - (if (not f) (break true)) - (file/close f) - (some (partial needs-build dest) sources)) - -(defn do-rule - "Evaluate a given rule." - [target] - (def item ((getrules) target)) - (unless item - (if (os/stat target :mode) - (break target) - (error (string "No rule for file " target " found.")))) - (def [deps thunk phony] item) - (def realdeps (seq [dep :in deps :let [x (do-rule dep)] :when x] x)) - (when (or phony (needs-build-some target realdeps)) - (thunk)) - (unless phony target)) - -(def- _env (fiber/getenv (fiber/current))) -(defn- import-rules* - [path & args] - (def [realpath] (module/find path)) - (def env (make-env)) - (loop [k :keys _env :when (symbol? k)] - (unless ((_env k) :private) (put env k (_env k)))) - (def currenv (fiber/getenv (fiber/current))) - (loop [k :keys currenv :when (keyword? k)] - (put env k (currenv k))) - (require path :env env ;args) - (when-let [rules (env :rules)] (merge-into (getrules) rules))) - -(defmacro import-rules - "Import another file that defines more cook rules. This ruleset - is merged into the current ruleset." - [path & args] - ~(,import-rules* ,(string path) ,;args)) - -# -# Configuration -# - -# Installation settings -(def JANET_MODPATH (or (os/getenv "JANET_MODPATH") module/*syspath*)) -(def JANET_HEADERPATH (or (os/getenv "JANET_HEADERPATH") module/*headerpath*)) -(def JANET_BINPATH (or (os/getenv "JANET_BINPATH") (unless is-win "/usr/local/bin"))) - -# Compilation settings -(def OPTIMIZE (or (os/getenv "OPTIMIZE") 2)) -(def CC (or (os/getenv "CC") (if is-win "cl" "cc"))) -(def LD (or (os/getenv "LINKER") (if is-win "link" CC))) -(def LDFLAGS (or (os/getenv "LFLAGS") - (if is-win " /nologo" - (string " -shared" - (if is-mac " -undefined dynamic_lookup" ""))))) -(def CFLAGS (or (os/getenv "CFLAGS") (if is-win "" " -std=c99 -Wall -Wextra -fpic"))) - -(defn- opt - "Get an option, allowing overrides via dynamic bindings AND some - default value dflt if no dynamic binding is set." - [opts key dflt] - (def ret (or (opts key) (dyn key dflt))) - (if (= nil ret) - (error (string "option :" key " not set"))) - ret) - -# -# OS and shell helpers -# - -(defn shell - "Do a shell command" - [& args] - (def cmd (string/join args)) - (print cmd) - (def res (os/shell cmd)) - (unless (zero? res) - (error (string "command exited with status " res)))) - -(defn rm - "Remove a directory and all sub directories." - [path] - (if (= (os/stat path :mode) :directory) - (do - (each subpath (os/dir path) - (rm (string path sep subpath))) - (os/rmdir path)) - (os/rm path))) - -(defn copy - "Copy a file or directory recursively from one location to another." - [src dest] - (shell (if is-win "xcopy " "cp -rf ") `"` src `" "` dest (if is-win `" /y /e` `"`))) - -# -# C Compilation -# - -(defn- embed-name - "Rename a janet symbol for embedding." - [path] - (->> path - (string/replace-all sep "___") - (string/replace-all ".janet" ""))) - -(defn- embed-c-name - "Rename a janet file for embedding." - [path] - (->> path - (string/replace-all sep "___") - (string/replace-all ".janet" ".janet.c") - (string "build" sep))) - -(defn- embed-o-name - "Get object file for c file." - [path] - (->> path - (string/replace-all sep "___") - (string/replace-all ".janet" (string ".janet" objext)) - (string "build" sep))) - -(defn- object-name - "Rename a source file so it can be built in a flat source tree." - [path] - (->> path - (string/replace-all sep "___") - (string/replace-all ".c" (if is-win ".obj" ".o")) - (string "build" sep))) - -(defn- lib-name - "Generate name for dynamic library." - [name] - (string "build" sep name modext)) - -(defn- make-define - "Generate strings for adding custom defines to the compiler." - [define value] - (def pre (if is-win "/D" "-D")) - (if value - (string pre define "=" value) - (string pre define))) - -(defn- make-defines - "Generate many defines. Takes a dictionary of defines. If a value is - true, generates -DNAME (/DNAME on windows), otherwise -DNAME=value." - [defines] - (seq [[d v] :pairs defines] (make-define d (if (not= v true) v)))) - -(defn- getcflags - "Generate the c flags from the input options." - [opts] - (string (opt opts :cflags CFLAGS) - (if is-win " /I\"" " \"-I") - (opt opts :headerpath JANET_HEADERPATH) - `"` - (if is-win " /O\"" " \"-O") - (opt opts :optimize OPTIMIZE) - `"`)) - -(defn- compile-c - "Compile a C file into an object file." - [opts src dest] - (def cc (opt opts :compiler CC)) - (def cflags (getcflags opts)) - (def defines (interpose " " (make-defines (opt opts :defines {})))) - (rule dest [src] - (if is-win - (shell cc " " ;defines " /nologo /c " cflags " /Fo\"" dest `" "` src `"`) - (shell cc " -c '" src "' " ;defines " " cflags " -o '" dest `'`)))) - -(defn- link-c - "Link a number of object files together." - [opts target & objects] - (def ld (opt opts :linker LD)) - (def cflags (getcflags opts)) - (def lflags (opt opts :lflags LDFLAGS)) - (def olist (string/join objects `" "`)) - (rule target objects - (if is-win - (shell ld " " lflags " /DLL /OUT:" target ` "` olist `" "` (opt opts :headerpath JANET_HEADERPATH) `"\\janet.lib`) - (shell ld " " cflags ` -o "` target `" "` olist `" ` lflags)))) - -(defn- create-buffer-c - "Inline raw byte file as a c file." - [source dest name] - (rule dest [source] - (def f (file/open source :r)) - (if (not f) (error (string "file " f " not found"))) - (def out (file/open dest :w)) - (def chunks (seq [b :in (file/read f :all)] (string b))) - (file/write out - "#include <janet.h>\n" - "static const unsigned char bytes[] = {" - ;(interpose ", " chunks) - "};\n\n" - "const unsigned char *" name "_embed = bytes;\n" - "size_t " name "_embed_size = sizeof(bytes);\n") - (file/close out) - (file/close f))) - -# -# Declaring Artifacts - used in project.janet, targets specifically -# tailored for janet. -# - -(defn- install-rule - "Add install and uninstall rule for moving file from src into destdir." - [src destdir] - (def parts (string/split sep src)) - (def name (last parts)) - (add-body "install" - (try (os/mkdir destdir) ([err] nil)) - (copy src destdir)) - (add-body "uninstall" - (def path (string destdir sep name)) - (print "removing " path) - (try (rm path) ([err] - (unless (= err "No such file or directory") - (error err)))))) - -(defn declare-native - "Declare a native binary. This is a shared library that can be loaded - dynamically by a janet runtime." - [&keys opts] - (def sources (opts :source)) - (def name (opts :name)) - (def lname (lib-name name)) - (loop [src :in sources] - (compile-c opts src (object-name src))) - (def objects (map object-name sources)) - (when-let [embedded (opts :embedded)] - (loop [src :in embedded] - (def c-src (embed-c-name src)) - (def o-src (embed-o-name src)) - (array/push objects o-src) - (create-buffer-c src c-src (embed-name src)) - (compile-c opts c-src o-src))) - (link-c opts lname ;objects) - (add-dep "build" lname) - (def path (opt opts :modpath JANET_MODPATH)) - (install-rule lname path)) - -(defn declare-source - "Create a Janet modules. This does not actually build the module(s), - but registers it for packaging and installation." - [&keys opts] - (def sources (opts :source)) - (def path (opt opts :modpath JANET_MODPATH)) - (each s sources - (install-rule s path))) - -(defn declare-binscript - "Declare a janet file to be installed as an executable script." - [&keys opts] - (def main (opts :main)) - (def binpath (opt opts :binpath JANET_BINPATH)) - (install-rule main binpath)) - -(defn declare-archive - "Build a janet archive. This is a file that bundles together many janet - scripts into a janet image. This file can the be moved to any machine with - a janet vm and the required dependencies and run there." - [&keys opts] - (def entry (opts :entry)) - (def name (opts :name)) - (def iname (string "build" sep name ".jimage")) - (rule iname (or (opts :deps) []) - (spit iname (make-image (require entry)))) - (def path (opt opts :modpath JANET_MODPATH)) - (install-rule iname path)) - -(defn declare-project - "Define your project metadata. This should - be the first declaration in a project.janet file. - Also sets up basic phony targets like clean, build, test, etc." - [&keys meta] - (setdyn :project meta) - (try (os/mkdir "build") ([err] nil)) - (phony "build" []) - (phony "install" ["build"] (print "Installed.")) - (phony "uninstall" [] (print "Uninstalled.")) - (phony "clean" [] (rm "build") (print "Deleted build directory.")) - (phony "test" ["build"] - (defn dodir - [dir] - (each sub (os/dir dir) - (def ndir (string dir sep sub)) - (case (os/stat ndir :mode) - :file (when (string/has-suffix? ".janet" ndir) - (print "running " ndir " ...") - (dofile ndir :exit true)) - :directory (dodir ndir)))) - (dodir "test") - (print "All tests passed."))) diff --git a/tools/highlight.janet b/tools/highlight.janet deleted file mode 100644 index 95380da9..00000000 --- a/tools/highlight.janet +++ /dev/null @@ -1,198 +0,0 @@ -# Copyright (C) Calvin Rose 2019 -# -# Takes in a janet string and colorizes for multiple -# output formats. - -# Constants for checking if symbols should be -# highlighted. -(def- core-env (table/getproto *env*)) -(def- specials {'fn true - 'var true - 'do true - 'while true - 'def true - 'splice true - 'set true - 'break true - 'unquote true - 'quasiquote true - 'quote true - 'if true}) - -(defn check-number [text] (and (scan-number text) text)) - -(defn- make-grammar - "Creates the grammar based on the paint function, which - colorizes fragments of text." - [paint] - - (defn <-c - "Peg rule for capturing and coloring a rule." - [color what] - ~(/ (<- ,what) ,(partial paint color))) - - (defn color-symbol - "Color a symbol only if it is a core library binding or special." - [text] - (def sym (symbol text)) - (def should-color (or (specials sym) (core-env sym))) - (paint (if should-color :coresym :symbol) text)) - - ~{:ws (set " \t\r\f\n\v\0") - :readermac (set "';~,") - :symchars (+ (range "09" "AZ" "az" "\x80\xFF") (set "!$%&*+-./:<?=>@^_|")) - :token (some :symchars) - :hex (range "09" "af" "AF") - :escape (* "\\" (+ (set "ntrvzf0\"\\e") - (* "x" :hex :hex) - (error (constant "bad hex escape")))) - - :comment ,(<-c :comment ~(* "#" (any (if-not (+ "\n" -1) 1)))) - - :symbol (/ ':token ,color-symbol) - :keyword ,(<-c :keyword ~(* ":" (any :symchars))) - :constant ,(<-c :constant ~(+ "true" "false" "nil")) - :bytes (* "\"" (any (+ :escape (if-not "\"" 1))) "\"") - :string ,(<-c :string :bytes) - :buffer ,(<-c :string ~(* "@" :bytes)) - :long-bytes {:delim (some "`") - :open (capture :delim :n) - :close (cmt (* (not (> -1 "`")) (-> :n) ':delim) ,=) - :main (drop (* :open (any (if-not :close 1)) :close))} - :long-string ,(<-c :string :long-bytes) - :long-buffer ,(<-c :string ~(* "@" :long-bytes)) - :number (/ (cmt ':token ,check-number) ,(partial paint :number)) - - :raw-value (+ :comment :constant :number :keyword - :string :buffer :long-string :long-buffer - :parray :barray :ptuple :btuple :struct :dict :symbol) - - :value (* (? '(some (+ :ws :readermac))) :raw-value '(any :ws)) - :root (any :value) - :root2 (any (* :value :value)) - :ptuple (* '"(" :root (+ '")" (error ""))) - :btuple (* '"[" :root (+ '"]" (error ""))) - :struct (* '"{" :root2 (+ '"}" (error ""))) - :parray (* '"@" :ptuple) - :barray (* '"@" :btuple) - :dict (* '"@" :struct) - - :main (+ (% :root) (error ""))}) - -# Terminal syntax highlighting - -(def- terminal-colors - {:number 32 - :keyword 33 - :string 35 - :coresym 31 - :constant 34 - :comment 36}) - -(defn- terminal-paint - "Paint colors for ansi terminals" - [what str] - (def code (get terminal-colors what)) - (if code (string "\e[" code "m" str "\e[0m") str)) - -# HTML syntax highlighting - -(def- html-colors - {:number "j-number" - :keyword "j-keyword" - :string "j-string" - :coresym "j-coresym" - :constant "j-constant" - :comment "j-comment" - :line "j-line"}) - -(def- escapes - {38 "&" - 60 "<" - 62 ">" - 34 """ - 39 "'" - 47 "/"}) - -(def html-style - "Style tag to add to a page to highlight janet code" -``` -<style type="text/css"> -.j-main { color: white; background: #111; font-size: 1.4em; } -.j-number { color: #89dc76; } -.j-keyword { color: #ffd866; } -.j-string { color: #ab90f2; } -.j-coresym { color: #ff6188; } -.j-constant { color: #fc9867; } -.j-comment { color: darkgray; } -.j-line { color: gray; } -</style> -```) - -(defn html-escape - "Escape special characters for HTML encoding." - [str] - (def buf @"") - (loop [byte :in str] - (if-let [rep (get escapes byte)] - (buffer/push-string buf rep) - (buffer/push-byte buf byte))) - buf) - -(defn- html-paint - "Paint colors for HTML" - [what str] - (def color (get html-colors what)) - (def escaped (html-escape str)) - (if color - (string "<span class=\"" color "\">" escaped "</span>") - escaped)) - -# Create Pegs - -(def- terminal-grammar (peg/compile (make-grammar terminal-paint))) -(def- html-grammar (peg/compile (make-grammar html-paint))) - -# API - -(defn ansi - "Highlight janet source code ANSI Termianl escape colors." - [source] - (0 (peg/match terminal-grammar source))) - -(defn html - "Highlight janet source code and output HTML." - [source] - (string "<pre class=\"j-main\"><code>" - (0 (peg/match html-grammar source)) - "</code></pre>")) - -(defn html-file - "Highlight a janet file and print out a highlighted HTML version - of the file. Must provide a default title when creating the file." - [in-path out-path title &] - (default title in-path) - (def f (file/open in-path :r)) - (def source (file/read f :all)) - (file/close f) - (def markup (0 (peg/match html-grammar source))) - (def out (file/open out-path :w)) - (file/write out - "<!doctype html><html><head><meta charset=\"UTF-8\">" - html-style - "<title>" - title - "</title></head>" - "<body class=\"j-main\"><pre>" - markup - "</pre></body></html>") - (file/close out)) - -(defn ansi-file - "Highlight a janet file and print the highlighted output to stdout." - [in-path] - (def f (file/open in-path :r)) - (def source (file/read f :all)) - (file/close f) - (def markup (0 (peg/match terminal-grammar source))) - (print markup)) diff --git a/tools/jpm b/tools/jpm deleted file mode 100755 index 8449f9a0..00000000 --- a/tools/jpm +++ /dev/null @@ -1,41 +0,0 @@ -#!/usr/bin/env janet - -# CLI tool for building janet projects. Wraps cook. - -(import cook) - -(def- argpeg - (peg/compile - '(* "--" '(some (if-not "=" 1)) "=" '(any 1)))) - -(defn- help - [] - (print "usage: jpm [targets]... --key=value ...") - (print "Available targets are:") - (each k (sort (keys (dyn :rules @{}))) - (print " " k)) - (print ` - -Keys are: - --modpath : The directory to install modules to. Defaults to $JANET_MODPATH or module/*syspath* - --headerpath : The directory containing janet headers. Defaults to $JANET_HEADERPATH or module/*headerpath* - --binpath : The directory to install binaries and scripts. Defaults to $JANET_BINPATH. - --optimize : Optimization level for natives. Defaults to $OPTIMIZE or 2. - --compiler : C compiler to use for natives. Defaults to $CC or cc. - --linker : C linker to use for linking natives. Defaults to $LINKER or cc. - --cflags : Extra compiler flags for native modules. Defaults to $CFLAGS if set. - --lflags : Extra linker flags for native modules. Defaults to $LFLAGS if set. - `)) - -(def args (tuple/slice process/args 2)) -(def todo @[]) -(each arg args - (if (string/has-prefix? "--" arg) - (let [[key value] (peg/match argpeg arg)] - (setdyn (keyword key) value)) - (array/push todo arg))) - -(cook/import-rules "./project.janet") - -(if (empty? todo) (help)) -(each rule todo (cook/do-rule rule)) |
