diff options
author | Eduardo Julian | 2017-05-01 18:15:14 -0400 |
---|---|---|
committer | Eduardo Julian | 2017-05-01 18:15:14 -0400 |
commit | 3175ae85d62ff6f692b8cc127f56c6569041d788 (patch) | |
tree | 83340fd6cb5c287f13080d7ead386b1d161b8e77 /new-luxc/source/luxc/module | |
parent | 94cca1d49c0d3f6d328a81eaf6ce9660a6f149c1 (diff) |
- WIP: Some initial implementations for some re-written infrastructure.
Diffstat (limited to 'new-luxc/source/luxc/module')
-rw-r--r-- | new-luxc/source/luxc/module/def.lux | 6 | ||||
-rw-r--r-- | new-luxc/source/luxc/module/descriptor/annotation.lux | 83 | ||||
-rw-r--r-- | new-luxc/source/luxc/module/descriptor/common.lux | 38 | ||||
-rw-r--r-- | new-luxc/source/luxc/module/descriptor/type.lux | 145 |
4 files changed, 272 insertions, 0 deletions
diff --git a/new-luxc/source/luxc/module/def.lux b/new-luxc/source/luxc/module/def.lux new file mode 100644 index 000000000..2d48b3617 --- /dev/null +++ b/new-luxc/source/luxc/module/def.lux @@ -0,0 +1,6 @@ +(;module: + lux + (lux (control monad) + (data text/format)) + (luxc ["&" base])) + diff --git a/new-luxc/source/luxc/module/descriptor/annotation.lux b/new-luxc/source/luxc/module/descriptor/annotation.lux new file mode 100644 index 000000000..9a687e02a --- /dev/null +++ b/new-luxc/source/luxc/module/descriptor/annotation.lux @@ -0,0 +1,83 @@ +(;module: + lux + (lux (control codec + monad) + (data [text] + (text format + ["l" lexer "l/" Monad<Lexer>]) + [char] + [number] + error + (coll [list "L/" Functor<List>]))) + ["&" ../common] + [luxc ["&;" parser]]) + +(def: dummy-cursor Cursor ["" +0 +0]) + +(do-template [<name> <code>] + [(def: <name> &;Signal <code>)] + + [ident-signal "@"] + [bool-signal "B"] + [nat-signal "N"] + [int-signal "I"] + [deg-signal "D"] + [real-signal "R"] + [char-signal "C"] + [text-signal "T"] + [list-signal "%"] + [dict-signal "#"] + ) + +(def: (encode-ident [module name]) + (-> Ident Text) + (format ident-signal + module &;ident-separator name + &;stop-signal)) + +(def: (encode-text value) + (-> Text Text) + (format text-signal + (%t value) + &;stop-signal)) + +(def: (encode-ann-value value) + (-> Ann-Value Text) + (case value + (^template [<tag> <signal> <encoder>] + (<tag> value) + (format <signal> + (<encoder> value) + &;stop-signal)) + ([#;BoolA bool-signal %b] + [#;NatA nat-signal %n] + [#;IntA int-signal %i] + [#;DegA deg-signal %d] + [#;RealA real-signal %r] + [#;CharA char-signal %c] + [#;TextA text-signal %t] + [#;IdentA ident-signal %ident] + [#;ListA list-signal (&;encode-list encode-ann-value)] + [#;DictA dict-signal (&;encode-list (function [[k v]] + (format (encode-text k) + (encode-ann-value v))))]))) + +(def: ann-value-decoder + (l;Lexer Ann-Value) + (let% [<simple> (do-template [<tag> <lexer> <signal>] + [(do l;Monad<Lexer> + [])])] + ($_ l;either + <simple> + (|> ... (l;after (l;text bool-signal))) + ))) + +(def: encode-anns + (-> Anns Text) + (&;encode-list (function [[ident value]] + (format (encode-ident ident) + (encode-ann-value value))))) + +(struct: #export _ (Codec Text Anns) + (def: encode encode-anns) + (def: decode decode-anns)) diff --git a/new-luxc/source/luxc/module/descriptor/common.lux b/new-luxc/source/luxc/module/descriptor/common.lux new file mode 100644 index 000000000..60a313115 --- /dev/null +++ b/new-luxc/source/luxc/module/descriptor/common.lux @@ -0,0 +1,38 @@ +(;module: + lux + (lux (data [text] + (text format + ["l" lexer "l/" Monad<Lexer>]) + [char] + (coll [list "L/" Functor<List>])))) + +(type: #export Signal Text) + +(do-template [<name> <code>] + [(def: #export <name> Signal (|> <code> char;char char;as-text))] + + [cons-signal +5] + [nil-signal +6] + [stop-signal +7] + ) + +(do-template [<name> <code>] + [(def: #export <name> Signal <code>)] + + [ident-separator ";"] + ) + +(def: #export (encode-list encode-elem types) + (All [a] (-> (-> a Text) (List a) Text)) + (format (|> (L/map encode-elem types) + (text;join-with cons-signal)) + nil-signal)) + +(def: #export (decode-list decode-elem) + (All [a] (-> (l;Lexer a) (l;Lexer (List a)))) + (l;alt (<| (l;after (l;text nil-signal)) + (l/wrap [])) + (<| (l;seq decode-elem) + (l;after (l;text cons-signal)) + (decode-list decode-elem)))) + diff --git a/new-luxc/source/luxc/module/descriptor/type.lux b/new-luxc/source/luxc/module/descriptor/type.lux new file mode 100644 index 000000000..c4078ec0e --- /dev/null +++ b/new-luxc/source/luxc/module/descriptor/type.lux @@ -0,0 +1,145 @@ +(;module: + lux + (lux (control codec + monad) + (data [text] + (text format + ["l" lexer "l/" Monad<Lexer>]) + [char] + [number] + error + (coll [list "L/" Functor<List>])) + [type "Type/" Eq<Type>]) + ["&" ../common]) + +(do-template [<name> <code>] + [(def: <name> &;Signal <code>)] + + [type-signal "T"] + [host-signal "^"] + [void-signal "0"] + [unit-signal "1"] + [product-signal "*"] + [sum-signal "+"] + [function-signal ">"] + [application-signal "%"] + [uq-signal "U"] + [eq-signal "E"] + [bound-signal "$"] + [ex-signal "!"] + [var-signal "?"] + [named-signal "@"] + ) + +(def: (encode-type type) + (-> Type Text) + (if (or (is Type type) + (Type/= Type type)) + type-signal + (case type + (#;HostT name params) + (format host-signal name &;stop-signal (&;encode-list encode-type params)) + + #;VoidT + void-signal + + #;UnitT + unit-signal + + (^template [<tag> <prefix>] + (<tag> left right) + (format <prefix> (encode-type left) (encode-type right))) + ([#;ProdT product-signal] + [#;SumT sum-signal] + [#;FunctionT function-signal] + [#;AppT application-signal]) + + + (^template [<tag> <prefix>] + (<tag> env body) + (format <prefix> (&;encode-list encode-type env) (encode-type body))) + ([#;UnivQ uq-signal] + [#;ExQ eq-signal]) + + (^template [<tag> <prefix>] + (<tag> idx) + (format <prefix> (%i (nat-to-int idx)) &;stop-signal)) + ([#;BoundT bound-signal] + [#;ExT ex-signal] + [#;VarT var-signal]) + + (#;NamedT [module name] type*) + (format named-signal module &;ident-separator name &;stop-signal (encode-type type*)) + ))) + +(def: type-decoder + (l;Lexer Type) + (l;rec + (function [type-decoder] + (let% [<simple> (do-template [<type> <signal>] + [(|> (l/wrap <type>) (l;after (l;text <signal>)))] + + [Type type-signal] + [#;VoidT void-signal] + [#;UnitT unit-signal]) + <combinators> (do-template [<tag> <prefix>] + [(do l;Monad<Lexer> + [_ (l;text <prefix>) + left type-decoder + right type-decoder] + (wrap (<tag> left right)))] + + [#;ProdT product-signal] + [#;SumT sum-signal] + [#;FunctionT function-signal] + [#;AppT application-signal]) + <abstractions> (do-template [<tag> <prefix>] + [(do l;Monad<Lexer> + [_ (l;text <prefix>) + env (&;decode-list type-decoder) + body type-decoder] + (wrap (<tag> env body)))] + + [#;UnivQ uq-signal] + [#;ExQ eq-signal]) + <wildcards> (do-template [<tag> <prefix>] + [(do l;Monad<Lexer> + [_ (l;text <prefix>) + id (l;codec number;Codec<Text,Int> + (l;some' l;digit)) + _ (l;text &;stop-signal)] + (wrap (<tag> (int-to-nat id))))] + + [#;BoundT bound-signal] + [#;ExT ex-signal] + [#;VarT var-signal])] + ($_ l;either + (do l;Monad<Lexer> + [_ (l;text host-signal) + name (l;many' (l;none-of &;stop-signal)) + _ (l;text &;stop-signal) + params (&;decode-list type-decoder)] + (wrap (#;HostT name params))) + <simple> + <combinators> + <abstractions> + <wildcards> + (do l;Monad<Lexer> + [_ (l;text named-signal) + module (l;some' (l;none-of &;ident-separator)) + _ (l;text &;ident-separator) + name (l;many' (l;none-of &;stop-signal)) + _ (l;text &;stop-signal) + unnamed type-decoder] + (wrap (#;NamedT [module name] unnamed))) + ))))) + +(def: (decode-type input) + (-> Text (Error Type)) + (|> type-decoder + (l;before l;end) + (l;run input))) + +(struct: #export _ (Codec Text Type) + (def: encode encode-type) + (def: decode decode-type)) |