- The output directory is now being used as the cache.

- "input" has been renamed as "source" and "output" has been renamed as "target".

1 files changed, 287 insertions, 0 deletions

diff --git a/source/lux/meta/lux.lux b/source/lux/meta/lux.lux
new file mode 100644
index 000000000..a28d6e5d4
--- /dev/null
+++ b/source/lux/meta/lux.lux
@@ -0,0 +1,287 @@
+##   Copyright (c) Eduardo Julian. All rights reserved.
+##   The use and distribution terms for this software are covered by the
+##   Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
+##   which can be found in the file epl-v10.html at the root of this distribution.
+##   By using this software in any fashion, you are agreeing to be bound by
+##   the terms of this license.
+##   You must not remove this notice, or any other, from this software.
+
+(;import lux
+         (.. macro)
+         (lux/control (monoid #as m)
+                      (functor #as F)
+                      (monad #as M #refer (#only do)))
+         (lux/data list
+                   maybe
+                   (show #as S)
+                   (number #as N)))
+
+## [Types]
+## (deftype (Lux a)
+##   (-> Compiler (Either Text (, Compiler a))))
+
+## [Utils]
+(def (ident->text ident)
+  (-> Ident Text)
+  (let [[pre post] ident]
+    ($ text:++ pre ";" post)))
+
+## [Structures]
+(defstruct #export Lux/Functor (F;Functor Lux)
+  (def (F;map f fa)
+    (lambda [state]
+      (case (fa state)
+        (#;Left msg)
+        (#;Left msg)
+
+        (#;Right [state' a])
+        (#;Right [state' (f a)])))))
+
+(defstruct #export Lux/Monad (M;Monad Lux)
+  (def M;_functor Lux/Functor)
+  (def (M;wrap x)
+    (lambda [state]
+      (#;Right [state x])))
+  (def (M;join mma)
+    (lambda [state]
+      (case (mma state)
+        (#;Left msg)
+        (#;Left msg)
+
+        (#;Right [state' ma])
+        (ma state')))))
+
+## Functions
+(def #export (get-module-name state)
+  (Lux Text)
+  (case (reverse (get@ #;envs state))
+    #;Nil
+    (#;Left "Can't get the module name without a module!")
+
+    (#;Cons [env _])
+    (#;Right [state (get@ #;name env)])))
+
+(def (get k plist)
+  (All [a]
+    (-> Text (List (, Text a)) (Maybe a)))
+  (case plist
+    #;Nil
+    #;None
+
+    (#;Cons [[k' v] plist'])
+    (if (text:= k k')
+      (#;Some v)
+      (get k plist'))))
+
+(def (find-macro' modules current-module module name)
+  (-> (List (, Text (Module Compiler))) Text Text Text
+      (Maybe Macro))
+  (do Maybe/Monad
+    [$module (get module modules)
+     gdef (|> (: (Module Compiler) $module) (get@ #;defs) (get name))]
+    (case (: (, Bool (DefData' Macro)) gdef)
+      [exported? (#;MacroD macro')]
+      (if (or exported? (text:= module current-module))
+        (#;Some macro')
+        #;None)
+
+      [_ (#;AliasD [r-module r-name])]
+      (find-macro' modules current-module r-module r-name)
+      
+      _
+      #;None)))
+
+(def #export (find-macro ident)
+  (-> Ident (Lux (Maybe Macro)))
+  (do Lux/Monad
+    [current-module get-module-name]
+    (let [[module name] ident]
+      (: (Lux (Maybe Macro))
+         (lambda [state]
+           (#;Right [state (find-macro' (get@ #;modules state) current-module module name)]))))))
+
+(def #export (normalize ident)
+  (-> Ident (Lux Ident))
+  (case ident
+    ["" name]
+    (do Lux/Monad
+      [module-name get-module-name]
+      (M;wrap (: Ident [module-name name])))
+
+    _
+    (:: Lux/Monad (M;wrap ident))))
+
+(def #export (macro-expand syntax)
+  (-> Syntax (Lux (List Syntax)))
+  (case syntax
+    (#;Meta [_ (#;FormS (#;Cons [(#;Meta [_ (#;SymbolS macro-name)]) args]))])
+    (do Lux/Monad
+      [macro-name' (normalize macro-name)
+       ?macro (find-macro macro-name')]
+      (case ?macro
+        (#;Some macro)
+        (do Lux/Monad
+          [expansion (macro args)
+           expansion' (M;map% Lux/Monad macro-expand expansion)]
+          (M;wrap (:: List/Monad (M;join expansion'))))
+        
+        #;None
+        (do Lux/Monad
+          [parts' (M;map% Lux/Monad macro-expand (list& (symbol$ macro-name) args))]
+          (M;wrap (list (form$ (:: List/Monad (M;join parts'))))))))
+
+    (#;Meta [_ (#;FormS (#;Cons [harg targs]))])
+    (do Lux/Monad
+      [harg+ (macro-expand harg)
+       targs+ (M;map% Lux/Monad macro-expand targs)]
+      (M;wrap (list (form$ (list:++ harg+ (:: List/Monad (M;join (: (List (List Syntax)) targs+))))))))
+
+    (#;Meta [_ (#;TupleS members)])
+    (do Lux/Monad
+      [members' (M;map% Lux/Monad macro-expand members)]
+      (M;wrap (list (tuple$ (:: List/Monad (M;join members'))))))
+
+    _
+    (:: Lux/Monad (M;wrap (list syntax)))))
+
+(def #export (gensym prefix state)
+  (-> Text (Lux Syntax))
+  (#;Right [(update@ #;seed inc state)
+            (symbol$ ["__gensym__" (:: N;Int/Show (S;show (get@ #;seed state)))])]))
+
+(def #export (emit datum)
+  (All [a]
+    (-> a (Lux a)))
+  (lambda [state]
+    (#;Right [state datum])))
+
+(def #export (fail msg)
+  (All [a]
+    (-> Text (Lux a)))
+  (lambda [_]
+    (#;Left msg)))
+
+(def #export (macro-expand-1 token)
+  (-> Syntax (Lux Syntax))
+  (do Lux/Monad
+    [token+ (macro-expand token)]
+    (case token+
+      (\ (list token'))
+      (M;wrap token')
+
+      _
+      (fail "Macro expanded to more than 1 element."))))
+
+(def #export (module-exists? module state)
+  (-> Text (Lux Bool))
+  (#;Right [state (case (get module (get@ #;modules state))
+                    (#;Some _)
+                    true
+                    
+                    #;None
+                    false)]))
+
+(def #export (exported-defs module state)
+  (-> Text (Lux (List Text)))
+  (case (get module (get@ #;modules state))
+    (#;Some =module)
+    (using List/Monad
+      (#;Right [state (M;join (:: M;_functor (F;map (: (-> (, Text (, Bool (DefData' Macro)))
+                                                           (List Text))
+                                                       (lambda [gdef]
+                                                         (let [[name [export? _]] gdef]
+                                                           (if export?
+                                                             (list name)
+                                                             (list)))))
+                                                    (get@ #;defs =module))))]))
+    
+    #;None
+    (#;Left ($ text:++ "Unknown module: " module))))
+
+(def (show-envs envs)
+  (-> (List (Env Text (, LuxVar Type))) Text)
+  (|> envs
+      (F;map (lambda [env]
+               (case env
+                 {#;name name #;inner-closures _ #;locals {#;counter _ #;mappings locals} #;closure _}
+                 ($ text:++ name ": " (|> locals
+                                          (F;map (: (All [a] (-> (, Text a) Text))
+                                                    (lambda [b] (let [[label _] b] label))))
+                                          (:: List/Functor)
+                                          (interpose " ")
+                                          (foldL text:++ ""))))))
+      (:: List/Functor)
+      (interpose "\n")
+      (foldL text:++ "")))
+
+(def (try-both f x1 x2)
+  (All [a b]
+    (-> (-> a (Maybe b)) a a (Maybe b)))
+  (case (f x1)
+    #;None     (f x2)
+    (#;Some y) (#;Some y)))
+
+(def (find-in-env name state)
+  (-> Ident Compiler (Maybe Type))
+  (let [vname' (ident->text name)]
+    (case state
+      {#;source source #;modules modules
+       #;envs   envs   #;types   types             #;host  host
+       #;seed   seed   #;eval? eval?}
+      (some (: (-> (Env Text (, LuxVar Type)) (Maybe Type))
+               (lambda [env]
+                 (case env
+                   {#;name _ #;inner-closures _ #;locals {#;counter _ #;mappings locals} #;closure {#;counter _ #;mappings closure}}
+                   (try-both (some (: (-> (, Text (, LuxVar Type)) (Maybe Type))
+                                      (lambda [binding]
+                                        (let [[bname [_ type]] binding]
+                                          (if (text:= vname' bname)
+                                            (#;Some type)
+                                            #;None)))))
+                             locals
+                             closure))))
+            envs))))
+
+(def (find-in-defs name state)
+  (-> Ident Compiler (Maybe Type))
+  (let [[v-prefix v-name] name
+        {#;source source #;modules modules
+         #;envs   envs   #;types   types   #;host           host
+         #;seed   seed   #;eval? eval?} state]
+    (case (get v-prefix modules)
+      #;None
+      #;None
+
+      (#;Some {#;defs defs #;module-aliases _ #;imports _})
+      (case (get v-name defs)
+        #;None
+        #;None
+
+        (#;Some [_ def-data])
+        (case def-data
+          #;TypeD          (#;Some Type)
+          (#;ValueD type)  (#;Some type)
+          (#;MacroD m)     (#;Some Macro)
+          (#;AliasD name') (find-in-defs name' state))))))
+
+(def #export (find-var-type name)
+  (-> Ident (Lux Type))
+  (do Lux/Monad
+    [name' (normalize name)]
+    (: (Lux Type)
+       (lambda [state]
+         (case (find-in-env name state)
+           (#;Some struct-type)
+           (#;Right [state struct-type])
+
+           _
+           (case (find-in-defs name' state)
+             (#;Some struct-type)
+             (#;Right [state struct-type])
+
+             _
+             (let [{#;source source #;modules      modules
+                    #;envs   envs   #;types        types        #;host  host
+                    #;seed   seed   #;eval? eval?} state]
+               (#;Left ($ text:++ "Unknown var: " (ident->text name) "\n\n" (show-envs envs))))))))
+    ))