- WIP: Some initial implementations for some re-written infrastructure.

5 files changed, 278 insertions, 0 deletions

diff --git a/new-luxc/source/luxc/module.lux b/new-luxc/source/luxc/module.lux
new file mode 100644
index 000000000..2d48b3617
--- /dev/null
+++ b/new-luxc/source/luxc/module.lux
@@ -0,0 +1,6 @@
+(;module:
+  lux
+  (lux (control monad)
+       (data text/format))
+  (luxc ["&" base]))
+
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))