From 6979cbb0e4d04a65c041381237aa034b4b708550 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Mon, 19 Jun 2017 20:03:02 -0400 Subject: - Split "lux/macro/syntax/common" into 2 other sub-modules ("reader" and "writer"). --- stdlib/source/lux/concurrency/actor.lux | 20 +-- stdlib/source/lux/control/effect.lux | 28 ++-- stdlib/source/lux/control/exception.lux | 18 ++- stdlib/source/lux/macro/poly.lux | 14 +- stdlib/source/lux/macro/syntax/common.lux | 178 ++--------------------- stdlib/source/lux/macro/syntax/common/reader.lux | 146 +++++++++++++++++++ stdlib/source/lux/macro/syntax/common/writer.lux | 24 +++ 7 files changed, 225 insertions(+), 203 deletions(-) create mode 100644 stdlib/source/lux/macro/syntax/common/reader.lux create mode 100644 stdlib/source/lux/macro/syntax/common/writer.lux (limited to 'stdlib/source') diff --git a/stdlib/source/lux/concurrency/actor.lux b/stdlib/source/lux/concurrency/actor.lux index e9a6b5d37..9062feb73 100644 --- a/stdlib/source/lux/concurrency/actor.lux +++ b/stdlib/source/lux/concurrency/actor.lux @@ -11,7 +11,9 @@ [macro #+ with-gensyms] (macro [code] ["s" syntax #+ syntax: Syntax] - (syntax [common])) + (syntax ["cs" common] + (common ["csr" reader] + ["csw" writer]))) [type]) (.. ["P" promise #+ Monad] [stm #+ Monad] @@ -153,7 +155,7 @@ vars (s;default (list) (s;tuple (s;some s;local-symbol))) [name args] (s;form ($_ s;seq s;local-symbol - (s;many common;typed-input) + (s;many csr;typed-input) )) return s;any body s;any] @@ -172,7 +174,7 @@ (def: actor-decl^ (Syntax [(List Text) Text (List [Text Code])]) (s;seq (s;default (list) (s;tuple (s;some s;local-symbol))) - (s;either (s;form (s;seq s;local-symbol (s;many common;typed-input))) + (s;either (s;form (s;seq s;local-symbol (s;many csr;typed-input))) (s;seq s;local-symbol (:: s;Monad wrap (list)))))) (def: (actor-def-decl [_vars _name _args] return-type) @@ -190,7 +192,7 @@ (list decl type))) -(syntax: #export (actor: [_ex-lev common;export] +(syntax: #export (actor: [_ex-lev csr;export] [(^@ decl [_vars _name _args]) actor-decl^] state-type [methods (s;many method^)] @@ -264,16 +266,16 @@ type (` (-> (~@ (List/map product;right args)) (~ g!actor-name) (P;Promise (~ return))))] - (` (def: (~@ (common;gen-export _ex-lev)) ((~ (code;symbol ["" name])) (~@ arg-names) (~ g!self)) + (` (def: (~@ (csw;export _ex-lev)) ((~ (code;symbol ["" name])) (~@ arg-names) (~ g!self)) (~ type) (let [(~ g!output) (P;promise (~ return))] (exec (send ((~ (code;tag ["" name])) [[(~@ arg-names)] (~ g!output)]) (~ g!self)) (~ g!output)))))))) methods)] - (wrap (list& (` (type: (~@ (common;gen-export _ex-lev)) (~ g!state-name) (~ state-type))) - (` (type: (~@ (common;gen-export _ex-lev)) (~ g!protocol-name) (~@ protocol))) - (` (type: (~@ (common;gen-export _ex-lev)) (~ g!actor-name) (Actor (~ g!state-name) (~ g!protocol-name)))) - (` (def: (~@ (common;gen-export _ex-lev)) (~@ (actor-def-decl decl (` (Behavior (~ g!state-name) (~ g!protocol-name))))) + (wrap (list& (` (type: (~@ (csw;export _ex-lev)) (~ g!state-name) (~ state-type))) + (` (type: (~@ (csw;export _ex-lev)) (~ g!protocol-name) (~@ protocol))) + (` (type: (~@ (csw;export _ex-lev)) (~ g!actor-name) (Actor (~ g!state-name) (~ g!protocol-name)))) + (` (def: (~@ (csw;export _ex-lev)) (~@ (actor-def-decl decl (` (Behavior (~ g!state-name) (~ g!protocol-name))))) (~ g!behavior))) g!methods)) ))) diff --git a/stdlib/source/lux/control/effect.lux b/stdlib/source/lux/control/effect.lux index 81f976e98..939bd28f5 100644 --- a/stdlib/source/lux/control/effect.lux +++ b/stdlib/source/lux/control/effect.lux @@ -12,7 +12,9 @@ [macro] (macro [code] ["s" syntax #+ syntax: Syntax] - (syntax [common])) + (syntax ["cs" common] + (common ["csr" reader] + ["csw" writer]))) [type])) ## [Type] @@ -92,7 +94,7 @@ (:: s;Monad wrap (list)) s;any)))) -(syntax: #export (effect: [exp-lvl common;export] +(syntax: #export (effect: [exp-lvl csr;export] [name s;local-symbol] [ops (s;many op^)]) {#;doc (doc "Define effects by specifying which operations and constants a handler must provide." @@ -111,12 +113,12 @@ (` ((~ g!tag) (~ g!inputs) (~ g!output))))) ops) type-name (code;symbol ["" name]) - type-def (` (type: (~@ (common;gen-export exp-lvl)) + type-def (` (type: (~@ (csw;export exp-lvl)) ((~ type-name) (~ g!output)) (~@ op-types))) op-tags (List/map (|>. (get@ #name) [""] code;tag (list) code;tuple) ops) - functor-def (` (struct: (~@ (common;gen-export exp-lvl)) (~' _) (F;Functor (~ type-name)) + functor-def (` (struct: (~@ (csw;export exp-lvl)) (~' _) (F;Functor (~ type-name)) (def: ((~' map) (~' f) (~' fa)) (case (~' fa) (^template [(~' )] @@ -135,7 +137,7 @@ (format "_") [""] code;symbol)))))] - (` (def: (~@ (common;gen-export exp-lvl)) ((~ g!name) (~@ g!params)) + (` (def: (~@ (csw;export exp-lvl)) ((~ g!name) (~@ g!params)) (-> (~@ (get@ #inputs op)) ((~ type-name) (~ (get@ #output op)))) ((~ g!tag) [(~@ g!params)] ;id))))) @@ -157,10 +159,10 @@ (s;tuple (s;seq s;any s;any)))))) -(syntax: #export (handler: [exp-lvl common;export] +(syntax: #export (handler: [exp-lvl csr;export] [name s;local-symbol] [[effect target-type target-monad] translation^] - [defs (s;many (common;definition *compiler*))]) + [defs (s;many (csr;definition *compiler*))]) {#;doc (doc "Define effect handlers by implementing the operations and values of an effect." (handler: _ (=> EffA [IO Monad]) @@ -179,15 +181,15 @@ g!wrap (macro;gensym "wrap") #let [g!cases (|> defs (List/map (function [def] - (let [g!tag (code;tag [e-module (get@ #common;definition-name def)]) + (let [g!tag (code;tag [e-module (get@ #cs;definition-name def)]) g!args (List/map (|>. [""] code;symbol) - (get@ #common;definition-args def)) - eff-calc (case (get@ #common;definition-type def) + (get@ #cs;definition-args def)) + eff-calc (case (get@ #cs;definition-type def) #;None - (get@ #common;definition-value def) + (get@ #cs;definition-value def) (#;Some type) - (` (: (~ type) (~ (get@ #common;definition-value def))))) + (` (: (~ type) (~ (get@ #cs;definition-value def))))) invocation (case g!args #;Nil eff-calc @@ -201,7 +203,7 @@ ((~ g!wrap) ((~ g!cont) (~ g!value))))) )))) List/join)]] - (wrap (list (` (struct: (~@ (common;gen-export exp-lvl)) (~ (code;symbol ["" name])) + (wrap (list (` (struct: (~@ (csw;export exp-lvl)) (~ (code;symbol ["" name])) (;;Handler (~ (code;symbol effect)) (~ target-type)) (def: (~' monad) (~ target-monad)) diff --git a/stdlib/source/lux/control/exception.lux b/stdlib/source/lux/control/exception.lux index 6bccbeec8..ef0419b98 100644 --- a/stdlib/source/lux/control/exception.lux +++ b/stdlib/source/lux/control/exception.lux @@ -6,7 +6,9 @@ [macro] (macro [code] ["s" syntax #+ syntax: Syntax] - (syntax [common])))) + (syntax ["cs" common] + (common ["csr" reader] + ["csw" writer]))))) ## [Types] (type: #export Exception @@ -30,9 +32,13 @@ (#R;Success output) (#R;Error error) - (if (text;starts-with? (exception "") error) - (#R;Success (then error)) - (#R;Error error)))) + (let [reference (exception "")] + (if (text;starts-with? reference error) + (#R;Success (|> error + (text;clip (text;size reference) (text;size error)) + assume + then)) + (#R;Error error))))) (def: #export (otherwise to-do try) {#;doc "If no handler could be found to catch the exception, then run a function as a last-resort measure."} @@ -55,13 +61,13 @@ (All [a] (-> Exception Text (Result a))) (#R;Error (exception message))) -(syntax: #export (exception: [_ex-lev common;export] [name s;local-symbol]) +(syntax: #export (exception: [_ex-lev csr;export] [name s;local-symbol]) {#;doc (doc "Define a new exception type." "It moslty just serves as a way to tag error messages for later catching." (exception: #export Some-Exception))} (do @ [current-module macro;current-module-name #let [g!message (code;symbol ["" "message"])]] - (wrap (list (` (def: (~@ (common;gen-export _ex-lev)) ((~ (code;symbol ["" name])) (~ g!message)) + (wrap (list (` (def: (~@ (csw;export _ex-lev)) ((~ (code;symbol ["" name])) (~ g!message)) Exception ($_ _Text/append_ "[" (~ (code;text current-module)) ";" (~ (code;text name)) "]\t" (~ g!message)))))))) diff --git a/stdlib/source/lux/macro/poly.lux b/stdlib/source/lux/macro/poly.lux index fef8945c3..67a2a5013 100644 --- a/stdlib/source/lux/macro/poly.lux +++ b/stdlib/source/lux/macro/poly.lux @@ -15,7 +15,9 @@ [macro #+ Monad with-gensyms] (macro [code] ["s" syntax #+ syntax: Syntax] - (syntax [common])) + (syntax ["cs" common] + (common ["csr" reader] + ["csw" writer]))) [type] )) @@ -309,7 +311,7 @@ type-vars') )))) -(syntax: #export (poly: [_ex-lev common;export] +(syntax: #export (poly: [_ex-lev csr;export] [[name env inputs] (s;form ($_ s;seq s;local-symbol s;local-symbol @@ -319,8 +321,8 @@ (let [g!inputs (List/map (|>. [""] code;symbol) inputs) g!name (code;symbol ["" name]) g!env (code;symbol ["" env])] - (wrap (;list (` (syntax: (~@ (common;gen-export _ex-lev)) ((~ g!name) (~@ (List/map (;function [g!input] (` [(~ g!input) s;symbol])) - g!inputs))) + (wrap (;list (` (syntax: (~@ (csw;export _ex-lev)) ((~ g!name) (~@ (List/map (;function [g!input] (` [(~ g!input) s;symbol])) + g!inputs))) (do Monad [(~@ (List/join (List/map (;function [g!input] (;list g!input (` (macro;find-type-def (~ g!input))))) g!inputs))) @@ -343,7 +345,7 @@ (#;Some (List/fold (text;replace-once "?") poly args)) #;None)) -(syntax: #export (derived: [_ex-lev common;export] +(syntax: #export (derived: [_ex-lev csr;export] [?name (s;opt s;local-symbol)] [[poly-func poly-args] (s;form (s;seq s;symbol (s;many s;symbol)))] [?custom-impl (s;opt s;any)]) @@ -366,7 +368,7 @@ #;None (` ((~ (code;symbol poly-func)) (~@ (List/map code;symbol poly-args)))))]] - (wrap (;list (` (def: (~@ (common;gen-export _ex-lev)) + (wrap (;list (` (def: (~@ (csw;export _ex-lev)) (~ (code;symbol ["" name])) {#;struct? true} (~ impl))))))) diff --git a/stdlib/source/lux/macro/syntax/common.lux b/stdlib/source/lux/macro/syntax/common.lux index a4b6928c9..72e52a4ab 100644 --- a/stdlib/source/lux/macro/syntax/common.lux +++ b/stdlib/source/lux/macro/syntax/common.lux @@ -1,165 +1,16 @@ -(;module: {#;doc "Commons syntax parsers and generators. +(;module: {#;doc "Commons syntax readers and writers. The goal is to be able to reuse common syntax in macro definitions across libraries."} - lux - (lux (control monad) - (data (coll [list "L/" Functor]) - text/format - [ident "Ident/" Eq] - [product]) - [macro] - (macro [code] - ["s" syntax #+ syntax: Syntax]))) + lux) -## Exports (type: #export Export #Exported #Hidden) -(def: #export export - {#;doc (doc "A parser for export levels." - "Such as:" - #export - #hidden)} - (Syntax (Maybe Export)) - (s;opt (s;alt (s;this (' #export)) - (s;this (' #hidden))))) - -(def: #export (gen-export ?el) - (-> (Maybe Export) (List Code)) - (case ?el - #;None - (list) - - (#;Some #Exported) - (list (' #export)) - - (#;Some #Hidden) - (list (' #hidden)))) - -## Declarations (type: #export Declaration {#declaration-name Text #declaration-args (List Text)}) -(def: #export declaration - {#;doc (doc "A parser for declaration syntax." - "Such as:" - quux - (foo bar baz))} - (Syntax Declaration) - (s;either (s;seq s;local-symbol - (:: s;Monad wrap (list))) - (s;form (s;seq s;local-symbol - (s;many s;local-symbol))))) - -## Definitions -(type: #export Definition - {#definition-name Text - #definition-type (Maybe Code) - #definition-value Code - #definition-anns (List [Ident Code]) - #definition-args (List Text) - }) - -(def: check^ - (Syntax [(Maybe Code) Code]) - (s;either (s;form (do s;Monad - [_ (s;this (' lux;_lux_:)) - type s;any - value s;any] - (wrap [(#;Some type) value]))) - (s;seq (:: s;Monad wrap #;None) - s;any))) - -(def: _definition-anns-tag^ - (Syntax Ident) - (s;tuple (s;seq s;text s;text))) - -(def: (_definition-anns^ _) - (-> Top (Syntax (List [Ident Code]))) - (s;alt (s;this (' #lux;Nil)) - (s;form (do s;Monad - [_ (s;this (' #lux;Cons)) - [head tail] (s;seq (s;tuple (s;seq _definition-anns-tag^ s;any)) - (_definition-anns^ []))] - (wrap [head tail]))) - )) - -(def: (flat-list^ _) - (-> Top (Syntax (List Code))) - (s;either (do s;Monad - [_ (s;this (' #lux;Nil))] - (wrap (list))) - (s;form (do s;Monad - [_ (s;this (' #lux;Cons)) - [head tail] (s;tuple (s;seq s;any s;any)) - tail (s;local (list tail) (flat-list^ []))] - (wrap (#;Cons head tail)))))) - -(def: list-meta^ - (Syntax (List Code)) - (s;form (do s;Monad - [_ (s;this (' #lux;ListA))] - (flat-list^ [])))) - -(def: text-meta^ - (Syntax Text) - (s;form (do s;Monad - [_ (s;this (' #lux;TextA))] - s;text))) - -(def: (find-definition-args meta-data) - (-> (List [Ident Code]) (List Text)) - (default (list) - (case (list;find (|>. product;left (Ident/= ["lux" "func-args"])) meta-data) - (^multi (#;Some [_ value]) - [(s;run (list value) list-meta^) - (#;Right [_ args])] - [(s;run args (s;some text-meta^)) - (#;Right [_ args])]) - (#;Some args) - - _ - #;None) - )) - -(def: #export (definition compiler) - {#;doc "A parser that first macro-expands and then analyses the input Code, to ensure it's a definition."} - (-> Compiler (Syntax Definition)) - (do s;Monad - [definition-raw s;any - me-definition-raw (s;on compiler - (macro;macro-expand-all definition-raw))] - (s;local me-definition-raw - (s;form (do @ - [_ (s;this (' lux;_lux_def)) - definition-name s;local-symbol - [?definition-type definition-value] check^ - definition-anns s;any - definition-anns (s;local (list definition-anns) - (_definition-anns^ [])) - #let [definition-args (find-definition-args definition-anns)]] - (wrap {#definition-name definition-name - #definition-type ?definition-type - #definition-anns definition-anns - #definition-value definition-value - #definition-args definition-args})))))) - -(def: #export (typed-definition compiler) - {#;doc "A parser for definitions that ensures the input syntax is typed."} - (-> Compiler (Syntax Definition)) - (do s;Monad - [_definition (definition compiler) - _ (case (get@ #definition-type _definition) - (#;Some _) - (wrap []) - - #;None - (s;fail "Typed definition must have a type!") - )] - (wrap _definition))) - (type: #export Annotations (List [Ident Code])) @@ -167,21 +18,10 @@ Annotations (list)) -(def: #export annotations - {#;doc "Parser for the common annotations syntax used by def: statements."} - (Syntax Annotations) - (s;record (s;some (s;seq s;tag s;any)))) - -(def: #export (gen-annotations annotations) - (-> Annotations Code) - (|> annotations (L/map (product;both code;tag id)) code;record)) - -(def: #export typed-input - {#;doc "Parser for the common typed-argument syntax used by many macros."} - (Syntax [Text Code]) - (s;tuple (s;seq s;local-symbol s;any))) - -(def: #export type-variables - {#;doc "Parser for the common type var/param used by many macros."} - (Syntax (List Text)) - (s;tuple (s;some s;local-symbol))) +(type: #export Definition + {#definition-name Text + #definition-type (Maybe Code) + #definition-value Code + #definition-anns Annotations + #definition-args (List Text) + }) diff --git a/stdlib/source/lux/macro/syntax/common/reader.lux b/stdlib/source/lux/macro/syntax/common/reader.lux new file mode 100644 index 000000000..19a454ba8 --- /dev/null +++ b/stdlib/source/lux/macro/syntax/common/reader.lux @@ -0,0 +1,146 @@ +(;module: {#;doc "Commons syntax readers."} + lux + (lux (control monad) + (data (coll [list "L/" Functor]) + [ident "Ident/" Eq] + [product]) + [macro] + (macro ["s" syntax #+ syntax: Syntax])) + [.. #*]) + +## Exports +(def: #export export + {#;doc (doc "A reader for export levels." + "Such as:" + #export + #hidden)} + (Syntax (Maybe Export)) + (s;opt (s;alt (s;this (' #export)) + (s;this (' #hidden))))) + +## Declarations +(def: #export declaration + {#;doc (doc "A reader for declaration syntax." + "Such as:" + quux + (foo bar baz))} + (Syntax Declaration) + (s;either (s;seq s;local-symbol + (:: s;Monad wrap (list))) + (s;form (s;seq s;local-symbol + (s;many s;local-symbol))))) + +## Annotations +(def: #export annotations + {#;doc "Reader for the common annotations syntax used by def: statements."} + (Syntax Annotations) + (s;record (s;some (s;seq s;tag s;any)))) + +## Definitions +(def: check^ + (Syntax [(Maybe Code) Code]) + (s;either (s;form (do s;Monad + [_ (s;this (' lux;_lux_:)) + type s;any + value s;any] + (wrap [(#;Some type) value]))) + (s;seq (:: s;Monad wrap #;None) + s;any))) + +(def: _definition-anns-tag^ + (Syntax Ident) + (s;tuple (s;seq s;text s;text))) + +(def: (_definition-anns^ _) + (-> Top (Syntax Annotations)) + (s;alt (s;this (' #lux;Nil)) + (s;form (do s;Monad + [_ (s;this (' #lux;Cons)) + [head tail] (s;seq (s;tuple (s;seq _definition-anns-tag^ s;any)) + (_definition-anns^ []))] + (wrap [head tail]))) + )) + +(def: (flat-list^ _) + (-> Top (Syntax (List Code))) + (s;either (do s;Monad + [_ (s;this (' #lux;Nil))] + (wrap (list))) + (s;form (do s;Monad + [_ (s;this (' #lux;Cons)) + [head tail] (s;tuple (s;seq s;any s;any)) + tail (s;local (list tail) (flat-list^ []))] + (wrap (#;Cons head tail)))))) + +(def: list-meta^ + (Syntax (List Code)) + (s;form (do s;Monad + [_ (s;this (' #lux;ListA))] + (flat-list^ [])))) + +(def: text-meta^ + (Syntax Text) + (s;form (do s;Monad + [_ (s;this (' #lux;TextA))] + s;text))) + +(def: (find-definition-args meta-data) + (-> (List [Ident Code]) (List Text)) + (default (list) + (case (list;find (|>. product;left (Ident/= ["lux" "func-args"])) meta-data) + (^multi (#;Some [_ value]) + [(s;run (list value) list-meta^) + (#;Right [_ args])] + [(s;run args (s;some text-meta^)) + (#;Right [_ args])]) + (#;Some args) + + _ + #;None) + )) + +(def: #export (definition compiler) + {#;doc "A reader that first macro-expands and then analyses the input Code, to ensure it's a definition."} + (-> Compiler (Syntax Definition)) + (do s;Monad + [definition-raw s;any + me-definition-raw (s;on compiler + (macro;macro-expand-all definition-raw))] + (s;local me-definition-raw + (s;form (do @ + [_ (s;this (' lux;_lux_def)) + definition-name s;local-symbol + [?definition-type definition-value] check^ + definition-anns s;any + definition-anns (s;local (list definition-anns) + (_definition-anns^ [])) + #let [definition-args (find-definition-args definition-anns)]] + (wrap {#..;definition-name definition-name + #..;definition-type ?definition-type + #..;definition-anns definition-anns + #..;definition-value definition-value + #..;definition-args definition-args})))))) + +(def: #export (typed-definition compiler) + {#;doc "A reader for definitions that ensures the input syntax is typed."} + (-> Compiler (Syntax Definition)) + (do s;Monad + [_definition (definition compiler) + _ (case (get@ #..;definition-type _definition) + (#;Some _) + (wrap []) + + #;None + (s;fail "Typed definition must have a type!") + )] + (wrap _definition))) + +(def: #export typed-input + {#;doc "Reader for the common typed-argument syntax used by many macros."} + (Syntax [Text Code]) + (s;tuple (s;seq s;local-symbol s;any))) + +(def: #export type-variables + {#;doc "Reader for the common type var/param used by many macros."} + (Syntax (List Text)) + (s;tuple (s;some s;local-symbol))) diff --git a/stdlib/source/lux/macro/syntax/common/writer.lux b/stdlib/source/lux/macro/syntax/common/writer.lux new file mode 100644 index 000000000..72e4a11eb --- /dev/null +++ b/stdlib/source/lux/macro/syntax/common/writer.lux @@ -0,0 +1,24 @@ +(;module: {#;doc "Commons syntax writers."} + lux + (lux (data (coll [list "L/" Functor]) + [product]) + (macro [code])) + [.. #*]) + +## Exports +(def: #export (export ?el) + (-> (Maybe Export) (List Code)) + (case ?el + #;None + (list) + + (#;Some #..;Exported) + (list (' #export)) + + (#;Some #..;Hidden) + (list (' #hidden)))) + +## Annotations +(def: #export (annotations anns) + (-> Annotations Code) + (|> anns (L/map (product;both code;tag id)) code;record)) -- cgit v1.2.3