diff options
| -rw-r--r-- | new-luxc/source/luxc/cache/description.lux | 139 | ||||
| -rw-r--r-- | stdlib/source/lux.lux | 4 | ||||
| -rw-r--r-- | stdlib/source/lux/data/format/binary.lux | 91 | ||||
| -rw-r--r-- | stdlib/source/lux/lang/compiler/default/cache.lux | 33 | ||||
| -rw-r--r-- | stdlib/source/lux/lang/compiler/meta/archive.lux | 31 | ||||
| -rw-r--r-- | stdlib/source/lux/lang/compiler/meta/cache.lux | 27 |
6 files changed, 153 insertions, 172 deletions
diff --git a/new-luxc/source/luxc/cache/description.lux b/new-luxc/source/luxc/cache/description.lux deleted file mode 100644 index 7706d03b1..000000000 --- a/new-luxc/source/luxc/cache/description.lux +++ /dev/null @@ -1,139 +0,0 @@ -(.module: - lux - (lux (control [monad #+ do] - ["p" parser "parser/" Monad<Parser>] - ["ex" exception #+ exception:]) - (data [product] - ["e" error #+ Error] - [text "text/" Eq<Text>] - text/format - (coll [list "list/" Functor<List>])) - (macro [code] - ["s" syntax #+ Syntax]) - [lang])) - -(exception: #export (invalid-lux-version {version Text}) - (ex.report ["Expected: " lang.version] - [" Actual: " version])) - -(def: (write-type type) - (-> Type Code) - (case type - (#.Primitive name params) - (` ("Primitive" - (~ (code.text name)) - (~+ (list/map write-type params)))) - - (^template [<tag> <description>] - (<tag> left right) - (` (<description> (~ (write-type left)) (~ (write-type right))))) - ([#.Sum "Sum"] - [#.Product "Product"] - [#.Function "Function"] - [#.Apply "Apply"]) - - (^template [<tag> <description>] - (<tag> id) - (` (<description> (~ (code.nat id))))) - ([#.Parameter "Parameter"] - [#.Var "Var"] - [#.Ex "Ex"]) - - (^template [<tag> <description>] - (<tag> env body) - (` (<description> (~ (code.tuple (list/map write-type env))) - (~ (write-type body))))) - ([#.UnivQ "UnivQ"] - [#.ExQ "ExQ"]) - - (#.Named name anonymous) - (` ("Named" (~ (code.symbol name)) (~ (write-type anonymous)))))) - -(def: read-type - (Syntax Type) - (let [tagged (: (All [a] (-> Text (Syntax a) (Syntax a))) - (function (_ tag syntax) - (s.form (p.after (s.this (code.text tag)) syntax)))) - binary (: (-> Text (Syntax Type) (Syntax [Type Type])) - (function (_ tag read-type) - (tagged tag (p.seq read-type read-type)))) - indexed (: (-> Text (Syntax Nat)) - (function (_ tag) - (tagged tag s.nat))) - quantified (: (-> Text (Syntax Type) (Syntax [(List Type) Type])) - (function (_ tag read-type) - (tagged tag (p.seq (s.tuple (p.some read-type)) - read-type))))] - (p.rec - (function (_ read-type) - ($_ p.alt - (tagged "Primitive" (p.seq s.text (p.some read-type))) - (binary "Sum" read-type) - (binary "Product" read-type) - (binary "Function" read-type) - (indexed "Parameter") - (indexed "Var") - (indexed "Ex") - (quantified "UnivQ" read-type) - (quantified "ExQ" read-type) - (binary "Apply" read-type) - (tagged "Named" (p.seq s.symbol read-type)) - ))))) - -(def: (write-definition [type annotations value]) - (-> Definition Code) - (` {"type" (~ (write-type type)) - "annotations" (~ annotations)})) - -(def: read-definition - (Syntax Definition) - (s.record ($_ p.seq - (p.after (s.this (` "type")) read-type) - (p.after (s.this (` "annotations")) s.any) - (parser/wrap [])))) - -(def: (write-aliases aliases) - (-> (List [Text Text]) Code) - (|> aliases (list/map (product.both code.text code.text)) code.record)) - -(def: read-aliases - (Syntax (List [Text Text])) - (s.record (p.some (p.seq s.text s.text)))) - -(def: #export (write lux-file module) - (-> Text Module Code) - (` {"lux version" (~ (code.text lang.version)) - "lux file" (~ (code.text lux-file)) - "hash" (~ (code.nat (get@ #.module-hash module))) - "aliases" (~ (write-aliases (get@ #.module-aliases module))) - "definitions" (~ (code.record (list/map (product.both code.text write-definition) - (get@ #.definitions module)))) - "imports" (~ (code.tuple (list/map code.text (get@ #.imports module)))) - "annotations" (~ (case (get@ #.module-annotations module) - #.None - (' "None") - - (#.Some annotations) - (` ("Some" (~ annotations))))) - })) - -(def: #export (read description) - (-> Code (Error [Text Module])) - (<| (s.run (list description)) - (s.record (do p.Monad<Parser> - [lux-version (p.after (s.this (` "lux version")) s.text) - _ (p.assert (ex.construct invalid-lux-version lux-version) - (text/= lang.version lux-version))] - ($_ p.seq - (p.after (s.this (` "lux file")) s.text) - ($_ p.seq - (p.after (s.this (` "hash")) s.nat) - (p.after (s.this (` "aliases")) read-aliases) - (p.after (s.this (` "definitions")) (s.record (p.some (p.seq s.text read-definition)))) - (p.after (s.this (` "imports")) (s.tuple (p.some s.text))) - (parser/wrap (list)) - (parser/wrap (list)) - (p.after (s.this (` "annotations")) (p.alt (s.this (` "None")) - (s.form (p.after (s.this (` "Some")) - s.any)))) - (parser/wrap #.Cached))))))) diff --git a/stdlib/source/lux.lux b/stdlib/source/lux.lux index 0389a64f8..138d965c4 100644 --- a/stdlib/source/lux.lux +++ b/stdlib/source/lux.lux @@ -312,8 +312,8 @@ ## (#Rev Rev) ## (#Frac Frac) ## (#Text Text) -## (#Symbol Text Text) -## (#Tag Text Text) +## (#Symbol Ident) +## (#Tag Ident) ## (#Form (List (w (Code' w)))) ## (#Tuple (List (w (Code' w)))) ## (#Record (List [(w (Code' w)) (w (Code' w))]))) diff --git a/stdlib/source/lux/data/format/binary.lux b/stdlib/source/lux/data/format/binary.lux index 040ae5e8b..d1d83853d 100644 --- a/stdlib/source/lux/data/format/binary.lux +++ b/stdlib/source/lux/data/format/binary.lux @@ -1,8 +1,9 @@ (.module: - [lux #- nat int rev list] + [lux #- nat int rev list type] (lux (control [monad #+ do Monad] ["p" parser] - ["ex" exception #+ exception:]) + ["ex" exception #+ exception:] + [equivalence #+ Equivalence]) (data [error] (text [encoding] [format #+ %n]) @@ -131,15 +132,19 @@ (write value)))}) ## Utilities -(def: #export unit - (Binary Any) +(def: #export (ignore default) + (All [a] (-> a (Binary a))) {#read (function (_ input) - (#error.Success [input []])) + (#error.Success [input default])) #write (function (_ value) [+0 (function (_ offset blob) blob)])}) +(def: #export any + (Binary Any) + (ignore [])) + (def: #export bool (Binary Bool) {#read (function (_ [offset blob]) @@ -199,9 +204,83 @@ (p.lift (encoding.from-utf8 utf8))) #write (|>> encoding.to-utf8 write)})) +(def: #export maybe + (All [a] (-> (Binary a) (Binary (Maybe a)))) + (..alt ..any)) + (def: #export (list value) (All [a] (-> (Binary a) (Binary (List a)))) (..rec (function (_ recur) - (..alt ..unit + (..alt ..any (..seq value recur))))) + +(def: #export ident + (Binary Ident) + (..seq ..text ..text)) + +(def: #export type + (Binary Type) + (..rec + (function (_ type) + (let [pair (..seq type type) + indexed ..nat + quantified (..seq (..list type) type)] + ($_ ..alt + ## #Primitive + (..seq ..text (..list type)) + ## #Sum + pair + ## #Product + pair + ## #Function + pair + ## #Parameter + indexed + ## #Var + indexed + ## #Ex + indexed + ## #UnivQ + quantified + ## #ExQ + quantified + ## #Apply + pair + ## #Named + (..seq ..ident type) + ))))) + +(def: #export cursor + (Binary Cursor) + ($_ ..seq ..text ..nat ..nat)) + +(def: #export code + (Binary Code) + (..rec + (function (_ code) + (let [sequence (..list code) + code' ($_ ..alt + ## #Bool + ..bool + ## #Nat + ..nat + ## #Int + ..int + ## #Rev + ..rev + ## #Frac + ..frac + ## #Text + ..text + ## #Symbol + ..ident + ## #Tag + ..ident + ## #Form + sequence + ## #Tuple + sequence + ## #Record + (..list (..seq code code)))] + (..seq ..cursor code'))))) diff --git a/stdlib/source/lux/lang/compiler/default/cache.lux b/stdlib/source/lux/lang/compiler/default/cache.lux new file mode 100644 index 000000000..a878e1615 --- /dev/null +++ b/stdlib/source/lux/lang/compiler/default/cache.lux @@ -0,0 +1,33 @@ +(.module: + lux + (lux (data (format [binary #+ Binary])))) + +(def: definition + (Binary Definition) + ($_ binary.seq binary.type binary.code binary.any)) + +(def: alias + (Binary [Text Text]) + (binary.seq binary.text binary.text)) + +## TODO: Remove #module-hash, #imports & #module-state ASAP. +## TODO: Not just from this parser, but from the lux.Module type. +(def: #export module + (Binary Module) + ($_ binary.seq + ## #module-hash + (binary.ignore +0) + ## #module-aliases + (binary.list ..alias) + ## #definitions + (binary.list (binary.seq binary.text ..definition)) + ## #imports + (binary.list binary.text) + ## #tags + (binary.ignore (list)) + ## #types + (binary.ignore (list)) + ## #module-annotations + (binary.maybe binary.code) + ## #module-state + (binary.ignore #.Cached))) diff --git a/stdlib/source/lux/lang/compiler/meta/archive.lux b/stdlib/source/lux/lang/compiler/meta/archive.lux index fa3b91d7c..a3e9c0397 100644 --- a/stdlib/source/lux/lang/compiler/meta/archive.lux +++ b/stdlib/source/lux/lang/compiler/meta/archive.lux @@ -9,13 +9,14 @@ text/format (coll (dictionary ["dict" unordered #+ Dict]))) (lang [type #+ :share]) - (type abstract)) - [////]) + (type abstract) + (world [file #+ File])) + [//// #+ Version]) ## Key (type: #export Signature {#name Ident - #version Text}) + #version Version}) (def: Equivalence<Signature> (Equivalence Signature) @@ -54,27 +55,35 @@ (ex.report ["Key" (describe (..signature key))] ["Signature" (describe signature)])) +(type: #export Reference Text) + +(type: #export Descriptor + {#hash Nat + #file File + #references (List Reference) + #state Module-State}) + (type: #export (Document d) {#key (Key d) - #hash Nat - #value d}) + #descriptor Descriptor + #content d}) -(def: #export (open expected [actual value]) +(def: #export (open expected [actual _descriptor content]) (All [d] (-> (Key d) (Document Any) (Error d))) (if (:: Equivalence<Key> = expected actual) (#error.Success (:share [e] {(Key e) expected} {e - value})) + content})) (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)))) +(def: #export (close key signature descriptor content) + (All [d] (-> (Key d) Signature Descriptor d (Error (Document d)))) (if (:: Equivalence<Signature> = (..signature key) signature) (#error.Success {#key key - #hash hash - #value value}) + #descriptor descriptor + #content content}) (ex.throw signature-does-not-match-key [key signature]))) ## Archive diff --git a/stdlib/source/lux/lang/compiler/meta/cache.lux b/stdlib/source/lux/lang/compiler/meta/cache.lux index 153679ef0..1d47121f9 100644 --- a/stdlib/source/lux/lang/compiler/meta/cache.lux +++ b/stdlib/source/lux/lang/compiler/meta/cache.lux @@ -17,7 +17,7 @@ [//io #+ Context Module] [//io/context] [//io/archive] - [//archive #+ Signature Key Document Archive] + [//archive #+ Signature Key Descriptor Document Archive] [/dependency #+ Dependency Graph]) (exception: #export (cannot-delete-cached-file {file File}) @@ -94,17 +94,15 @@ ## Load (def: signature (Binary Signature) - (let [name (binary.seq binary.text binary.text) - version binary.text] - (binary.seq name version))) + ($_ binary.seq binary.ident binary.text)) -(def: imports - (Binary (List Module)) - (binary.list binary.text)) +(def: descriptor + (Binary Descriptor) + ($_ binary.seq binary.nat binary.text (binary.list binary.text) (binary.ignore #.Cached))) (def: document - (All [a] (-> (Binary a) (Binary [Signature Nat (List Module) a]))) - (|>> ($_ binary.seq ..signature binary.nat ..imports))) + (All [a] (-> (Binary a) (Binary [Signature Descriptor a]))) + (|>> ($_ binary.seq ..signature ..descriptor))) (def: (load-document System<m> contexts root key binary module) (All [m d] (-> (System m) (List File) File (Key d) (Binary d) Module @@ -114,11 +112,12 @@ [module' source-code] (//io/context.read System<m> contexts module) #let [current-hash (:: text.Hash<Text> hash source-code)]] (case (do error.Monad<Error> - [[signature document-hash imports content] (binary.read (..document binary) document') + [[signature descriptor content] (binary.read (..document binary) document') + #let [[document-hash _file references _state] descriptor] _ (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])) + document (//archive.close key signature descriptor content)] + (wrap [[module references] document])) (#error.Success [dependency document]) (wrap (#.Some [dependency document])) @@ -136,8 +135,8 @@ [(monad.map @ (load-document System<m> contexts root key binary)) (:: @ map (list/fold (function (_ full-document archive) (case full-document - (#.Some [[module imports] document]) - (dict.put module [imports document] archive) + (#.Some [[module references] document]) + (dict.put module [references document] archive) #.None archive)) |