1 files changed, 146 insertions, 0 deletions
diff --git a/stdlib/source/lux/macro/code.lux b/stdlib/source/lux/macro/code.lux
new file mode 100644
index 000000000..6d2dd4604
--- /dev/null
+++ b/stdlib/source/lux/macro/code.lux
@@ -0,0 +1,146 @@
+(;module:
+  lux
+  (lux (control eq)
+       (data bool
+             number
+             [char]
+             [text #+ Eq<Text> "Text/" Monoid<Text>]
+             ident
+             (coll [list #* "" Functor<List> Fold<List>])
+             )))
+
+## [Types]
+## (type: (Code' w)
+##   (#;Bool Bool)
+##   (#;Nat Nat)
+##   (#;Int Int)
+##   (#;Real Real)
+##   (#;Char Char)
+##   (#;Text Text)
+##   (#;Symbol Text Text)
+##   (#;Tag Text Text)
+##   (#;Form (List (w (Code' w))))
+##   (#;Tuple (List (w (Code' w))))
+##   (#;Record (List [(w (Code' w)) (w (Code' w))])))
+
+## (type: Code
+##   (Meta Cursor (Code' (Meta Cursor))))
+
+## [Utils]
+(def: _cursor Cursor ["" +0 +0])
+
+## [Functions]
+(do-template [<name> <type> <tag>]
+  [(def: #export (<name> x)
+     (-> <type> Code)
+     [_cursor (<tag> x)])]
+  
+  [bool   Bool              #;Bool]
+  [nat    Nat               #;Nat]
+  [int    Int               #;Int]
+  [deg    Deg               #;Deg]
+  [real   Real              #;Real]
+  [char   Char              #;Char]
+  [text   Text              #;Text]
+  [symbol Ident             #;Symbol]
+  [tag    Ident             #;Tag]
+  [form   (List Code)       #;Form]
+  [tuple  (List Code)       #;Tuple]
+  [record (List [Code Code]) #;Record]
+  )
+
+(do-template [<name> <tag> <doc>]
+  [(def: #export (<name> name)
+     {#;doc <doc>}
+     (-> Text Code)
+     [_cursor (<tag> ["" name])])]
+
+  [local-symbol #;Symbol "Produces a local symbol (a symbol with no module prefix)."]
+  [local-tag    #;Tag    "Produces a local tag (a tag with no module prefix)."])
+
+## [Structures]
+(struct: #export _ (Eq Code)
+  (def: (= x y)
+    (case [x y]
+      (^template [<tag> <eq>]
+        [[_ (<tag> x')] [_ (<tag> y')]]
+        (:: <eq> = x' y'))
+      ([#;Bool   Eq<Bool>]
+       [#;Nat    Eq<Nat>]
+       [#;Int    Eq<Int>]
+       [#;Deg    Eq<Deg>]
+       [#;Real   Eq<Real>]
+       [#;Char   char;Eq<Char>]
+       [#;Text   Eq<Text>]
+       [#;Symbol Eq<Ident>]
+       [#;Tag    Eq<Ident>])
+
+      (^template [<tag>]
+        [[_ (<tag> xs')] [_ (<tag> ys')]]
+        (and (:: Eq<Nat> = (size xs') (size ys'))
+             (fold (function [[x' y'] old]
+                     (and old (= x' y')))
+                   true
+                   (zip2 xs' ys'))))
+      ([#;Form]
+       [#;Tuple])
+
+      [[_ (#;Record xs')] [_ (#;Record ys')]]
+      (and (:: Eq<Nat> = (size xs') (size ys'))
+           (fold (function [[[xl' xr'] [yl' yr']] old]
+                   (and old (= xl' yl') (= xr' yr')))
+                 true
+                 (zip2 xs' ys')))
+      
+      _
+      false)))
+
+## [Values]
+(def: #export (to-text ast)
+  (-> Code Text)
+  (case ast
+    (^template [<tag> <struct>]
+      [_ (<tag> value)]
+      (:: <struct> encode value))
+    ([#;Bool   Codec<Text,Bool>]
+     [#;Nat    Codec<Text,Nat>]
+     [#;Int    Codec<Text,Int>]
+     [#;Deg    Codec<Text,Deg>]
+     [#;Real   Codec<Text,Real>]
+     [#;Char   char;Codec<Text,Char>]
+     [#;Text   text;Codec<Text,Text>]
+     [#;Symbol Codec<Text,Ident>])
+
+    [_ (#;Tag ident)]
+    (Text/append  "#" (:: Codec<Text,Ident> encode ident))
+
+    (^template [<tag> <open> <close>]
+      [_ (<tag> members)]
+      ($_ Text/append <open> (|> members (map to-text) (interpose " ") (text;join-with "")) <close>))
+    ([#;Form  "(" ")"]
+     [#;Tuple "[" "]"])
+
+    [_ (#;Record pairs)]
+    ($_ Text/append "{" (|> pairs (map (function [[left right]] ($_ Text/append (to-text left) " " (to-text right)))) (interpose " ") (text;join-with "")) "}")
+    ))
+
+(def: #export (replace original substitute ast)
+  {#;doc "Replaces all code that looks like the 'original' with the 'substitute'."}
+  (-> Code Code Code Code)
+  (if (:: Eq<Code> = original ast)
+    substitute
+    (case ast
+      (^template [<tag>]
+        [cursor (<tag> parts)]
+        [cursor (<tag> (map (replace original substitute) parts))])
+      ([#;Form]
+       [#;Tuple])
+
+      [cursor (#;Record parts)]
+      [cursor (#;Record (map (function [[left right]]
+                               [(replace original substitute left)
+                                (replace original substitute right)])
+                             parts))]
+
+      _
+      ast)))