diff options
Diffstat (limited to '')
| -rw-r--r-- | stdlib/source/lux.lux | 9 | ||||
| -rw-r--r-- | stdlib/source/lux/data/text/format.lux | 4 | ||||
| -rw-r--r-- | stdlib/source/lux/lang/type.lux | 44 | ||||
| -rw-r--r-- | stdlib/source/lux/macro.lux | 55 | ||||
| -rw-r--r-- | stdlib/source/lux/macro/code.lux | 8 | ||||
| -rw-r--r-- | stdlib/source/lux/macro/syntax.lux | 84 | ||||
| -rw-r--r-- | stdlib/source/lux/type/abstract.lux | 17 |
7 files changed, 121 insertions, 100 deletions
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) []])))) |