aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorEduardo Julian2018-07-10 19:37:30 -0400
committerEduardo Julian2018-07-10 19:37:30 -0400
commit631b52a83f7ee64c46a893cdd347289276afe210 (patch)
treeb4ea9b01d8be324838a535a33d6b69abc8485f47
parent9d89d791a8c65e6d2fa5ee9ff7ecae29ca9b7fdc (diff)
- Ported caching machinery for default compiler.
- Expanded binary format module.
Diffstat (limited to '')
-rw-r--r--new-luxc/source/luxc/cache/description.lux139
-rw-r--r--stdlib/source/lux.lux4
-rw-r--r--stdlib/source/lux/data/format/binary.lux91
-rw-r--r--stdlib/source/lux/lang/compiler/default/cache.lux33
-rw-r--r--stdlib/source/lux/lang/compiler/meta/archive.lux31
-rw-r--r--stdlib/source/lux/lang/compiler/meta/cache.lux27
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))