aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--lux-mode/lux-mode.el4
-rw-r--r--stdlib/source/lux.lux9
-rw-r--r--stdlib/source/lux/data/text/format.lux4
-rw-r--r--stdlib/source/lux/lang/type.lux44
-rw-r--r--stdlib/source/lux/macro.lux55
-rw-r--r--stdlib/source/lux/macro/code.lux8
-rw-r--r--stdlib/source/lux/macro/syntax.lux84
-rw-r--r--stdlib/source/lux/type/abstract.lux17
8 files changed, 123 insertions, 102 deletions
diff --git a/lux-mode/lux-mode.el b/lux-mode/lux-mode.el
index 45db10635..6fcfb3853 100644
--- a/lux-mode/lux-mode.el
+++ b/lux-mode/lux-mode.el
@@ -225,7 +225,7 @@ Called by `imenu--generic-function'."
"abstract:"
"unit:" "scale:"
"import:"
- ":" ":coerce" ":assume" ":abstraction" ":representation" "^:representation"
+ ":" ":coerce" ":assume" ":cast" ":abstraction" ":representation" "^:representation"
"function" "case" "undefined" "ident-for" "static"
"and" "or"
"char"
@@ -259,7 +259,7 @@ Called by `imenu--generic-function'."
("\\<-?\\(0\\|[0-9][0-9_]*\\)\\(\\.[0-9_]+\\)?\\>" 0 font-lock-constant-face)
("\\<-?\\(0\\|[--9][0-9_]*\\)\\(\\.[0-9_]+\\(\\(e\\|E\\)\\(-\\|\\+\\)?[0-9][0-9_]*\\)?\\)?\\>" 0 font-lock-constant-face)
; Frac "ratio" literals
- ("\\<-?\\(0\\|[0-9][0-9_]*\\)/[0-9][0-9_]*\\>" 0 font-lock-constant-face)
+ ("\\<-?[0-9][0-9_]*/[0-9][0-9_]*\\>" 0 font-lock-constant-face)
; Deg literals
("\\<\\(\\.[0-9][0-9_]*\\)\\>" 0 font-lock-constant-face)
; Tags
diff --git a/stdlib/source/lux.lux b/stdlib/source/lux.lux
index 55499d6cc..31f5165ea 100644
--- a/stdlib/source/lux.lux
+++ b/stdlib/source/lux.lux
@@ -6341,3 +6341,12 @@
_
(fail "Wrong syntax for alias:")))
+
+(def: #export (cursor-description [file line column])
+ (-> Cursor Text)
+ (let [separator ", "
+ fields ($_ "lux text concat"
+ (text/encode file) separator
+ (nat/encode line) separator
+ (nat/encode column))]
+ ($_ "lux text concat" "[" fields "]")))
diff --git a/stdlib/source/lux/data/text/format.lux b/stdlib/source/lux/data/text/format.lux
index 8ae82ef89..b2a1c160c 100644
--- a/stdlib/source/lux/data/text/format.lux
+++ b/stdlib/source/lux/data/text/format.lux
@@ -23,9 +23,7 @@
(syntax: #export (format {fragments (p.many s.any)})
{#.doc (doc "Text interpolation."
(format "Static part " (%t static) " does not match URI: " uri))}
- (macro.with-gensyms [g!compose]
- (wrap (list (` (let [(~ g!compose) (:: (~! text.Monoid<Text>) (~' compose))]
- ($_ (~ g!compose) (~+ fragments))))))))
+ (wrap (list (` ($_ "lux text concat" (~+ fragments))))))
## [Formats]
(type: #export (Format a)
diff --git a/stdlib/source/lux/lang/type.lux b/stdlib/source/lux/lang/type.lux
index 36e6a74a8..acc3d9046 100644
--- a/stdlib/source/lux/lang/type.lux
+++ b/stdlib/source/lux/lang/type.lux
@@ -1,13 +1,16 @@
(.module: {#.doc "Basic functionality for working with types."}
[lux #- function]
(lux (control [equality #+ Eq]
- [monad #+ do Monad])
+ [monad #+ do Monad]
+ ["p" parser])
(data [text "text/" Monoid<Text> Eq<Text>]
- [ident "ident/" Eq<Ident>]
+ [ident "ident/" Eq<Ident> Codec<Text,Ident>]
[number "nat/" Codec<Text,Nat>]
[maybe]
- (coll [list #+ "list/" Monad<List> Monoid<List> Fold<List>]))
- (macro [code])
+ (coll [list #+ "list/" Functor<List> Monoid<List> Fold<List>]))
+ [macro]
+ (macro [code]
+ ["s" syntax #+ syntax:])
))
## [Utils]
@@ -275,7 +278,7 @@
(<ctor> type (<name> types'))))]
[variant Nothing #.Sum]
- [tuple Any #.Product]
+ [tuple Any #.Product]
)
(def: #export (function inputs output)
@@ -330,3 +333,34 @@
(case level
+0 elem-type
_ (|> elem-type (array (dec level)) (list) (#.Primitive "#Array"))))
+
+(syntax: #export (:log! {input (p.alt s.symbol
+ s.any)})
+ (case input
+ (#.Left valueN)
+ (do @
+ [cursor macro.cursor
+ valueT (macro.find-type valueN)
+ #let [_ (log! ($_ text/compose
+ ":log!" " @ " (.cursor-description cursor) "\n"
+ (ident/encode valueN) " : " (..to-text valueT) "\n"))]]
+ (wrap (list (' []))))
+
+ (#.Right valueC)
+ (macro.with-gensyms [g!value]
+ (wrap (list (` (.let [(~ g!value) (~ valueC)]
+ (..:log! (~ g!value)))))))))
+
+(syntax: #export (:cast {type-vars (s.tuple (p.some s.local-symbol))}
+ input
+ output
+ {value (p.maybe s.any)})
+ (let [casterC (` (: (All [(~+ (list/map code.local-symbol type-vars))]
+ (-> (~ input) (~ output)))
+ (|>> :assume)))]
+ (case value
+ #.None
+ (wrap (list casterC))
+
+ (#.Some value)
+ (wrap (list (` ((~ casterC) (~ value))))))))
diff --git a/stdlib/source/lux/macro.lux b/stdlib/source/lux/macro.lux
index 982dec71b..9e26a49e4 100644
--- a/stdlib/source/lux/macro.lux
+++ b/stdlib/source/lux/macro.lux
@@ -9,8 +9,7 @@
[maybe]
["e" error]
[text "text/" Monoid<Text> Eq<Text>]
- (coll [list "list/" Monoid<List> Monad<List>]))
- (lang [type]))
+ (coll [list "list/" Monoid<List> Monad<List>])))
(/ [code]))
## (type: (Meta a)
@@ -605,17 +604,31 @@
[(^slots [#.imports]) (find-module module-name)]
(wrap imports)))
+(def: #export (imported-by? import module)
+ (-> Text Text (Meta Bool))
+ (do Monad<Meta>
+ [(^slots [#.imports]) (find-module module)]
+ (wrap (list.any? (text/= import) imports))))
+
+(def: #export (imported? import)
+ (-> Text (Meta Bool))
+ (let [(^open) Monad<Meta>]
+ (|> current-module-name
+ (map find-module) join
+ (map (|>> (get@ #.imports) (list.any? (text/= import)))))))
+
(def: #export (resolve-tag tag)
{#.doc "Given a tag, finds out what is its index, its related tag-list and it's associated type."}
(-> Ident (Meta [Nat (List Ident) Type]))
(do Monad<Meta>
[#let [[module name] tag]
=module (find-module module)
- this-module-name current-module-name]
+ this-module-name current-module-name
+ imported! (..imported? module)]
(case (get name (get@ #.tags =module))
(#.Some [idx tag-list exported? type])
- (if (or exported?
- (text/= this-module-name module))
+ (if (or (text/= this-module-name module)
+ (and imported! exported?))
(wrap [idx tag-list type])
(fail ($_ text/compose "Cannot access tag: " (ident/encode tag) " from module " this-module-name)))
@@ -673,14 +686,6 @@
(function (_ compiler)
(#e.Success [compiler (get@ #.type-context compiler)])))
-(def: (cursor-description [file line column])
- (-> Cursor Text)
- (|> (list (text.encode file)
- (nat/encode line)
- (nat/encode column))
- (text.join-with ", ")
- (text.enclose ["[" "]"])))
-
(do-template [<macro> <func> <desc>]
[(macro: #export (<macro> tokens)
{#.doc (doc "Performs a macro-expansion and logs the resulting code."
@@ -705,7 +710,7 @@
(do Monad<Meta>
[cursor ..cursor
output (<func> token)
- #let [_ (log! ($_ text/compose <desc> " @ " (cursor-description cursor)))
+ #let [_ (log! ($_ text/compose <desc> " @ " (.cursor-description cursor)))
_ (list/map (|>> code.to-text log!)
output)
_ (log! "")]]
@@ -720,25 +725,3 @@
[log-expand-all expand-all "log-expand-all"]
[log-expand-once expand-once "log-expand-once"]
)
-
-(macro: #export (log-type! tokens)
- (case tokens
- (#.Cons [_ (#.Symbol valueN)] #.Nil)
- (do Monad<Meta>
- [cursor ..cursor
- valueT (find-type valueN)
- #let [_ (log! ($_ text/compose
- "log-type!" " @ " (cursor-description cursor) "\n"
- (code.to-text (code.symbol valueN)) " : " (type.to-text valueT) "\n"))]]
- (wrap (list (' []))))
-
- (#.Cons valueC #.Nil)
- (|> (` (.let [(~ g!value) (~ valueC)]
- (..log-type! (~ g!value))))
- (let [g!value (code.local-symbol (code.to-text valueC))])
- list
- (:: Monad<Meta> wrap))
-
- _
- (fail "Wrong syntax for log-type!.")
- ))
diff --git a/stdlib/source/lux/macro/code.lux b/stdlib/source/lux/macro/code.lux
index cde2f97fe..f537eedac 100644
--- a/stdlib/source/lux/macro/code.lux
+++ b/stdlib/source/lux/macro/code.lux
@@ -3,7 +3,7 @@
(lux (control [equality #+ Eq])
(data bool
number
- [text #+ Eq<Text> "Text/" Monoid<Text>]
+ [text #+ Eq<Text> "text/" Monoid<Text>]
ident
(coll [list #* "" Functor<List> Fold<List>])
)))
@@ -109,16 +109,16 @@
(text.encode value)
[_ (#.Tag ident)]
- (Text/compose "#" (:: Codec<Text,Ident> encode ident))
+ (text/compose "#" (:: Codec<Text,Ident> encode ident))
(^template [<tag> <open> <close>]
[_ (<tag> members)]
- ($_ Text/compose <open> (|> members (map to-text) (interpose " ") (text.join-with "")) <close>))
+ ($_ text/compose <open> (|> members (map to-text) (interpose " ") (text.join-with "")) <close>))
([#.Form "(" ")"]
[#.Tuple "[" "]"])
[_ (#.Record pairs)]
- ($_ Text/compose "{" (|> pairs (map (function (_ [left right]) ($_ Text/compose (to-text left) " " (to-text right)))) (interpose " ") (text.join-with "")) "}")
+ ($_ text/compose "{" (|> pairs (map (function (_ [left right]) ($_ text/compose (to-text left) " " (to-text right)))) (interpose " ") (text.join-with "")) "}")
))
(def: #export (replace original substitute ast)
diff --git a/stdlib/source/lux/macro/syntax.lux b/stdlib/source/lux/macro/syntax.lux
index 0268cae29..c26cb7327 100644
--- a/stdlib/source/lux/macro/syntax.lux
+++ b/stdlib/source/lux/macro/syntax.lux
@@ -9,9 +9,8 @@
[text "text/" Monoid<Text>]
[ident]
(coll [list "list/" Functor<List>])
- [product]
[maybe]
- ["e" error]))
+ [error #+ Error]))
(// [code "code/" Eq<Code>]))
## [Utils]
@@ -38,8 +37,8 @@
(Syntax Code)
(function (_ tokens)
(case tokens
- #.Nil (#e.Error "There are no tokens to parse!")
- (#.Cons [t tokens']) (#e.Success [tokens' t]))))
+ #.Nil (#error.Error "There are no tokens to parse!")
+ (#.Cons [t tokens']) (#error.Success [tokens' t]))))
(do-template [<get-name> <type> <tag> <eq> <desc>]
[(def: #export <get-name>
@@ -48,15 +47,15 @@
(function (_ tokens)
(case tokens
(#.Cons [[_ (<tag> x)] tokens'])
- (#e.Success [tokens' x])
+ (#error.Success [tokens' x])
_
- (#e.Error ($_ text/compose "Cannot parse " <desc> (remaining-inputs tokens))))))]
+ (#error.Error ($_ text/compose "Cannot parse " <desc> (remaining-inputs tokens))))))]
[ bool Bool #.Bool bool.Eq<Bool> "bool"]
[ nat Nat #.Nat number.Eq<Nat> "nat"]
[ int Int #.Int number.Eq<Int> "int"]
- [ deg Deg #.Deg number.Eq<Deg> "deg"]
+ [ deg Deg #.Deg number.Eq<Deg> "deg"]
[ frac Frac #.Frac number.Eq<Frac> "frac"]
[ text Text #.Text text.Eq<Text> "text"]
[symbol Ident #.Symbol ident.Eq<Ident> "symbol"]
@@ -73,10 +72,10 @@
remaining (if is-it?
tokens'
tokens)]
- (#e.Success [remaining is-it?]))
+ (#error.Success [remaining is-it?]))
_
- (#e.Success [tokens false]))))
+ (#error.Success [tokens false]))))
(def: #export (this ast)
{#.doc "Ensures the given Code is the next input."}
@@ -85,12 +84,12 @@
(case tokens
(#.Cons [token tokens'])
(if (code/= ast token)
- (#e.Success [tokens' []])
- (#e.Error ($_ text/compose "Expected a " (code.to-text ast) " but instead got " (code.to-text token)
- (remaining-inputs tokens))))
+ (#error.Success [tokens' []])
+ (#error.Error ($_ text/compose "Expected a " (code.to-text ast) " but instead got " (code.to-text token)
+ (remaining-inputs tokens))))
_
- (#e.Error "There are no tokens to parse!"))))
+ (#error.Error "There are no tokens to parse!"))))
(do-template [<name> <tag> <desc>]
[(def: #export <name>
@@ -99,10 +98,10 @@
(function (_ tokens)
(case tokens
(#.Cons [[_ (<tag> ["" x])] tokens'])
- (#e.Success [tokens' x])
+ (#error.Success [tokens' x])
_
- (#e.Error ($_ text/compose "Cannot parse local " <desc> (remaining-inputs tokens))))))]
+ (#error.Error ($_ text/compose "Cannot parse local " <desc> (remaining-inputs tokens))))))]
[local-symbol #.Symbol "symbol"]
[ local-tag #.Tag "tag"]
@@ -117,11 +116,11 @@
(case tokens
(#.Cons [[_ (<tag> members)] tokens'])
(case (p members)
- (#e.Success [#.Nil x]) (#e.Success [tokens' x])
- _ (#e.Error ($_ text/compose "Syntax was expected to fully consume " <desc> (remaining-inputs tokens))))
+ (#error.Success [#.Nil x]) (#error.Success [tokens' x])
+ _ (#error.Error ($_ text/compose "Syntax was expected to fully consume " <desc> (remaining-inputs tokens))))
_
- (#e.Error ($_ text/compose "Cannot parse " <desc> (remaining-inputs tokens))))))]
+ (#error.Error ($_ text/compose "Cannot parse " <desc> (remaining-inputs tokens))))))]
[ form #.Form "form"]
[tuple #.Tuple "tuple"]
@@ -135,61 +134,61 @@
(case tokens
(#.Cons [[_ (#.Record pairs)] tokens'])
(case (p (join-pairs pairs))
- (#e.Success [#.Nil x]) (#e.Success [tokens' x])
- _ (#e.Error ($_ text/compose "Syntax was expected to fully consume record" (remaining-inputs tokens))))
+ (#error.Success [#.Nil x]) (#error.Success [tokens' x])
+ _ (#error.Error ($_ text/compose "Syntax was expected to fully consume record" (remaining-inputs tokens))))
_
- (#e.Error ($_ text/compose "Cannot parse record" (remaining-inputs tokens))))))
+ (#error.Error ($_ text/compose "Cannot parse record" (remaining-inputs tokens))))))
(def: #export end!
{#.doc "Ensures there are no more inputs."}
(Syntax Any)
(function (_ tokens)
(case tokens
- #.Nil (#e.Success [tokens []])
- _ (#e.Error ($_ text/compose "Expected list of tokens to be empty!" (remaining-inputs tokens))))))
+ #.Nil (#error.Success [tokens []])
+ _ (#error.Error ($_ text/compose "Expected list of tokens to be empty!" (remaining-inputs tokens))))))
(def: #export end?
{#.doc "Checks whether there are no more inputs."}
(Syntax Bool)
(function (_ tokens)
(case tokens
- #.Nil (#e.Success [tokens true])
- _ (#e.Success [tokens false]))))
+ #.Nil (#error.Success [tokens true])
+ _ (#error.Success [tokens false]))))
(def: #export (on compiler action)
{#.doc "Run a Lux operation as if it was a Syntax parser."}
(All [a] (-> Lux (Meta a) (Syntax a)))
(function (_ input)
(case (macro.run compiler action)
- (#e.Error error)
- (#e.Error error)
+ (#error.Error error)
+ (#error.Error error)
- (#e.Success value)
- (#e.Success [input value])
+ (#error.Success value)
+ (#error.Success [input value])
)))
(def: #export (run inputs syntax)
- (All [a] (-> (List Code) (Syntax a) (e.Error a)))
+ (All [a] (-> (List Code) (Syntax a) (Error a)))
(case (syntax inputs)
- (#e.Error error)
- (#e.Error error)
+ (#error.Error error)
+ (#error.Error error)
- (#e.Success [unconsumed value])
+ (#error.Success [unconsumed value])
(case unconsumed
#.Nil
- (#e.Success value)
+ (#error.Success value)
_
- (#e.Error (text/compose "Unconsumed inputs: "
- (|> (list/map code.to-text unconsumed)
- (text.join-with ", ")))))))
+ (#error.Error (text/compose "Unconsumed inputs: "
+ (|> (list/map code.to-text unconsumed)
+ (text.join-with ", ")))))))
(def: #export (local inputs syntax)
{#.doc "Run a syntax parser with the given list of inputs, instead of the real ones."}
(All [a] (-> (List Code) (Syntax a) (Syntax a)))
(function (_ real)
- (do e.Monad<Error>
+ (do error.Monad<Error>
[value (run inputs syntax)]
(wrap [real value]))))
@@ -233,7 +232,7 @@
#.None))]
(case ?parts
(#.Some [name args meta body])
- (with-gensyms [g!text/join-with g!tokens g!body g!error]
+ (with-gensyms [g!tokens g!body g!error]
(do macro.Monad<Meta>
[vars+parsers (monad.map @
(: (-> Code (Meta [Code Code]))
@@ -263,12 +262,11 @@
((~' wrap) ((~! do) (~! macro.Monad<Meta>)
[]
(~ body))))))
- {(#e.Success (~ g!body))
+ {(#error.Success (~ g!body))
((~ g!body) (~ g!state))
- (#e.Error (~ g!error))
- (let [(~ g!text/join-with) (~! text.join-with)]
- (#e.Error ((~ g!text/join-with) ": " (list (~ error-msg) (~ g!error)))))})))))))
+ (#error.Error (~ g!error))
+ (#error.Error ((~! text.join-with) ": " (list (~ error-msg) (~ g!error))))})))))))
_
(macro.fail "Wrong syntax for syntax:"))))
diff --git a/stdlib/source/lux/type/abstract.lux b/stdlib/source/lux/type/abstract.lux
index 70a71c60b..f7594852d 100644
--- a/stdlib/source/lux/type/abstract.lux
+++ b/stdlib/source/lux/type/abstract.lux
@@ -10,7 +10,8 @@
["s" syntax #+ syntax:]
(syntax ["cs" common]
(common ["csr" reader]
- ["csw" writer])))))
+ ["csw" writer])))
+ (lang [type #+ :cast])))
(def: (get k plist)
(All [a]
@@ -57,18 +58,16 @@
(|>> ($_ text/compose "{" kind "@" module "}")
(let [[module kind] (ident-for #..Representation)])))
-(def: (cast name type-vars input-declaration output-declaration)
- (-> Text (List Code) Code Code Macro)
+(def: (cast type-vars input-declaration output-declaration)
+ (-> (List Code) Code Code Macro)
(function (_ tokens)
(case tokens
(^ (list value))
- (meta/wrap (list (` ((: (All [(~+ type-vars)]
- (-> (~ input-declaration) (~ output-declaration)))
- (|>> :assume))
+ (meta/wrap (list (` ((~! :cast) [(~+ type-vars)] (~ input-declaration) (~ output-declaration)
(~ value)))))
_
- (macro.fail ($_ text/compose "Wrong syntax for " name)))))
+ (meta/wrap (list (` ((~! :cast) [(~+ type-vars)] (~ input-declaration) (~ output-declaration))))))))
(def: (install-casts' this-module-name name type-vars)
(-> Text Text (List Text) (Meta Any))
@@ -80,10 +79,10 @@
this-module (|> this-module
(update@ #.definitions (put down-cast (: Definition
[Macro macro-anns
- (cast down-cast type-varsC representation-declaration abstraction-declaration)])))
+ (cast type-varsC representation-declaration abstraction-declaration)])))
(update@ #.definitions (put up-cast (: Definition
[Macro macro-anns
- (cast up-cast type-varsC abstraction-declaration representation-declaration)]))))]]
+ (cast type-varsC abstraction-declaration representation-declaration)]))))]]
(function (_ compiler)
(#error.Success [(update@ #.modules (put this-module-name this-module) compiler)
[]]))))
generated by cgit v1.2.3 (git 2.25.1) at 2024-07-08 04:36:16 +0000