From e1cf2d9780de765fc925b0ea3c9b29d532e70c2e Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sun, 8 Jul 2018 03:53:57 -0400 Subject: - Ported caching machinery for Lux Meta-Compiler to stdlib. --- stdlib/source/lux/control/exception.lux | 6 + stdlib/source/lux/data/format/binary.lux | 119 +++++++++++---- stdlib/source/lux/lang/compiler/meta/archive.lux | 49 +++++-- stdlib/source/lux/lang/compiler/meta/cache.lux | 163 +++++++++++++++++++++ .../lux/lang/compiler/meta/cache/dependency.lux | 51 +++++++ stdlib/source/lux/lang/compiler/meta/io.lux | 2 + .../source/lux/lang/compiler/meta/io/context.lux | 10 +- stdlib/source/lux/world/file.lux | 5 + 8 files changed, 355 insertions(+), 50 deletions(-) create mode 100644 stdlib/source/lux/lang/compiler/meta/cache.lux create mode 100644 stdlib/source/lux/lang/compiler/meta/cache/dependency.lux (limited to 'stdlib/source') diff --git a/stdlib/source/lux/control/exception.lux b/stdlib/source/lux/control/exception.lux index 2ca06defa..80ddeed35 100644 --- a/stdlib/source/lux/control/exception.lux +++ b/stdlib/source/lux/control/exception.lux @@ -71,6 +71,12 @@ (All [e] (-> (Exception e) e Error)) (#/.Error (construct exception message))) +(def: #export (assert exception message test) + (All [e] (-> (Exception e) e Bool (Error Any))) + (if test + (#/.Success []) + (..throw exception message))) + (syntax: #export (exception: {export csr.export} {t-vars (p.default (list) csr.type-variables)} {[name inputs] (p.either (p.seq s.local-symbol (wrap (list))) diff --git a/stdlib/source/lux/data/format/binary.lux b/stdlib/source/lux/data/format/binary.lux index cabdf7091..040ae5e8b 100644 --- a/stdlib/source/lux/data/format/binary.lux +++ b/stdlib/source/lux/data/format/binary.lux @@ -1,5 +1,5 @@ (.module: - [lux #- nat int rev] + [lux #- nat int rev list] (lux (control [monad #+ do Monad] ["p" parser] ["ex" exception #+ exception:]) @@ -14,8 +14,9 @@ (ex.report ["Blob length" (%n length)] ["Read bytes" (%n read)])) -(exception: #export (invalid-bool {byte Nat}) - (%n byte)) +(exception: #export (invalid-tag {range Nat} {byte Nat}) + (ex.report ["Range" (%n range)] + ["Byte" (%n byte)])) ## Types (type: #export Offset Nat) @@ -33,13 +34,13 @@ (type: #export (Write a) (-> a [Size (-> Offset Blob Blob)])) -(type: #export (Format a) +(type: #export (Binary a) {#read (Read a) #write (Write a)}) ## Operators (def: #export (read format input) - (All [a] (-> (Format a) Blob (error.Error a))) + (All [a] (-> (Binary a) Blob (error.Error a))) (case ((get@ #read format) [+0 input]) (#error.Error msg) (#error.Error msg) @@ -51,26 +52,14 @@ (ex.throw blob-was-not-fully-read [length end]))))) (def: #export (write format value) - (All [a] (-> (Format a) a Blob)) + (All [a] (-> (Binary a) a Blob)) (let [[valueS valueT] ((get@ #write format) value)] (|> valueS blob.create (valueT +0)))) -## Combinators -(def: #export (seq preF postF) - (All [a b] (-> (Format a) (Format b) (Format [a b]))) - {#read (p.seq (get@ #read preF) (get@ #read postF)) - #write (function (_ [preV postV]) - (let [[preS preT] ((get@ #write preF) preV) - [postS postT] ((get@ #write postF) postV)] - [(n/+ preS postS) - (function (_ offset) - (|>> (preT offset) - (postT (n/+ preS offset))))]))}) - ## Primitives (do-template [ ] [(def: - (Format (I64 Any)) + (Binary (I64 Any)) {#read (function (_ [offset blob]) (case ( offset blob) (#error.Success data) @@ -81,7 +70,9 @@ #write (function (_ value) [ (function (_ offset blob) - (error.assume ( offset value blob)))])})] + (|> blob + ( offset value) + error.assume))])})] [bits/8 size/8 blob.read/8 blob.write/8] [bits/16 size/16 blob.read/16 blob.write/16] @@ -89,9 +80,68 @@ [bits/64 size/64 blob.read/64 blob.write/64] ) +## Combinators +(def: #export (alt leftB rightB) + (All [l r] (-> (Binary l) (Binary r) (Binary (| l r)))) + {#read (do p.Monad + [flag (get@ #read bits/8)] + (case flag + +0 (:: @ map (|>> #.Left) (get@ #read leftB)) + +1 (:: @ map (|>> #.Right) (get@ #read rightB)) + _ (p.lift (ex.throw invalid-tag [+2 (.nat flag)])))) + #write (function (_ altV) + (case altV + (#.Left leftV) + (let [[leftS leftT] ((get@ #write leftB) leftV)] + [(.inc leftS) + (function (_ offset blob) + (|> blob + (blob.write/8 offset +0) + error.assume + (leftT (.inc offset))))]) + + (#.Right rightV) + (let [[rightS rightT] ((get@ #write rightB) rightV)] + [(.inc rightS) + (function (_ offset blob) + (|> blob + (blob.write/8 offset +1) + error.assume + (rightT (.inc offset))))]) + ))}) + +(def: #export (seq preB postB) + (All [a b] (-> (Binary a) (Binary b) (Binary [a b]))) + {#read (p.seq (get@ #read preB) (get@ #read postB)) + #write (function (_ [preV postV]) + (let [[preS preT] ((get@ #write preB) preV) + [postS postT] ((get@ #write postB) postV)] + [(n/+ preS postS) + (function (_ offset) + (|>> (preT offset) + (postT (n/+ preS offset))))]))}) + +(def: #export (rec body) + (All [a] (-> (-> (Binary a) (Binary a)) (Binary a))) + {#read (function (_ input) + (let [read (get@ #read (body (rec body)))] + (read input))) + #write (function (_ value) + (let [write (get@ #write (body (rec body)))] + (write value)))}) + ## Utilities +(def: #export unit + (Binary Any) + {#read (function (_ input) + (#error.Success [input []])) + #write (function (_ value) + [+0 + (function (_ offset blob) + blob)])}) + (def: #export bool - (Format Bool) + (Binary Bool) {#read (function (_ [offset blob]) (case (blob.read/8 offset blob) (#error.Success data) @@ -102,29 +152,29 @@ [+1 true]) _ - (ex.throw invalid-bool data)) + (ex.throw invalid-tag [+2 data])) (#error.Error error) (#error.Error error))) #write (function (_ value) [+1 (function (_ offset blob) - (exec (error.assume (blob.write/8 offset (if value +1 +0) blob)) - blob))])} - ) + (|> blob + (blob.write/8 offset (if value +1 +0)) + error.assume))])}) -(def: #export nat (Format Nat) (:assume ..bits/64)) -(def: #export int (Format Int) (:assume ..bits/64)) -(def: #export rev (Format Rev) (:assume ..bits/64)) +(def: #export nat (Binary Nat) (:assume ..bits/64)) +(def: #export int (Binary Int) (:assume ..bits/64)) +(def: #export rev (Binary Rev) (:assume ..bits/64)) (def: #export frac - (Format Frac) + (Binary Frac) (let [(^slots [#read #write]) ..bits/64] {#read (:: p.Monad map number.bits-to-frac read) #write (|>> number.frac-to-bits write)})) (def: #export blob - (Format Blob) + (Binary Blob) {#read (do p.Monad [size (get@ #read nat)] (function (_ [offset blob]) @@ -142,9 +192,16 @@ (blob.copy size +0 value (n/+ size/64 offset) blob))))]))}) (def: #export text - (Format Text) + (Binary Text) (let [(^slots [#read #write]) ..blob] {#read (do p.Monad [utf8 read] (p.lift (encoding.from-utf8 utf8))) #write (|>> encoding.to-utf8 write)})) + +(def: #export (list value) + (All [a] (-> (Binary a) (Binary (List a)))) + (..rec + (function (_ recur) + (..alt ..unit + (..seq value recur))))) diff --git a/stdlib/source/lux/lang/compiler/meta/archive.lux b/stdlib/source/lux/lang/compiler/meta/archive.lux index f61476111..371164ee4 100644 --- a/stdlib/source/lux/lang/compiler/meta/archive.lux +++ b/stdlib/source/lux/lang/compiler/meta/archive.lux @@ -13,41 +13,54 @@ [////]) ## Key +(type: #export Signature + {#name Ident + #version Text}) + +(def: Equivalence + (Equivalence Signature) + (equivalence.product ident.Equivalence text.Equivalence)) + +(def: (describe signature) + (-> Signature Text) + (format (%ident (get@ #name signature)) " " (get@ #version signature))) + (abstract: #export (Key k) {} - {#name Ident - #version Text} + Signature - (def: Equivalence' - (equivalence.product ident.Equivalence text.Equivalence)) - (struct: #export Equivalence (All [k] (Equivalence (Key k))) (def: (= reference sample) - (:: Equivalence' = (:representation reference) (:representation sample)))) + (:: Equivalence = (:representation reference) (:representation sample)))) (def: #export default (Key Nothing) (:abstraction {#name ["" ""] #version ////.version})) - (def: (describe (^:representation key)) - (-> (Key Any) Text) - (format (%ident (get@ #name key)) " " (get@ #version key))) + (def: #export signature + (-> (Key Any) Signature) + (|>> :representation)) ) ## Document (exception: #export (invalid-key-for-document {expected (Key Any)} {actual (Key Any)}) - (ex.report ["Expected" (describe expected)] - ["Actual" (describe actual)])) + (ex.report ["Expected" (describe (..signature expected))] + ["Actual" (describe (..signature actual))])) + +(exception: #export (signature-does-not-match-key {key (Key Any)} {signature Signature}) + (ex.report ["Key" (describe (..signature key))] + ["Signature" (describe signature)])) (type: #export (Document d) {#key (Key d) + #hash Nat #value d}) (def: #export (open expected [actual value]) - (All [e] (-> (Key e) (Document Any) (Error e))) + (All [d] (-> (Key d) (Document Any) (Error d))) (if (:: Equivalence = expected actual) (#error.Success (:share [e] {(Key e) @@ -56,11 +69,19 @@ value})) (ex.throw invalid-key-for-document [expected actual]))) +(def: #export (close key signature hash value) + (All [d] (-> (Key d) Signature Nat d (Error (Document d)))) + (if (:: Equivalence = (..signature key) signature) + (#error.Success {#key key + #hash hash + #value value}) + (ex.throw signature-does-not-match-key [key signature]))) + ## Archive (exception: #export (cannot-replace-document-in-archive {name Text} {old (Document Any)} {new (Document Any)}) (ex.report ["Module's name" name] - ["Old document's key" (describe (get@ #key old))] - ["New document's key" (describe (get@ #key new))])) + ["Old document's key" (describe (..signature (get@ #key old)))] + ["New document's key" (describe (..signature (get@ #key new)))])) (type: #export Archive (Dict Text (Ex [d] (Document d)))) diff --git a/stdlib/source/lux/lang/compiler/meta/cache.lux b/stdlib/source/lux/lang/compiler/meta/cache.lux new file mode 100644 index 000000000..153679ef0 --- /dev/null +++ b/stdlib/source/lux/lang/compiler/meta/cache.lux @@ -0,0 +1,163 @@ +(.module: + [lux #- Module] + (lux (control [monad #+ Monad do] + ["ex" exception #+ exception:] + pipe) + (data [bool "bool/" Equivalence] + [maybe] + [error] + [product] + (format [binary #+ Binary]) + [text] + text/format + (coll [list "list/" Functor Fold] + (dictionary ["dict" unordered #+ Dict]) + (set ["set" unordered #+ Set]))) + (world [file #+ File System])) + [//io #+ Context Module] + [//io/context] + [//io/archive] + [//archive #+ Signature Key Document Archive] + [/dependency #+ Dependency Graph]) + +(exception: #export (cannot-delete-cached-file {file File}) + (ex.report ["File" file])) + +(exception: #export (stale-document {module Text} {current-hash Nat} {stale-hash Nat}) + (ex.report ["Module" module] + ["Current hash" (%n current-hash)] + ["Stale hash" (%n stale-hash)])) + +(do-template [] + [(exception: #export ( {message Text}) + message)] + + [cannot-load-definition] + ) + +## General +(def: #export (cached System root) + (All [m] (-> (System m) File (m (List File)))) + (|> root + (//io/archive.archive System) + (do> (:: System &monad) + [(:: System files)] + [(monad.map @ (function (recur file) + (do @ + [is-dir? (:: System directory? file)] + (if is-dir? + (|> file + (do> @ + [(:: System files)] + [(monad.map @ recur)] + [list.concat + (list& (maybe.assume (//io/archive.module System root file))) + wrap])) + (wrap (list))))))] + [list.concat wrap]))) + +## Clean +(def: (delete System document) + (All [m] (-> (System m) File (m Any))) + (do (:: System &monad) + [deleted? (:: System delete document)] + (if deleted? + (wrap []) + (:: System throw cannot-delete-cached-file document)))) + +(def: (un-install System root module) + (All [m] (-> (System m) File Module (m Any))) + (let [document (//io/archive.document System root module)] + (|> document + (do> (:: System &monad) + [(:: System files)] + [(monad.map @ (function (_ file) + (do @ + [? (:: System directory? file)] + (if ? + (wrap false) + (do @ + [_ (..delete System file)] + (wrap true))))))] + [(list.every? (bool/= true)) + (if> [(..delete System document)] + [(wrap [])])])))) + +(def: #export (clean System root wanted-modules) + (All [m] (-> (System m) File (Set Module) (m Any))) + (|> root + (do> (:: System &monad) + [(..cached System)] + [(list.filter (bool.complement (set.member? wanted-modules))) + (monad.map @ (un-install System root))]))) + +## Load +(def: signature + (Binary Signature) + (let [name (binary.seq binary.text binary.text) + version binary.text] + (binary.seq name version))) + +(def: imports + (Binary (List Module)) + (binary.list binary.text)) + +(def: document + (All [a] (-> (Binary a) (Binary [Signature Nat (List Module) a]))) + (|>> ($_ binary.seq ..signature binary.nat ..imports))) + +(def: (load-document System contexts root key binary module) + (All [m d] (-> (System m) (List File) File (Key d) (Binary d) Module + (m (Maybe [Dependency (Document d)])))) + (do (:: System &monad) + [document' (:: System read (//io/archive.document System root module)) + [module' source-code] (//io/context.read System contexts module) + #let [current-hash (:: text.Hash hash source-code)]] + (case (do error.Monad + [[signature document-hash imports content] (binary.read (..document binary) document') + _ (ex.assert stale-document [module current-hash document-hash] + (n/= current-hash document-hash)) + document (//archive.close key signature document-hash content)] + (wrap [[module imports] document])) + (#error.Success [dependency document]) + (wrap (#.Some [dependency document])) + + (#error.Error error) + (do @ + [_ (un-install System root module)] + (wrap #.None))))) + +(def: #export (load-archive System contexts root key binary) + (All [m d] (-> (System m) (List Context) File (Key d) (Binary d) (m Archive))) + (do (:: System &monad) + [candidate (|> root + (do> @ + [(..cached System)] + [(monad.map @ (load-document System contexts root key binary)) + (:: @ map (list/fold (function (_ full-document archive) + (case full-document + (#.Some [[module imports] document]) + (dict.put module [imports document] archive) + + #.None + archive)) + (: (Dict Text [(List Module) (Ex [d] (Document d))]) + (dict.new text.Hash))))])) + #let [candidate-entries (dict.entries candidate) + candidate-dependencies (list/map (product.both id product.left) + candidate-entries) + candidate-archive (|> candidate-entries + (list/map (product.both id product.right)) + (dict.from-list text.Hash)) + graph (|> candidate + dict.entries + (list/map (product.both id product.left)) + /dependency.graph + (/dependency.prune candidate-archive)) + archive (list/fold (function (_ module archive) + (if (dict.contains? module graph) + archive + (dict.remove module archive))) + candidate-archive + (dict.keys candidate))]] + (wrap archive))) diff --git a/stdlib/source/lux/lang/compiler/meta/cache/dependency.lux b/stdlib/source/lux/lang/compiler/meta/cache/dependency.lux new file mode 100644 index 000000000..28fcfccc8 --- /dev/null +++ b/stdlib/source/lux/lang/compiler/meta/cache/dependency.lux @@ -0,0 +1,51 @@ +(.module: + [lux #- Module] + (lux (data [text] + (coll [list "list/" Functor Fold] + (dictionary ["dict" unordered #+ Dict])))) + [///io #+ Module] + [///archive #+ Archive]) + +(type: #export Graph (Dict Module (List Module))) + +(def: #export empty Graph (dict.new text.Hash)) + +(def: #export (add to from) + (-> Module Module Graph Graph) + (|>> (dict.update~ from (list) (|>> (#.Cons to))) + (dict.update~ to (list) id))) + +(def: dependents + (-> Module Graph (Maybe (List Text))) + dict.get) + +(def: #export (remove module dependency) + (-> Module Graph Graph) + (case (dependents module dependency) + (#.Some dependents) + (list/fold remove (dict.remove module dependency) dependents) + + #.None + dependency)) + +(type: #export Dependency + {#module Module + #imports (List Module)}) + +(def: #export (dependency [module imports]) + (-> Dependency Graph) + (list/fold (..add module) ..empty imports)) + +(def: #export graph + (-> (List Dependency) Graph) + (|>> (list/map ..dependency) + (list/fold dict.merge empty))) + +(def: #export (prune archive graph) + (-> Archive Graph Graph) + (list/fold (function (_ module graph) + (if (dict.contains? module archive) + graph + (..remove module graph))) + graph + (dict.keys graph))) diff --git a/stdlib/source/lux/lang/compiler/meta/io.lux b/stdlib/source/lux/lang/compiler/meta/io.lux index 6be4605f2..e440c16f9 100644 --- a/stdlib/source/lux/lang/compiler/meta/io.lux +++ b/stdlib/source/lux/lang/compiler/meta/io.lux @@ -9,6 +9,8 @@ (world [file #+ File System] [blob #+ Blob]))) +(type: #export Context File) + (type: #export Module Text) (def: #export (sanitize system) diff --git a/stdlib/source/lux/lang/compiler/meta/io/context.lux b/stdlib/source/lux/lang/compiler/meta/io/context.lux index d03dcbdd8..327f52cf5 100644 --- a/stdlib/source/lux/lang/compiler/meta/io/context.lux +++ b/stdlib/source/lux/lang/compiler/meta/io/context.lux @@ -1,5 +1,5 @@ (.module: - [lux #- Module] + [lux #- Module Code] (lux (control monad ["ex" exception #+ Exception exception:]) (data [error] @@ -8,9 +8,7 @@ (world [file #+ File System] [blob #+ Blob])) [/////host] - [// #+ Module]) - -(type: #export Context File) + [// #+ Context Module]) (type: #export Extension Text) @@ -72,8 +70,10 @@ #.None (try System computations' exception message))))) +(type: #export Code Text) + (def: #export (read System contexts name) - (All [m] (-> (System m) (List Context) Module (m [Module Text]))) + (All [m] (-> (System m) (List Context) Module (m [Text Code]))) (let [find-source' (find-source System contexts name)] (do (:: System &monad) [[path file] (try System diff --git a/stdlib/source/lux/world/file.lux b/stdlib/source/lux/world/file.lux index 21f5c1d3c..24c38024c 100644 --- a/stdlib/source/lux/world/file.lux +++ b/stdlib/source/lux/world/file.lux @@ -29,6 +29,9 @@ (: (All [a] (-> (m a) (m (Error a)))) try) + + (: (All [a] (-> (Error a) (m a))) + lift) (do-template [] [(: (-> Blob File (m Any)) @@ -136,6 +139,8 @@ (do io.Monad [outcome computation] (:: io.Monad wrap outcome))) + + (def: lift (:: io.Monad wrap)) (do-template [ ] [(def: ( data file) -- cgit v1.2.3