From 4cd9b0c9242f1105e50ad9b42b7f6f5d074f14b4 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sat, 25 Jul 2015 20:19:43 -0400 Subject: - The output directory is now being used as the cache. - "input" has been renamed as "source" and "output" has been renamed as "target". --- input/lux.lux | 2784 --------------------------------------------------------- 1 file changed, 2784 deletions(-) delete mode 100644 input/lux.lux (limited to 'input/lux.lux') diff --git a/input/lux.lux b/input/lux.lux deleted file mode 100644 index 61d99396c..000000000 --- a/input/lux.lux +++ /dev/null @@ -1,2784 +0,0 @@ -## 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. - -## First things first, must define functions -(_jvm_interface "Function" [] - (apply ["java.lang.Object"] "java.lang.Object" ["public" "abstract"])) - -## Basic types -(_lux_def Bool (#DataT "java.lang.Boolean")) -(_lux_export Bool) - -(_lux_def Int (#DataT "java.lang.Long")) -(_lux_export Int) - -(_lux_def Real (#DataT "java.lang.Double")) -(_lux_export Real) - -(_lux_def Char (#DataT "java.lang.Character")) -(_lux_export Char) - -(_lux_def Text (#DataT "java.lang.String")) -(_lux_export Text) - -(_lux_def Unit (#TupleT #Nil)) -(_lux_export Unit) - -(_lux_def Void (#VariantT #Nil)) -(_lux_export Void) - -(_lux_def Ident (#TupleT (#Cons [Text (#Cons [Text #Nil])]))) -(_lux_export Ident) - -## (deftype (List a) -## (| #Nil -## (#Cons (, a (List a))))) -(_lux_def List - (#AllT [(#Some #Nil) "lux;List" "a" - (#VariantT (#Cons [["lux;Nil" (#TupleT #Nil)] - (#Cons [["lux;Cons" (#TupleT (#Cons [(#BoundT "a") - (#Cons [(#AppT [(#BoundT "lux;List") (#BoundT "a")]) - #Nil])]))] - #Nil])]))])) -(_lux_export List) - -## (deftype (Maybe a) -## (| #None -## (#Some a))) -(_lux_def Maybe - (#AllT [(#Some #Nil) "lux;Maybe" "a" - (#VariantT (#Cons [["lux;None" (#TupleT #Nil)] - (#Cons [["lux;Some" (#BoundT "a")] - #Nil])]))])) -(_lux_export Maybe) - -## (deftype #rec Type -## (| (#DataT Text) -## (#TupleT (List Type)) -## (#VariantT (List (, Text Type))) -## (#RecordT (List (, Text Type))) -## (#LambdaT (, Type Type)) -## (#BoundT Text) -## (#VarT Int) -## (#AllT (, (Maybe (List (, Text Type))) Text Text Type)) -## (#AppT (, Type Type)))) -(_lux_def Type - (_lux_case (#AppT [(#BoundT "Type") (#BoundT "_")]) - Type - (_lux_case (#AppT [List (#TupleT (#Cons [Text (#Cons [Type #Nil])]))]) - TypeEnv - (#AppT [(#AllT [(#Some #Nil) "Type" "_" - (#VariantT (#Cons [["lux;DataT" Text] - (#Cons [["lux;TupleT" (#AppT [List Type])] - (#Cons [["lux;VariantT" TypeEnv] - (#Cons [["lux;RecordT" TypeEnv] - (#Cons [["lux;LambdaT" (#TupleT (#Cons [Type (#Cons [Type #Nil])]))] - (#Cons [["lux;BoundT" Text] - (#Cons [["lux;VarT" Int] - (#Cons [["lux;AllT" (#TupleT (#Cons [(#AppT [Maybe TypeEnv]) (#Cons [Text (#Cons [Text (#Cons [Type #Nil])])])]))] - (#Cons [["lux;AppT" (#TupleT (#Cons [Type (#Cons [Type #Nil])]))] - (#Cons [["lux;ExT" Int] - #Nil])])])])])])])])])]))]) - Void])))) -(_lux_export Type) - -## (deftype (Bindings k v) -## (& #counter Int -## #mappings (List (, k v)))) -(_lux_def Bindings - (#AllT [(#Some #Nil) "lux;Bindings" "k" - (#AllT [#None "" "v" - (#RecordT (#Cons [["lux;counter" Int] - (#Cons [["lux;mappings" (#AppT [List - (#TupleT (#Cons [(#BoundT "k") - (#Cons [(#BoundT "v") - #Nil])]))])] - #Nil])]))])])) -(_lux_export Bindings) - -## (deftype (Env k v) -## (& #name Text -## #inner-closures Int -## #locals (Bindings k v) -## #closure (Bindings k v))) -(_lux_def Env - (#AllT [(#Some #Nil) "lux;Env" "k" - (#AllT [#None "" "v" - (#RecordT (#Cons [["lux;name" Text] - (#Cons [["lux;inner-closures" Int] - (#Cons [["lux;locals" (#AppT [(#AppT [Bindings (#BoundT "k")]) - (#BoundT "v")])] - (#Cons [["lux;closure" (#AppT [(#AppT [Bindings (#BoundT "k")]) - (#BoundT "v")])] - #Nil])])])]))])])) -(_lux_export Env) - -## (deftype Cursor -## (, Text Int Int)) -(_lux_def Cursor - (#TupleT (#Cons [Text (#Cons [Int (#Cons [Int #Nil])])]))) -(_lux_export Cursor) - -## (deftype (Meta m v) -## (| (#Meta (, m v)))) -(_lux_def Meta - (#AllT [(#Some #Nil) "lux;Meta" "m" - (#AllT [#None "" "v" - (#VariantT (#Cons [["lux;Meta" (#TupleT (#Cons [(#BoundT "m") - (#Cons [(#BoundT "v") - #Nil])]))] - #Nil]))])])) -(_lux_export Meta) - -## (deftype (Syntax' w) -## (| (#BoolS Bool) -## (#IntS Int) -## (#RealS Real) -## (#CharS Char) -## (#TextS Text) -## (#SymbolS (, Text Text)) -## (#TagS (, Text Text)) -## (#FormS (List (w (Syntax' w)))) -## (#TupleS (List (w (Syntax' w)))) -## (#RecordS (List (, (w (Syntax' w)) (w (Syntax' w))))))) -(_lux_def Syntax' - (_lux_case (#AppT [(#BoundT "w") - (#AppT [(#BoundT "lux;Syntax'") - (#BoundT "w")])]) - Syntax - (_lux_case (#AppT [List Syntax]) - SyntaxList - (#AllT [(#Some #Nil) "lux;Syntax'" "w" - (#VariantT (#Cons [["lux;BoolS" Bool] - (#Cons [["lux;IntS" Int] - (#Cons [["lux;RealS" Real] - (#Cons [["lux;CharS" Char] - (#Cons [["lux;TextS" Text] - (#Cons [["lux;SymbolS" Ident] - (#Cons [["lux;TagS" Ident] - (#Cons [["lux;FormS" SyntaxList] - (#Cons [["lux;TupleS" SyntaxList] - (#Cons [["lux;RecordS" (#AppT [List (#TupleT (#Cons [Syntax (#Cons [Syntax #Nil])]))])] - #Nil]) - ])])])])])])])])]) - )])))) -(_lux_export Syntax') - -## (deftype Syntax -## (Meta Cursor (Syntax' (Meta Cursor)))) -(_lux_def Syntax - (_lux_case (#AppT [Meta Cursor]) - w - (#AppT [w (#AppT [Syntax' w])]))) -(_lux_export Syntax) - -(_lux_def SyntaxList (#AppT [List Syntax])) - -## (deftype (Either l r) -## (| (#Left l) -## (#Right r))) -(_lux_def Either - (#AllT [(#Some #Nil) "lux;Either" "l" - (#AllT [#None "" "r" - (#VariantT (#Cons [["lux;Left" (#BoundT "l")] - (#Cons [["lux;Right" (#BoundT "r")] - #Nil])]))])])) -(_lux_export Either) - -## (deftype (StateE s a) -## (-> s (Either Text (, s a)))) -(_lux_def StateE - (#AllT [(#Some #Nil) "lux;StateE" "s" - (#AllT [#None "" "a" - (#LambdaT [(#BoundT "s") - (#AppT [(#AppT [Either Text]) - (#TupleT (#Cons [(#BoundT "s") - (#Cons [(#BoundT "a") - #Nil])]))])])])])) - -## (deftype Reader -## (List (Meta Cursor Text))) -(_lux_def Reader - (#AppT [List - (#AppT [(#AppT [Meta Cursor]) - Text])])) -(_lux_export Reader) - -## (deftype HostState -## (& #writer (^ org.objectweb.asm.ClassWriter) -## #loader (^ java.net.URLClassLoader) -## #classes (^ clojure.lang.Atom))) -(_lux_def HostState - (#RecordT (#Cons [["lux;writer" (#DataT "org.objectweb.asm.ClassWriter")] - (#Cons [["lux;loader" (#DataT "java.lang.ClassLoader")] - (#Cons [["lux;classes" (#DataT "clojure.lang.Atom")] - #Nil])])]))) - -## (deftype (DefData' m) -## (| #TypeD -## (#ValueD Type) -## (#MacroD m) -## (#AliasD Ident))) -(_lux_def DefData' - (#AllT [(#Some #Nil) "lux;DefData'" "" - (#VariantT (#Cons [["lux;TypeD" (#TupleT #Nil)] - (#Cons [["lux;ValueD" Type] - (#Cons [["lux;MacroD" (#BoundT "")] - (#Cons [["lux;AliasD" Ident] - #Nil])])])]))])) -(_lux_export DefData') - -## (deftype LuxVar -## (| (#Local Int) -## (#Global Ident))) -(_lux_def LuxVar - (#VariantT (#Cons [["lux;Local" Int] - (#Cons [["lux;Global" Ident] - #Nil])]))) -(_lux_export LuxVar) - -## (deftype (Module Compiler) -## (& #module-aliases (List (, Text Text)) -## #defs (List (, Text (, Bool (DefData' (-> (List Syntax) (StateE Compiler (List Syntax))))))) -## #imports (List Text) -## )) -(_lux_def Module - (#AllT [(#Some #Nil) "lux;Module" "Compiler" - (#RecordT (#Cons [["lux;module-aliases" (#AppT [List (#TupleT (#Cons [Text (#Cons [Text #Nil])]))])] - (#Cons [["lux;defs" (#AppT [List (#TupleT (#Cons [Text - (#Cons [(#TupleT (#Cons [Bool (#Cons [(#AppT [DefData' (#LambdaT [SyntaxList - (#AppT [(#AppT [StateE (#BoundT "Compiler")]) - SyntaxList])])]) - #Nil])])) - #Nil])]))])] - (#Cons [["lux;imports" (#AppT [List Text])] - #Nil])])]))])) -(_lux_export Module) - -## (deftype #rec Compiler -## (& #source Reader -## #modules (List (, Text (Module Compiler))) -## #envs (List (Env Text (, LuxVar Type))) -## #types (Bindings Int Type) -## #host HostState -## #seed Int -## #eval? Bool)) -(_lux_def Compiler - (#AppT [(#AllT [(#Some #Nil) "lux;Compiler" "" - (#RecordT (#Cons [["lux;source" Reader] - (#Cons [["lux;modules" (#AppT [List (#TupleT (#Cons [Text - (#Cons [(#AppT [Module (#AppT [(#BoundT "lux;Compiler") (#BoundT "")])]) - #Nil])]))])] - (#Cons [["lux;envs" (#AppT [List (#AppT [(#AppT [Env Text]) - (#TupleT (#Cons [LuxVar (#Cons [Type #Nil])]))])])] - (#Cons [["lux;types" (#AppT [(#AppT [Bindings Int]) Type])] - (#Cons [["lux;host" HostState] - (#Cons [["lux;seed" Int] - (#Cons [["lux;eval?" Bool] - #Nil])])])])])])]))]) - Void])) -(_lux_export Compiler) - -## (deftype Macro -## (-> (List Syntax) (StateE Compiler (List Syntax)))) -(_lux_def Macro - (#LambdaT [SyntaxList - (#AppT [(#AppT [StateE Compiler]) - SyntaxList])])) -(_lux_export Macro) - -## Base functions & macros -## (def _cursor -## Cursor -## ["" -1 -1]) -(_lux_def _cursor - (_lux_: Cursor ["" -1 -1])) - -## (def (_meta data) -## (-> (Syntax' (Meta Cursor)) Syntax) -## (#Meta [["" -1 -1] data])) -(_lux_def _meta - (_lux_: (#LambdaT [(#AppT [Syntax' - (#AppT [Meta Cursor])]) - Syntax]) - (_lux_lambda _ data - (#Meta [_cursor data])))) - -## (def (return x) -## (All [a] -## (-> a Compiler -## (Either Text (, Compiler a)))) -## ...) -(_lux_def return - (_lux_: (#AllT [(#Some #Nil) "" "a" - (#LambdaT [(#BoundT "a") - (#LambdaT [Compiler - (#AppT [(#AppT [Either Text]) - (#TupleT (#Cons [Compiler - (#Cons [(#BoundT "a") - #Nil])]))])])])]) - (_lux_lambda _ val - (_lux_lambda _ state - (#Right [state val]))))) - -## (def (fail msg) -## (All [a] -## (-> Text Compiler -## (Either Text (, Compiler a)))) -## ...) -(_lux_def fail - (_lux_: (#AllT [(#Some #Nil) "" "a" - (#LambdaT [Text - (#LambdaT [Compiler - (#AppT [(#AppT [Either Text]) - (#TupleT (#Cons [Compiler - (#Cons [(#BoundT "a") - #Nil])]))])])])]) - (_lux_lambda _ msg - (_lux_lambda _ state - (#Left msg))))) - -(_lux_def text$ - (_lux_: (#LambdaT [Text Syntax]) - (_lux_lambda _ text - (_meta (#TextS text))))) - -(_lux_def symbol$ - (_lux_: (#LambdaT [Ident Syntax]) - (_lux_lambda _ ident - (_meta (#SymbolS ident))))) - -(_lux_def tag$ - (_lux_: (#LambdaT [Ident Syntax]) - (_lux_lambda _ ident - (_meta (#TagS ident))))) - -(_lux_def form$ - (_lux_: (#LambdaT [(#AppT [List Syntax]) Syntax]) - (_lux_lambda _ tokens - (_meta (#FormS tokens))))) - -(_lux_def tuple$ - (_lux_: (#LambdaT [(#AppT [List Syntax]) Syntax]) - (_lux_lambda _ tokens - (_meta (#TupleS tokens))))) - -(_lux_def record$ - (_lux_: (#LambdaT [(#AppT [List (#TupleT (#Cons [Syntax (#Cons [Syntax #Nil])]))]) Syntax]) - (_lux_lambda _ tokens - (_meta (#RecordS tokens))))) - -(_lux_def let' - (_lux_: Macro - (_lux_lambda _ tokens - (_lux_case tokens - (#Cons [lhs (#Cons [rhs (#Cons [body #Nil])])]) - (return (#Cons [(form$ (#Cons [(symbol$ ["" "_lux_case"]) - (#Cons [rhs (#Cons [lhs (#Cons [body #Nil])])])])) - #Nil])) - - _ - (fail "Wrong syntax for let'"))))) -(_lux_declare-macro let') - -(_lux_def lambda' - (_lux_: Macro - (_lux_lambda _ tokens - (_lux_case tokens - (#Cons [(#Meta [_ (#TupleS (#Cons [arg args']))]) (#Cons [body #Nil])]) - (return (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_lambda"])) - (#Cons [(_meta (#SymbolS ["" ""])) - (#Cons [arg - (#Cons [(_lux_case args' - #Nil - body - - _ - (_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "lambda'"])) - (#Cons [(_meta (#TupleS args')) - (#Cons [body #Nil])])])))) - #Nil])])])]))) - #Nil])) - - (#Cons [(#Meta [_ (#SymbolS self)]) (#Cons [(#Meta [_ (#TupleS (#Cons [arg args']))]) (#Cons [body #Nil])])]) - (return (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_lambda"])) - (#Cons [(_meta (#SymbolS self)) - (#Cons [arg - (#Cons [(_lux_case args' - #Nil - body - - _ - (_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "lambda'"])) - (#Cons [(_meta (#TupleS args')) - (#Cons [body #Nil])])])))) - #Nil])])])]))) - #Nil])) - - _ - (fail "Wrong syntax for lambda"))))) -(_lux_declare-macro lambda') - -(_lux_def def' - (_lux_: Macro - (lambda' [tokens] - (_lux_case tokens - (#Cons [(#Meta [_ (#TagS ["" "export"])]) - (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) - (#Cons [type (#Cons [body #Nil])])])]) - (return (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_def"])) - (#Cons [name - (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_:"])) - (#Cons [type - (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "lambda'"])) - (#Cons [name - (#Cons [(_meta (#TupleS args)) - (#Cons [body #Nil])])])]))) - #Nil])])]))) - #Nil])])]))) - (#Cons [(_meta (#FormS (#Cons [(symbol$ ["" "_lux_export"]) (#Cons [name #Nil])]))) - #Nil])])) - - (#Cons [(#Meta [_ (#TagS ["" "export"])]) (#Cons [name (#Cons [type (#Cons [body #Nil])])])]) - (return (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_def"])) - (#Cons [name - (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_:"])) - (#Cons [type - (#Cons [body - #Nil])])]))) - #Nil])])]))) - (#Cons [(_meta (#FormS (#Cons [(symbol$ ["" "_lux_export"]) (#Cons [name #Nil])]))) - #Nil])])) - - (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) - (#Cons [type (#Cons [body #Nil])])]) - (return (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_def"])) - (#Cons [name - (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_:"])) - (#Cons [type - (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "lambda'"])) - (#Cons [name - (#Cons [(_meta (#TupleS args)) - (#Cons [body #Nil])])])]))) - #Nil])])]))) - #Nil])])]))) - #Nil])) - - (#Cons [name (#Cons [type (#Cons [body #Nil])])]) - (return (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_def"])) - (#Cons [name - (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_:"])) - (#Cons [type - (#Cons [body - #Nil])])]))) - #Nil])])]))) - #Nil])) - - _ - (fail "Wrong syntax for def") - )))) -(_lux_declare-macro def') - -(def' (defmacro tokens) - Macro - (_lux_case tokens - (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) (#Cons [body #Nil])]) - (return (#Cons [(form$ (#Cons [(symbol$ ["lux" "def'"]) - (#Cons [(form$ (#Cons [name args])) - (#Cons [(symbol$ ["lux" "Macro"]) - (#Cons [body - #Nil])]) - ])])) - (#Cons [(form$ (#Cons [(symbol$ ["" "_lux_declare-macro"]) (#Cons [name #Nil])])) - #Nil])])) - - (#Cons [(#Meta [_ (#TagS ["" "export"])]) (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) (#Cons [body #Nil])])]) - (return (#Cons [(form$ (#Cons [(symbol$ ["lux" "def'"]) - (#Cons [(tag$ ["" "export"]) - (#Cons [(form$ (#Cons [name args])) - (#Cons [(symbol$ ["lux" "Macro"]) - (#Cons [body - #Nil])]) - ])])])) - (#Cons [(form$ (#Cons [(symbol$ ["" "_lux_declare-macro"]) (#Cons [name #Nil])])) - #Nil])])) - - _ - (fail "Wrong syntax for defmacro"))) -(_lux_declare-macro defmacro) - -(defmacro #export (comment tokens) - (return #Nil)) - -(defmacro (->' tokens) - (_lux_case tokens - (#Cons [input (#Cons [output #Nil])]) - (return (#Cons [(_meta (#FormS (#Cons [(_meta (#TagS ["lux" "LambdaT"])) - (#Cons [(_meta (#TupleS (#Cons [input (#Cons [output #Nil])]))) - #Nil])]))) - #Nil])) - - (#Cons [input (#Cons [output others])]) - (return (#Cons [(_meta (#FormS (#Cons [(_meta (#TagS ["lux" "LambdaT"])) - (#Cons [(_meta (#TupleS (#Cons [input - (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "->'"])) - (#Cons [output others])]))) - #Nil])]))) - #Nil])]))) - #Nil])) - - _ - (fail "Wrong syntax for ->'"))) - -(defmacro (All' tokens) - (_lux_case tokens - (#Cons [(#Meta [_ (#TupleS #Nil)]) - (#Cons [body #Nil])]) - (return (#Cons [body - #Nil])) - - (#Cons [(#Meta [_ (#TupleS (#Cons [(#Meta [_ (#SymbolS ["" arg-name])]) other-args]))]) - (#Cons [body #Nil])]) - (return (#Cons [(_meta (#FormS (#Cons [(_meta (#TagS ["lux" "AllT"])) - (#Cons [(_meta (#TupleS (#Cons [(_meta (#TagS ["lux" "None"])) - (#Cons [(_meta (#TextS "")) - (#Cons [(_meta (#TextS arg-name)) - (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "All'"])) - (#Cons [(_meta (#TupleS other-args)) - (#Cons [body - #Nil])])]))) - #Nil])])])]))) - #Nil])]))) - #Nil])) - - _ - (fail "Wrong syntax for All'"))) - -(defmacro (B' tokens) - (_lux_case tokens - (#Cons [(#Meta [_ (#SymbolS ["" bound-name])]) - #Nil]) - (return (#Cons [(_meta (#FormS (#Cons [(_meta (#TagS ["lux" "BoundT"])) - (#Cons [(_meta (#TextS bound-name)) - #Nil])]))) - #Nil])) - - _ - (fail "Wrong syntax for B'"))) - -(defmacro ($' tokens) - (_lux_case tokens - (#Cons [x #Nil]) - (return tokens) - - (#Cons [x (#Cons [y xs])]) - (return (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "$'"])) - (#Cons [(_meta (#FormS (#Cons [(_meta (#TagS ["lux" "AppT"])) - (#Cons [(_meta (#TupleS (#Cons [x (#Cons [y #Nil])]))) - #Nil])]))) - xs])]))) - #Nil])) - - _ - (fail "Wrong syntax for $'"))) - -(def' (foldL f init xs) - (All' [a b] - (->' (->' (B' a) (B' b) (B' a)) - (B' a) - ($' List (B' b)) - (B' a))) - (_lux_case xs - #Nil - init - - (#Cons [x xs']) - (foldL f (f init x) xs'))) - -(def' (reverse list) - (All' [a] - (->' ($' List (B' a)) ($' List (B' a)))) - (foldL (lambda' [tail head] (#Cons [head tail])) - #Nil - list)) - -(defmacro (list xs) - (return (#Cons [(foldL (lambda' [tail head] - (_meta (#FormS (#Cons [(_meta (#TagS ["lux" "Cons"])) - (#Cons [(_meta (#TupleS (#Cons [head (#Cons [tail #Nil])]))) - #Nil])])))) - (_meta (#TagS ["lux" "Nil"])) - (reverse xs)) - #Nil]))) - -(defmacro (list& xs) - (_lux_case (reverse xs) - (#Cons [last init]) - (return (list (foldL (lambda' [tail head] - (_meta (#FormS (list (_meta (#TagS ["lux" "Cons"])) - (_meta (#TupleS (list head tail))))))) - last - init))) - - _ - (fail "Wrong syntax for list&"))) - -(defmacro #export (lambda tokens) - (let' [name tokens'] (_lux_: (#TupleT (list Ident ($' List Syntax))) - (_lux_case tokens - (#Cons [(#Meta [_ (#SymbolS name)]) tokens']) - [name tokens'] - - _ - [["" ""] tokens])) - (_lux_case tokens' - (#Cons [(#Meta [_ (#TupleS args)]) (#Cons [body #Nil])]) - (_lux_case args - #Nil - (fail "lambda requires a non-empty arguments tuple.") - - (#Cons [harg targs]) - (return (list (form$ (list (symbol$ ["" "_lux_lambda"]) - (symbol$ name) - harg - (foldL (lambda' [body' arg] - (form$ (list (symbol$ ["" "_lux_lambda"]) - (symbol$ ["" ""]) - arg - body'))) - body - (reverse targs))))))) - - _ - (fail "Wrong syntax for lambda")))) - -(defmacro (def'' tokens) - (_lux_case tokens - (#Cons [(#Meta [_ (#TagS ["" "export"])]) - (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) - (#Cons [type (#Cons [body #Nil])])])]) - (return (list (form$ (list (symbol$ ["" "_lux_def"]) - name - (form$ (list (symbol$ ["" "_lux_:"]) - type - (form$ (list (symbol$ ["lux" "lambda"]) - name - (tuple$ args) - body)))))) - (form$ (list (symbol$ ["" "_lux_export"]) name)))) - - (#Cons [(#Meta [_ (#TagS ["" "export"])]) (#Cons [name (#Cons [type (#Cons [body #Nil])])])]) - (return (list (form$ (list (symbol$ ["" "_lux_def"]) - name - (form$ (list (symbol$ ["" "_lux_:"]) - type - body)))) - (form$ (list (symbol$ ["" "_lux_export"]) name)))) - - (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) - (#Cons [type (#Cons [body #Nil])])]) - (return (list (form$ (list (symbol$ ["" "_lux_def"]) - name - (form$ (list (symbol$ ["" "_lux_:"]) - type - (form$ (list (symbol$ ["lux" "lambda"]) - name - (tuple$ args) - body)))))))) - - (#Cons [name (#Cons [type (#Cons [body #Nil])])]) - (return (list (form$ (list (symbol$ ["" "_lux_def"]) - name - (form$ (list (symbol$ ["" "_lux_:"]) type body)))))) - - _ - (fail "Wrong syntax for def") - )) - -(def'' (as-pairs xs) - (All' [a] - (->' ($' List (B' a)) ($' List (#TupleT (list (B' a) (B' a)))))) - (_lux_case xs - (#Cons [x (#Cons [y xs'])]) - (#Cons [[x y] (as-pairs xs')]) - - _ - #Nil)) - -(defmacro #export (let tokens) - (_lux_case tokens - (#Cons [(#Meta [_ (#TupleS bindings)]) (#Cons [body #Nil])]) - (return (list (foldL (_lux_: (->' Syntax (#TupleT (list Syntax Syntax)) - Syntax) - (lambda [body binding] - (_lux_case binding - [label value] - (form$ (list (symbol$ ["" "_lux_case"]) value label body))))) - body - (reverse (as-pairs bindings))))) - - _ - (fail "Wrong syntax for let"))) - -(def'' (map f xs) - (All' [a b] - (->' (->' (B' a) (B' b)) ($' List (B' a)) ($' List (B' b)))) - (_lux_case xs - #Nil - #Nil - - (#Cons [x xs']) - (#Cons [(f x) (map f xs')]))) - -(def'' (any? p xs) - (All' [a] - (->' (->' (B' a) Bool) ($' List (B' a)) Bool)) - (_lux_case xs - #Nil - false - - (#Cons [x xs']) - (_lux_case (p x) - true true - false (any? p xs')))) - -(def'' (spliced? token) - (->' Syntax Bool) - (_lux_case token - (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS ["" "~@"])]) (#Cons [_ #Nil])]))]) - true - - _ - false)) - -(def'' (wrap-meta content) - (->' Syntax Syntax) - (_meta (#FormS (list (_meta (#TagS ["lux" "Meta"])) - (_meta (#TupleS (list (_meta (#TupleS (list (_meta (#TextS "")) (_meta (#IntS -1)) (_meta (#IntS -1))))) - content))))))) - -(def'' (untemplate-list tokens) - (->' ($' List Syntax) Syntax) - (_lux_case tokens - #Nil - (_meta (#TagS ["lux" "Nil"])) - - (#Cons [token tokens']) - (_meta (#FormS (list (_meta (#TagS ["lux" "Cons"])) - (_meta (#TupleS (list token (untemplate-list tokens'))))))))) - -(def'' #export (list:++ xs ys) - (All' [a] (->' ($' List (B' a)) ($' List (B' a)) ($' List (B' a)))) - (_lux_case xs - (#Cons [x xs']) - (#Cons [x (list:++ xs' ys)]) - - #Nil - ys)) - -(defmacro #export ($ tokens) - (_lux_case tokens - (#Cons [op (#Cons [init args])]) - (return (list (foldL (lambda [a1 a2] (form$ (list op a1 a2))) - init - args))) - - _ - (fail "Wrong syntax for $"))) - -(def'' (splice replace? untemplate tag elems) - (->' Bool (->' Syntax Syntax) Syntax ($' List Syntax) Syntax) - (_lux_case replace? - true - (_lux_case (any? spliced? elems) - true - (let [elems' (map (lambda [elem] - (_lux_case elem - (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS ["" "~@"])]) (#Cons [spliced #Nil])]))]) - spliced - - _ - (form$ (list (symbol$ ["" "_lux_:"]) - (form$ (list (tag$ ["lux" "AppT"]) (tuple$ (list (symbol$ ["lux" "List"]) (symbol$ ["lux" "Syntax"]))))) - (form$ (list (tag$ ["lux" "Cons"]) (tuple$ (list (untemplate elem) - (tag$ ["lux" "Nil"]))))))))) - elems)] - (wrap-meta (form$ (list tag - (form$ (list& (symbol$ ["lux" "$"]) - (symbol$ ["lux" "list:++"]) - elems')))))) - - false - (wrap-meta (form$ (list tag (untemplate-list (map untemplate elems)))))) - false - (wrap-meta (form$ (list tag (untemplate-list (map untemplate elems))))))) - -(def'' (untemplate replace? subst token) - (->' Bool Text Syntax Syntax) - (_lux_case (_lux_: (#TupleT (list Bool Syntax)) [replace? token]) - [_ (#Meta [_ (#BoolS value)])] - (wrap-meta (form$ (list (tag$ ["lux" "BoolS"]) (_meta (#BoolS value))))) - - [_ (#Meta [_ (#IntS value)])] - (wrap-meta (form$ (list (tag$ ["lux" "IntS"]) (_meta (#IntS value))))) - - [_ (#Meta [_ (#RealS value)])] - (wrap-meta (form$ (list (tag$ ["lux" "RealS"]) (_meta (#RealS value))))) - - [_ (#Meta [_ (#CharS value)])] - (wrap-meta (form$ (list (tag$ ["lux" "CharS"]) (_meta (#CharS value))))) - - [_ (#Meta [_ (#TextS value)])] - (wrap-meta (form$ (list (tag$ ["lux" "TextS"]) (_meta (#TextS value))))) - - [_ (#Meta [_ (#TagS [module name])])] - (let [module' (_lux_case module - "" - subst - - _ - module)] - (wrap-meta (form$ (list (tag$ ["lux" "TagS"]) (tuple$ (list (text$ module') (text$ name))))))) - - [_ (#Meta [_ (#SymbolS [module name])])] - (let [module' (_lux_case module - "" - subst - - _ - module)] - (wrap-meta (form$ (list (tag$ ["lux" "SymbolS"]) (tuple$ (list (text$ module') (text$ name))))))) - - [_ (#Meta [_ (#TupleS elems)])] - (splice replace? (untemplate replace? subst) (tag$ ["lux" "TupleS"]) elems) - - [true (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS ["" "~"])]) (#Cons [unquoted #Nil])]))])] - unquoted - - [_ (#Meta [_ (#FormS elems)])] - (splice replace? (untemplate replace? subst) (tag$ ["lux" "FormS"]) elems) - - [_ (#Meta [_ (#RecordS fields)])] - (wrap-meta (form$ (list (tag$ ["lux" "RecordS"]) - (untemplate-list (map (_lux_: (->' (#TupleT (list Syntax Syntax)) Syntax) - (lambda [kv] - (let [[k v] kv] - (tuple$ (list (untemplate replace? subst k) (untemplate replace? subst v)))))) - fields))))) - )) - -(defmacro (`' tokens) - (_lux_case tokens - (#Cons [template #Nil]) - (return (list (untemplate true "" template))) - - _ - (fail "Wrong syntax for `'"))) - -(defmacro (' tokens) - (_lux_case tokens - (#Cons [template #Nil]) - (return (list (untemplate false "" template))) - - _ - (fail "Wrong syntax for '"))) - -(defmacro #export (|> tokens) - (_lux_case tokens - (#Cons [init apps]) - (return (list (foldL (lambda [acc app] - (_lux_case app - (#Meta [_ (#TupleS parts)]) - (tuple$ (list:++ parts (list acc))) - - (#Meta [_ (#FormS parts)]) - (form$ (list:++ parts (list acc))) - - _ - (`' ((~ app) (~ acc))))) - init - apps))) - - _ - (fail "Wrong syntax for |>"))) - -(defmacro #export (if tokens) - (_lux_case tokens - (#Cons [test (#Cons [then (#Cons [else #Nil])])]) - (return (list (`' (_lux_case (~ test) - true (~ then) - false (~ else))))) - - _ - (fail "Wrong syntax for if"))) - -## (deftype (Lux a) -## (-> Compiler (Either Text (, Compiler a)))) -(def'' #export Lux - Type - (All' [a] - (->' Compiler ($' Either Text (#TupleT (list Compiler (B' a))))))) - -## (defsig (Monad m) -## (: (All [a] (-> a (m a))) -## return) -## (: (All [a b] (-> (-> a (m b)) (m a) (m b))) -## bind)) -(def'' Monad - Type - (All' [m] - (#RecordT (list ["lux;return" (All' [a] (->' (B' a) ($' (B' m) (B' a))))] - ["lux;bind" (All' [a b] (->' (->' (B' a) ($' (B' m) (B' b))) - ($' (B' m) (B' a)) - ($' (B' m) (B' b))))])))) - -(def'' Maybe/Monad - ($' Monad Maybe) - {#lux;return - (lambda return [x] - (#Some x)) - - #lux;bind - (lambda [f ma] - (_lux_case ma - #None #None - (#Some a) (f a)))}) - -(def'' Lux/Monad - ($' Monad Lux) - {#lux;return - (lambda [x] - (lambda [state] - (#Right [state x]))) - - #lux;bind - (lambda [f ma] - (lambda [state] - (_lux_case (ma state) - (#Left msg) - (#Left msg) - - (#Right [state' a]) - (f a state'))))}) - -(defmacro #export (^ tokens) - (_lux_case tokens - (#Cons [(#Meta [_ (#SymbolS ["" class-name])]) #Nil]) - (return (list (`' (#;DataT (~ (_meta (#TextS class-name))))))) - - _ - (fail "Wrong syntax for ^"))) - -(defmacro #export (-> tokens) - (_lux_case (reverse tokens) - (#Cons [output inputs]) - (return (list (foldL (lambda [o i] (`' (#;LambdaT [(~ i) (~ o)]))) - output - inputs))) - - _ - (fail "Wrong syntax for ->"))) - -(defmacro #export (, tokens) - (return (list (`' (#;TupleT (~ (untemplate-list tokens))))))) - -(defmacro (do tokens) - (_lux_case tokens - (#Cons [monad (#Cons [(#Meta [_ (#TupleS bindings)]) (#Cons [body #Nil])])]) - (let [body' (foldL (_lux_: (-> Syntax (, Syntax Syntax) Syntax) - (lambda [body' binding] - (let [[var value] binding] - (_lux_case var - (#Meta [_ (#TagS ["" "let"])]) - (`' (;let (~ value) (~ body'))) - - _ - (`' (;bind (_lux_lambda (~ (symbol$ ["" ""])) - (~ var) - (~ body')) - (~ value))))))) - body - (reverse (as-pairs bindings)))] - (return (list (`' (_lux_case (~ monad) - {#;return ;return #;bind ;bind} - (~ body')))))) - - _ - (fail "Wrong syntax for do"))) - -(def'' (map% m f xs) - ## (All [m a b] - ## (-> (Monad m) (-> a (m b)) (List a) (m (List b)))) - (All' [m a b] - (-> ($' Monad (B' m)) - (-> (B' a) ($' (B' m) (B' b))) - ($' List (B' a)) - ($' (B' m) ($' List (B' b))))) - (let [{#;return ;return #;bind _} m] - (_lux_case xs - #Nil - (;return #Nil) - - (#Cons [x xs']) - (do m - [y (f x) - ys (map% m f xs')] - (;return (#Cons [y ys]))) - ))) - -(def'' #export (. f g) - (All' [a b c] - (-> (-> (B' b) (B' c)) (-> (B' a) (B' b)) (-> (B' a) (B' c)))) - (lambda [x] - (f (g x)))) - -(def'' (get-ident x) - (-> Syntax ($' Maybe Text)) - (_lux_case x - (#Meta [_ (#SymbolS ["" sname])]) - (#Some sname) - - _ - #None)) - -(def'' (tuple->list tuple) - (-> Syntax ($' Maybe ($' List Syntax))) - (_lux_case tuple - (#Meta [_ (#TupleS members)]) - (#Some members) - - _ - #None)) - -(def'' RepEnv - Type - ($' List (, Text Syntax))) - -(def'' (make-env xs ys) - (-> ($' List Text) ($' List Syntax) RepEnv) - (_lux_case (_lux_: (, ($' List Text) ($' List Syntax)) - [xs ys]) - [(#Cons [x xs']) (#Cons [y ys'])] - (#Cons [[x y] (make-env xs' ys')]) - - _ - #Nil)) - -(def'' #export (text:= x y) - (-> Text Text Bool) - (_jvm_invokevirtual java.lang.Object equals [java.lang.Object] - x [y])) - -(def'' (get-rep key env) - (-> Text RepEnv ($' Maybe Syntax)) - (_lux_case env - #Nil - #None - - (#Cons [[k v] env']) - (if (text:= k key) - (#Some v) - (get-rep key env')))) - -(def'' (apply-template env template) - (-> RepEnv Syntax Syntax) - (_lux_case template - (#Meta [_ (#SymbolS ["" sname])]) - (_lux_case (get-rep sname env) - (#Some subst) - subst - - _ - template) - - (#Meta [_ (#TupleS elems)]) - (tuple$ (map (apply-template env) elems)) - - (#Meta [_ (#FormS elems)]) - (form$ (map (apply-template env) elems)) - - (#Meta [_ (#RecordS members)]) - (record$ (map (_lux_: (-> (, Syntax Syntax) (, Syntax Syntax)) - (lambda [kv] - (let [[slot value] kv] - [(apply-template env slot) (apply-template env value)]))) - members)) - - _ - template)) - -(def'' (join-map f xs) - (All' [a b] - (-> (-> (B' a) ($' List (B' b))) ($' List (B' a)) ($' List (B' b)))) - (_lux_case xs - #Nil - #Nil - - (#Cons [x xs']) - (list:++ (f x) (join-map f xs')))) - -(defmacro #export (do-template tokens) - (_lux_case tokens - (#Cons [(#Meta [_ (#TupleS bindings)]) (#Cons [(#Meta [_ (#TupleS templates)]) data])]) - (_lux_case (_lux_: (, ($' Maybe ($' List Text)) ($' Maybe ($' List ($' List Syntax)))) - [(map% Maybe/Monad get-ident bindings) - (map% Maybe/Monad tuple->list data)]) - [(#Some bindings') (#Some data')] - (let [apply (_lux_: (-> RepEnv ($' List Syntax)) - (lambda [env] (map (apply-template env) templates)))] - (|> data' - (join-map (. apply (make-env bindings'))) - return)) - - _ - (fail "Wrong syntax for do-template")) - - _ - (fail "Wrong syntax for do-template"))) - -(do-template [ ] - [(def'' #export ( x y) - (-> Bool) - ( x y))] - - [i= _jvm_leq Int] - [i> _jvm_lgt Int] - [i< _jvm_llt Int] - [r= _jvm_deq Real] - [r> _jvm_dgt Real] - [r< _jvm_dlt Real] - ) - -(do-template [ ] - [(def'' #export ( x y) - (-> Bool) - (if ( x y) - true - ( x y)))] - - [i>= i> i= Int] - [i<= i< i= Int] - [r>= r> r= Real] - [r<= r< r= Real] - ) - -(do-template [ ] - [(def'' #export ( x y) - (-> ) - ( x y))] - - [i+ _jvm_ladd Int] - [i- _jvm_lsub Int] - [i* _jvm_lmul Int] - [i/ _jvm_ldiv Int] - [i% _jvm_lrem Int] - [r+ _jvm_dadd Real] - [r- _jvm_dsub Real] - [r* _jvm_dmul Real] - [r/ _jvm_ddiv Real] - [r% _jvm_drem Real] - ) - -(def'' (multiple? div n) - (-> Int Int Bool) - (i= 0 (i% n div))) - -(def'' (length list) - (-> List Int) - (foldL (lambda [acc _] (i+ 1 acc)) 0 list)) - -(def'' #export (not x) - (-> Bool Bool) - (if x false true)) - -(def'' #export (text:++ x y) - (-> Text Text Text) - (_jvm_invokevirtual java.lang.String concat [java.lang.String] - x [y])) - -(def'' (ident->text ident) - (-> Ident Text) - (let [[module name] ident] - ($ text:++ module ";" name))) - -(def'' (replace-syntax reps syntax) - (-> RepEnv Syntax Syntax) - (_lux_case syntax - (#Meta [_ (#SymbolS ["" name])]) - (_lux_case (get-rep name reps) - (#Some replacement) - replacement - - #None - syntax) - - (#Meta [_ (#FormS parts)]) - (#Meta [_ (#FormS (map (replace-syntax reps) parts))]) - - (#Meta [_ (#TupleS members)]) - (#Meta [_ (#TupleS (map (replace-syntax reps) members))]) - - (#Meta [_ (#RecordS slots)]) - (#Meta [_ (#RecordS (map (_lux_: (-> (, Syntax Syntax) (, Syntax Syntax)) - (lambda [slot] - (let [[k v] slot] - [(replace-syntax reps k) (replace-syntax reps v)]))) - slots))]) - - _ - syntax) - ) - -(defmacro #export (All tokens) - (let [[self-ident tokens'] (_lux_: (, Text SyntaxList) - (_lux_case tokens - (#Cons [(#Meta [_ (#SymbolS ["" self-ident])]) tokens']) - [self-ident tokens'] - - _ - ["" tokens]))] - (_lux_case tokens' - (#Cons [(#Meta [_ (#TupleS args)]) (#Cons [body #Nil])]) - (_lux_case (map% Maybe/Monad get-ident args) - (#Some idents) - (_lux_case idents - #Nil - (return (list body)) - - (#Cons [harg targs]) - (let [replacements (map (_lux_: (-> Text (, Text Syntax)) - (lambda [ident] [ident (`' (#;BoundT (~ (text$ ident))))])) - (list& self-ident idents)) - body' (foldL (lambda [body' arg'] - (`' (#;AllT [#;None "" (~ (text$ arg')) (~ body')]))) - (replace-syntax replacements body) - (reverse targs))] - ## (#;Some #;Nil) - (return (list (`' (#;AllT [#;None (~ (text$ self-ident)) (~ (text$ harg)) (~ body')])))))) - - #None - (fail "'All' arguments must be symbols.")) - - _ - (fail "Wrong syntax for All")) - )) - -(def'' (get k plist) - (All [a] - (-> Text ($' List (, Text a)) ($' Maybe a))) - (_lux_case plist - (#Cons [[k' v] plist']) - (if (text:= k k') - (#Some v) - (get k plist')) - - #Nil - #None)) - -(def'' (put k v dict) - (All [a] - (-> Text a ($' List (, Text a)) ($' List (, Text a)))) - (_lux_case dict - #Nil - (list [k v]) - - (#Cons [[k' v'] dict']) - (if (text:= k k') - (#Cons [[k' v] dict']) - (#Cons [[k' v'] (put k v dict')])))) - -(def'' (get-module-name state) - ($' Lux Text) - (_lux_case state - {#source source #modules modules - #envs envs #types types #host host - #seed seed #eval? eval?} - (_lux_case (reverse envs) - #Nil - (#Left "Can't get the module name without a module!") - - (#Cons [{#name module-name #inner-closures _ #locals _ #closure _} _]) - (#Right [state module-name])))) - -(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 (let [{#module-aliases _ #defs bindings #imports _} (_lux_: ($' Module Compiler) $module)] - (get name bindings))] - (_lux_case (_lux_: (, Bool ($' DefData' Macro)) gdef) - [exported? (#MacroD macro')] - (if exported? - (#Some macro') - (if (text:= module current-module) - (#Some macro') - #None)) - - [_ (#AliasD [r-module r-name])] - (find-macro' modules current-module r-module r-name) - - _ - #None))) - -(def'' (find-macro ident) - (-> Ident ($' Lux ($' Maybe Macro))) - (do Lux/Monad - [current-module get-module-name] - (let [[module name] ident] - (lambda [state] - (_lux_case state - {#source source #modules modules - #envs envs #types types #host host - #seed seed #eval? eval?} - (#Right [state (find-macro' modules current-module module name)])))))) - -(def'' (list:join xs) - (All [a] - (-> ($' List ($' List a)) ($' List a))) - (foldL list:++ #Nil xs)) - -(def'' (normalize ident) - (-> Ident ($' Lux Ident)) - (_lux_case ident - ["" name] - (do Lux/Monad - [module-name get-module-name] - (;return (_lux_: Ident [module-name name]))) - - _ - (return ident))) - -(defmacro #export (| tokens) - (do Lux/Monad - [pairs (map% Lux/Monad - (_lux_: (-> Syntax ($' Lux Syntax)) - (lambda [token] - (_lux_case token - (#Meta [_ (#TagS ident)]) - (do Lux/Monad - [ident (normalize ident)] - (;return (`' [(~ (text$ (ident->text ident))) (;,)]))) - - (#Meta [_ (#FormS (#Cons [(#Meta [_ (#TagS ident)]) (#Cons [value #Nil])]))]) - (do Lux/Monad - [ident (normalize ident)] - (;return (`' [(~ (text$ (ident->text ident))) (~ value)]))) - - _ - (fail "Wrong syntax for |")))) - tokens)] - (;return (list (`' (#;VariantT (~ (untemplate-list pairs)))))))) - -(defmacro #export (& tokens) - (if (not (multiple? 2 (length tokens))) - (fail "& expects an even number of arguments.") - (do Lux/Monad - [pairs (map% Lux/Monad - (_lux_: (-> (, Syntax Syntax) ($' Lux Syntax)) - (lambda [pair] - (_lux_case pair - [(#Meta [_ (#TagS ident)]) value] - (do Lux/Monad - [ident (normalize ident)] - (;return (`' [(~ (text$ (ident->text ident))) (~ value)]))) - - _ - (fail "Wrong syntax for &")))) - (as-pairs tokens))] - (;return (list (`' (#;RecordT (~ (untemplate-list pairs))))))))) - -(def'' #export (->text x) - (-> (^ java.lang.Object) Text) - (_jvm_invokevirtual java.lang.Object toString [] x [])) - -(def'' (interpose sep xs) - (All [a] - (-> a ($' List a) ($' List a))) - (_lux_case xs - #Nil - xs - - (#Cons [x #Nil]) - xs - - (#Cons [x xs']) - (list& x sep (interpose sep xs')))) - -(def'' (macro-expand syntax) - (-> Syntax ($' Lux ($' List Syntax))) - (_lux_case syntax - (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS macro-name)]) args]))]) - (do Lux/Monad - [macro-name' (normalize macro-name) - ?macro (find-macro macro-name')] - (_lux_case ?macro - (#Some macro) - (do Lux/Monad - [expansion (macro args) - expansion' (map% Lux/Monad macro-expand expansion)] - (;return (list:join expansion'))) - - #None - (do Lux/Monad - [parts' (map% Lux/Monad macro-expand (list& (symbol$ macro-name) args))] - (;return (list (form$ (list:join parts'))))))) - - (#Meta [_ (#FormS (#Cons [harg targs]))]) - (do Lux/Monad - [harg+ (macro-expand harg) - targs+ (map% Lux/Monad macro-expand targs)] - (;return (list (form$ (list:++ harg+ (list:join targs+)))))) - - (#Meta [_ (#TupleS members)]) - (do Lux/Monad - [members' (map% Lux/Monad macro-expand members)] - (;return (list (tuple$ (list:join members'))))) - - _ - (return (list syntax)))) - -(def'' (walk-type type) - (-> Syntax Syntax) - (_lux_case type - (#Meta [_ (#FormS (#Cons [(#Meta [_ (#TagS tag)]) parts]))]) - (form$ (#Cons [(tag$ tag) (map walk-type parts)])) - - (#Meta [_ (#TupleS members)]) - (tuple$ (map walk-type members)) - - (#Meta [_ (#FormS (#Cons [type-fn args]))]) - (foldL (lambda [type-fn arg] (`' (#;AppT [(~ type-fn) (~ arg)]))) - (walk-type type-fn) - (map walk-type args)) - - _ - type)) - -(defmacro #export (type tokens) - (_lux_case tokens - (#Cons [type #Nil]) - (do Lux/Monad - [type+ (macro-expand type)] - (_lux_case type+ - (#Cons [type' #Nil]) - (;return (list (walk-type type'))) - - _ - (fail "The expansion of the type-syntax had to yield a single element."))) - - _ - (fail "Wrong syntax for type"))) - -(defmacro #export (: tokens) - (_lux_case tokens - (#Cons [type (#Cons [value #Nil])]) - (return (list (`' (_lux_: (;type (~ type)) (~ value))))) - - _ - (fail "Wrong syntax for :"))) - -(defmacro #export (:! tokens) - (_lux_case tokens - (#Cons [type (#Cons [value #Nil])]) - (return (list (`' (_lux_:! (;type (~ type)) (~ value))))) - - _ - (fail "Wrong syntax for :!"))) - -(def'' (empty? xs) - (All [a] (-> ($' List a) Bool)) - (_lux_case xs - #Nil true - _ false)) - -(defmacro #export (deftype tokens) - (let [[export? tokens'] (: (, Bool (List Syntax)) - (_lux_case tokens - (#Cons [(#Meta [_ (#TagS ["" "export"])]) tokens']) - [true tokens'] - - _ - [false tokens])) - [rec? tokens'] (: (, Bool (List Syntax)) - (_lux_case tokens' - (#Cons [(#Meta [_ (#TagS ["" "rec"])]) tokens']) - [true tokens'] - - _ - [false tokens'])) - parts (: (Maybe (, Text (List Syntax) Syntax)) - (_lux_case tokens' - (#Cons [(#Meta [_ (#SymbolS ["" name])]) (#Cons [type #Nil])]) - (#Some [name #Nil type]) - - (#Cons [(#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS ["" name])]) args]))]) (#Cons [type #Nil])]) - (#Some [name args type]) - - _ - #None))] - (_lux_case parts - (#Some [name args type]) - (let [with-export (: (List Syntax) - (if export? - (list (`' (_lux_export (~ (symbol$ ["" name]))))) - #Nil)) - type' (: (Maybe Syntax) - (if rec? - (if (empty? args) - (let [g!param (symbol$ ["" ""]) - prime-name (symbol$ ["" (text:++ name "'")]) - type+ (replace-syntax (list [name (`' ((~ prime-name) (~ g!param)))]) type)] - (#Some (`' ((;All (~ prime-name) [(~ g!param)] (~ type+)) - ;Void)))) - #None) - (_lux_case args - #Nil - (#Some type) - - _ - (#Some (`' (;All (~ (symbol$ ["" name])) [(~@ args)] (~ type)))))))] - (_lux_case type' - (#Some type'') - (return (list& (`' (_lux_def (~ (symbol$ ["" name])) (;type (~ type'')))) - with-export)) - - #None - (fail "Wrong syntax for deftype"))) - - #None - (fail "Wrong syntax for deftype")) - )) -## (defmacro #export (deftype tokens) -## (let [[export? tokens'] (: (, Bool (List Syntax)) -## (_lux_case (:! (List Syntax) tokens) -## (#Cons [(#Meta [_ (#TagS ["" "export"])]) tokens']) -## [true (:! (List Syntax) tokens')] - -## _ -## [false (:! (List Syntax) tokens)])) -## parts (: (Maybe (, Syntax (List Syntax) Syntax)) -## (_lux_case tokens' -## (#Cons [(#Meta [_ (#SymbolS name)]) (#Cons [type #Nil])]) -## (#Some [(symbol$ name) #Nil type]) - -## (#Cons [(#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS name)]) args]))]) (#Cons [type #Nil])]) -## (#Some [(symbol$ name) args type]) - -## _ -## #None))] -## (_lux_case parts -## (#Some [name args type]) -## (let [with-export (: (List Syntax) -## (if export? -## (list (`' (_lux_export (~ name)))) -## #Nil)) -## type' (: Syntax -## (_lux_case args -## #Nil -## type - -## _ -## (`' (;All (~ name) [(~@ args)] (~ type)))))] -## (return (list& (`' (_lux_def (~ name) (;type (~ type')))) -## with-export))) - -## #None -## (fail "Wrong syntax for deftype")) -## )) - -(defmacro #export (exec tokens) - (_lux_case (reverse tokens) - (#Cons [value actions]) - (let [dummy (symbol$ ["" ""])] - (return (list (foldL (lambda [post pre] (`' (_lux_case (~ pre) (~ dummy) (~ post)))) - value - actions)))) - - _ - (fail "Wrong syntax for exec"))) - -(defmacro #export (def tokens) - (let [[export? tokens'] (: (, Bool (List Syntax)) - (_lux_case tokens - (#Cons [(#Meta [_ (#TagS ["" "export"])]) tokens']) - [true tokens'] - - _ - [false tokens])) - parts (: (Maybe (, Syntax (List Syntax) (Maybe Syntax) Syntax)) - (_lux_case tokens' - (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) (#Cons [type (#Cons [body #Nil])])]) - (#Some [name args (#Some type) body]) - - (#Cons [name (#Cons [type (#Cons [body #Nil])])]) - (#Some [name #Nil (#Some type) body]) - - (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) (#Cons [body #Nil])]) - (#Some [name args #None body]) - - (#Cons [name (#Cons [body #Nil])]) - (#Some [name #Nil #None body]) - - _ - #None))] - (_lux_case parts - (#Some [name args ?type body]) - (let [body' (: Syntax - (_lux_case args - #Nil - body - - _ - (`' (;lambda (~ name) [(~@ args)] (~ body))))) - body'' (: Syntax - (_lux_case ?type - (#Some type) - (`' (: (~ type) (~ body'))) - - #None - body'))] - (return (list& (`' (_lux_def (~ name) (~ body''))) - (if export? - (list (`' (_lux_export (~ name)))) - #Nil)))) - - #None - (fail "Wrong syntax for def")))) - -(def (rejoin-pair pair) - (-> (, Syntax Syntax) (List Syntax)) - (let [[left right] pair] - (list left right))) - -(defmacro #export (case tokens) - (_lux_case tokens - (#Cons [value branches]) - (do Lux/Monad - [expansions (map% Lux/Monad - (: (-> (, Syntax Syntax) (Lux (List (, Syntax Syntax)))) - (lambda expander [branch] - (let [[pattern body] branch] - (_lux_case pattern - (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS macro-name)]) macro-args]))]) - (do Lux/Monad - [expansion (macro-expand (form$ (list& (symbol$ macro-name) body macro-args))) - expansions (map% Lux/Monad expander (as-pairs expansion))] - (;return (list:join expansions))) - - _ - (;return (list branch)))))) - (as-pairs branches))] - (;return (list (`' (_lux_case (~ value) - (~@ (|> expansions list:join (map rejoin-pair) list:join))))))) - - _ - (fail "Wrong syntax for case"))) - -(defmacro #export (\ tokens) - (case tokens - (#Cons [body (#Cons [pattern #Nil])]) - (do Lux/Monad - [pattern+ (macro-expand pattern)] - (case pattern+ - (#Cons [pattern' #Nil]) - (;return (list pattern' body)) - - _ - (fail "\\ can only expand to 1 pattern."))) - - _ - (fail "Wrong syntax for \\"))) - -(defmacro #export (\or tokens) - (case tokens - (#Cons [body patterns]) - (case patterns - #Nil - (fail "\\or can't have 0 patterns") - - _ - (do Lux/Monad - [patterns' (map% Lux/Monad macro-expand patterns)] - (;return (list:join (map (lambda [pattern] (list pattern body)) - (list:join patterns')))))) - - _ - (fail "Wrong syntax for \\or"))) - -(do-template [ ] - [(def #export (i+ ))] - - [inc 1] - [dec -1]) - -(defmacro #export (` tokens) - (do Lux/Monad - [module-name get-module-name] - (case tokens - (\ (list template)) - (;return (list (untemplate true module-name template))) - - _ - (fail "Wrong syntax for `")))) - -(def (gensym prefix state) - (-> Text (Lux Syntax)) - (case state - {#source source #modules modules - #envs envs #types types #host host - #seed seed #eval? eval?} - (#Right [{#source source #modules modules - #envs envs #types types #host host - #seed (inc seed) #eval? eval?} - (symbol$ ["__gensym__" (->text seed)])]))) - -(def (macro-expand-1 token) - (-> Syntax (Lux Syntax)) - (do Lux/Monad - [token+ (macro-expand token)] - (case token+ - (\ (list token')) - (;return token') - - _ - (fail "Macro expanded to more than 1 element.")))) - -(defmacro #export (sig tokens) - (do Lux/Monad - [tokens' (map% Lux/Monad macro-expand tokens) - members (map% Lux/Monad - (: (-> Syntax (Lux (, Ident Syntax))) - (lambda [token] - (case token - (\ (#Meta [_ (#FormS (list (#Meta [_ (#SymbolS ["" "_lux_:"])]) type (#Meta [_ (#SymbolS name)])))])) - (do Lux/Monad - [name' (normalize name)] - (;return (: (, Ident Syntax) [name' type]))) - - _ - (fail "Signatures require typed members!")))) - (list:join tokens'))] - (;return (list (`' (#;RecordT (~ (untemplate-list (map (: (-> (, Ident Syntax) Syntax) - (lambda [pair] - (let [[name type] pair] - (`' [(~ (|> name ident->text text$)) - (~ type)])))) - members))))))))) - -(defmacro #export (defsig tokens) - (let [[export? tokens'] (: (, Bool (List Syntax)) - (case tokens - (\ (list& (#Meta [_ (#TagS ["" "export"])]) tokens')) - [true tokens'] - - _ - [false tokens])) - ?parts (: (Maybe (, Syntax (List Syntax) (List Syntax))) - (case tokens' - (\ (list& (#Meta [_ (#FormS (list& name args))]) sigs)) - (#Some [name args sigs]) - - (\ (list& name sigs)) - (#Some [name #Nil sigs]) - - _ - #None))] - (case ?parts - (#Some [name args sigs]) - (let [sigs' (: Syntax - (case args - #Nil - (`' (;sig (~@ sigs))) - - _ - (`' (;All (~ name) [(~@ args)] (;sig (~@ sigs))))))] - (return (list& (`' (_lux_def (~ name) (~ sigs'))) - (if export? - (list (`' (_lux_export (~ name)))) - #Nil)))) - - #None - (fail "Wrong syntax for defsig")))) - -(defmacro #export (struct tokens) - (do Lux/Monad - [tokens' (map% Lux/Monad macro-expand tokens) - members (map% Lux/Monad - (: (-> Syntax (Lux (, Syntax Syntax))) - (lambda [token] - (case token - (\ (#Meta [_ (#FormS (list (#Meta [_ (#SymbolS ["" "_lux_def"])]) (#Meta [_ (#SymbolS name)]) value))])) - (do Lux/Monad - [name' (normalize name)] - (;return (: (, Syntax Syntax) [(tag$ name') value]))) - - _ - (fail "Structures require defined members!")))) - (list:join tokens'))] - (;return (list (record$ members))))) - -(defmacro #export (defstruct tokens) - (let [[export? tokens'] (: (, Bool (List Syntax)) - (case tokens - (\ (list& (#Meta [_ (#TagS ["" "export"])]) tokens')) - [true tokens'] - - _ - [false tokens])) - ?parts (: (Maybe (, Syntax (List Syntax) Syntax (List Syntax))) - (case tokens' - (\ (list& (#Meta [_ (#FormS (list& name args))]) type defs)) - (#Some [name args type defs]) - - (\ (list& name type defs)) - (#Some [name #Nil type defs]) - - _ - #None))] - (case ?parts - (#Some [name args type defs]) - (let [defs' (: Syntax - (case args - #Nil - (`' (;struct (~@ defs))) - - _ - (`' (;lambda (~ name) [(~@ args)] (;struct (~@ defs))))))] - (return (list& (`' (def (~ name) (~ type) (~ defs'))) - (if export? - (list (`' (_lux_export (~ name)))) - #Nil)))) - - #None - (fail "Wrong syntax for defstruct")))) - -(def #export (id x) - (All [a] (-> a a)) - x) - -(do-template [
] - [(defmacro #export ( tokens) - (case (reverse tokens) - (\ (list& last init)) - (return (list (foldL (lambda [post pre] (` )) - last - init))) - - _ - (fail )))] - - [and (if (~ pre) (~ post) false) "and requires >=1 clauses."] - [or (if (~ pre) true (~ post)) "or requires >=1 clauses."]) - -(deftype Referrals - (| #All - (#Only (List Text)) - (#Except (List Text)) - #Nothing)) - -(deftype Import - (, Text (Maybe Text) Referrals)) - -(def (extract-defs defs) - (-> (List Syntax) (Lux (List Text))) - (map% Lux/Monad - (: (-> Syntax (Lux Text)) - (lambda [def] - (case def - (#Meta [_ (#SymbolS ["" name])]) - (return name) - - _ - (fail "only/except requires symbols.")))) - defs)) - -(def (parse-alias tokens) - (-> (List Syntax) (Lux (, (Maybe Text) (List Syntax)))) - (case tokens - (\ (list& (#Meta [_ (#TagS ["" "as"])]) (#Meta [_ (#SymbolS ["" alias])]) tokens')) - (return (: (, (Maybe Text) (List Syntax)) [(#Some alias) tokens'])) - - _ - (return (: (, (Maybe Text) (List Syntax)) [#None tokens])))) - -(def (parse-referrals tokens) - (-> (List Syntax) (Lux (, Referrals (List Syntax)))) - (case tokens - (\ (list& (#Meta [_ (#TagS ["" "refer"])]) referral tokens')) - (case referral - (#Meta [_ (#TagS ["" "all"])]) - (return (: (, Referrals (List Syntax)) [#All tokens'])) - - (\ (#Meta [_ (#FormS (list& (#Meta [_ (#TagS ["" "only"])]) defs))])) - (do Lux/Monad - [defs' (extract-defs defs)] - (return (: (, Referrals (List Syntax)) [(#Only defs') tokens']))) - - (\ (#Meta [_ (#FormS (list& (#Meta [_ (#TagS ["" "except"])]) defs))])) - (do Lux/Monad - [defs' (extract-defs defs)] - (return (: (, Referrals (List Syntax)) [(#Except defs') tokens']))) - - _ - (fail "Incorrect syntax for referral.")) - - _ - (return (: (, Referrals (List Syntax)) [#Nothing tokens])))) - -(def (decorate-imports super-name tokens) - (-> Text (List Syntax) (Lux (List Syntax))) - (map% Lux/Monad - (: (-> Syntax (Lux Syntax)) - (lambda [token] - (case token - (#Meta [_ (#SymbolS ["" sub-name])]) - (return (symbol$ ["" ($ text:++ super-name "/" sub-name)])) - - (\ (#Meta [_ (#FormS (list& (#Meta [_ (#SymbolS ["" sub-name])]) parts))])) - (return (form$ (list& (symbol$ ["" ($ text:++ super-name "/" sub-name)]) parts))) - - _ - (fail "Wrong import syntax.")))) - tokens)) - -(def (parse-imports imports) - (-> (List Syntax) (Lux (List Import))) - (do Lux/Monad - [referrals' (map% Lux/Monad - (: (-> Syntax (Lux (List Import))) - (lambda [token] - (case token - (#Meta [_ (#SymbolS ["" m-name])]) - (;return (list [m-name #None #All])) - - (\ (#Meta [_ (#FormS (list& (#Meta [_ (#SymbolS ["" m-name])]) extra))])) - (do Lux/Monad - [alias+extra' (parse-alias extra) - #let [[alias extra'] (: (, (Maybe Text) (List Syntax)) - alias+extra')] - referral+extra'' (parse-referrals extra') - #let [[referral extra''] (: (, Referrals (List Syntax)) - referral+extra'')] - extra''' (decorate-imports m-name extra'') - sub-imports (parse-imports extra''')] - (;return (case referral - #Nothing (case alias - #None sub-imports - (#Some _) (list& [m-name alias referral] sub-imports)) - _ (list& [m-name alias referral] sub-imports)))) - - _ - (fail "Wrong syntax for import")))) - imports)] - (;return (list:join referrals')))) - -(def (module-exists? module state) - (-> Text (Lux Bool)) - (case state - {#source source #modules modules - #envs envs #types types #host host - #seed seed #eval? eval?} - (case (get module modules) - (#Some =module) - (#Right [state true]) - - #None - (#Right [state false])) - )) - -(def (exported-defs module state) - (-> Text (Lux (List Text))) - (case state - {#source source #modules modules - #envs envs #types types #host host - #seed seed #eval? eval?} - (case (get module modules) - (#Some =module) - (let [to-alias (map (: (-> (, Text (, Bool (DefData' (-> (List Syntax) (StateE Compiler (List Syntax)))))) - (List Text)) - (lambda [gdef] - (let [[name [export? _]] gdef] - (if export? - (list name) - (list))))) - (let [{#module-aliases _ #defs defs #imports _} =module] - defs))] - (#Right [state (list:join to-alias)])) - - #None - (#Left ($ text:++ "Unknown module: " module))) - )) - -(def (last-index-of part text) - (-> Text Text Int) - (_jvm_i2l (_jvm_invokevirtual java.lang.String lastIndexOf [java.lang.String] - text [part]))) - -(def (index-of part text) - (-> Text Text Int) - (_jvm_i2l (_jvm_invokevirtual java.lang.String indexOf [java.lang.String] - text [part]))) - -(def (substring1 idx text) - (-> Int Text Text) - (_jvm_invokevirtual java.lang.String substring [int] - text [(_jvm_l2i idx)])) - -(def (substring2 idx1 idx2 text) - (-> Int Int Text Text) - (_jvm_invokevirtual java.lang.String substring [int int] - text [(_jvm_l2i idx1) (_jvm_l2i idx2)])) - -(def (split-module-contexts module) - (-> Text (List Text)) - (#Cons [module (let [idx (last-index-of "/" module)] - (if (i< idx 0) - #Nil - (split-module-contexts (substring2 0 idx module))))])) - -(def (split-module module) - (-> Text (List Text)) - (let [idx (index-of "/" module)] - (if (i< idx 0) - (#Cons [module #Nil]) - (#Cons [(substring2 0 idx module) - (split-module (substring1 (inc idx) module))])))) - -(def (@ idx xs) - (All [a] - (-> Int (List a) (Maybe a))) - (case xs - #Nil - #None - - (#Cons [x xs']) - (if (i= idx 0) - (#Some x) - (@ (dec idx) xs') - ))) - -(def (split-with' p ys xs) - (All [a] - (-> (-> a Bool) (List a) (List a) (, (List a) (List a)))) - (case xs - #Nil - [ys xs] - - (#Cons [x xs']) - (if (p x) - (split-with' p (list& x ys) xs') - [ys xs]))) - -(def (split-with p xs) - (All [a] - (-> (-> a Bool) (List a) (, (List a) (List a)))) - (let [[ys' xs'] (split-with' p #Nil xs)] - [(reverse ys') xs'])) - -(def (clean-module module) - (-> Text (Lux Text)) - (do Lux/Monad - [module-name get-module-name] - (case (split-module module) - (\ (list& "." parts)) - (return (|> (list& module-name parts) (interpose "/") (foldL text:++ ""))) - - parts - (let [[ups parts'] (split-with (text:= "..") parts) - num-ups (length ups)] - (if (i= num-ups 0) - (return module) - (case (@ num-ups (split-module-contexts module-name)) - #None - (fail (text:++ "Can't clean module: " module)) - - (#Some top-module) - (return (|> (list& top-module parts') (interpose "/") (foldL text:++ "")))) - ))) - )) - -(def (filter p xs) - (All [a] (-> (-> a Bool) (List a) (List a))) - (case xs - #;Nil - (list) - - (#;Cons [x xs']) - (if (p x) - (#;Cons [x (filter p xs')]) - (filter p xs')))) - -(def (is-member? cases name) - (-> (List Text) Text Bool) - (let [output (foldL (lambda [prev case] - (or prev - (text:= case name))) - false - cases)] - output)) - -(defmacro #export (import tokens) - (do Lux/Monad - [imports (parse-imports tokens) - imports (map% Lux/Monad - (: (-> Import (Lux Import)) - (lambda [import] - (case import - [m-name m-alias m-referrals] - (do Lux/Monad - [m-name (clean-module m-name)] - (;return (: Import [m-name m-alias m-referrals])))))) - imports) - unknowns' (map% Lux/Monad - (: (-> Import (Lux (List Text))) - (lambda [import] - (case import - [m-name _ _] - (do Lux/Monad - [? (module-exists? m-name)] - (;return (if ? - (list) - (list m-name))))))) - imports) - #let [unknowns (list:join unknowns')]] - (case unknowns - #Nil - (do Lux/Monad - [output' (map% Lux/Monad - (: (-> Import (Lux (List Syntax))) - (lambda [import] - (case import - [m-name m-alias m-referrals] - (do Lux/Monad - [defs (case m-referrals - #All - (exported-defs m-name) - - (#Only +defs) - (do Lux/Monad - [*defs (exported-defs m-name)] - (;return (filter (is-member? +defs) *defs))) - - (#Except -defs) - (do Lux/Monad - [*defs (exported-defs m-name)] - (;return (filter (. not (is-member? -defs)) *defs))) - - #Nothing - (;return (list)))] - (;return ($ list:++ - (list (` (_lux_import (~ (text$ m-name))))) - (case m-alias - #None (list) - (#Some alias) (list (` (_lux_alias (~ (text$ alias)) (~ (text$ m-name)))))) - (map (: (-> Text Syntax) - (lambda [def] - (` ((~ (symbol$ ["" "_lux_def"])) (~ (symbol$ ["" def])) (~ (symbol$ [m-name def])))))) - defs))))))) - imports)] - (;return (list:join output'))) - - _ - (;return (: (List Syntax) - (list:++ (map (lambda [m-name] (` (_lux_import (~ (text$ m-name))))) - unknowns) - (list (` (import (~@ tokens)))))))))) - -(def (some f xs) - (All [a b] - (-> (-> a (Maybe b)) (List a) (Maybe b))) - (case xs - #Nil - #None - - (#Cons [x xs']) - (case (f x) - #None - (some f xs') - - (#Some y) - (#Some y)))) - -(def (split-slot slot) - (-> Text (, Text Text)) - (let [idx (index-of ";" slot) - module (substring2 0 idx slot) - name (substring1 (inc idx) slot)] - [module name])) - -(def (type:show type) - (-> Type Text) - (case type - (#DataT name) - ($ text:++ "(^ " name ")") - - (#TupleT elems) - (case elems - #;Nil - "(,)" - - _ - ($ text:++ "(, " (|> elems (map type:show) (interpose " ") (foldL text:++ "")) ")")) - - (#VariantT cases) - (case cases - #;Nil - "(|)" - - _ - ($ text:++ "(| " - (|> cases - (map (: (-> (, Text Type) Text) - (lambda [kv] - (case kv - [k (#TupleT #;Nil)] - ($ text:++ "#" k) - - [k v] - ($ text:++ "(#" k " " (type:show v) ")"))))) - (interpose " ") - (foldL text:++ "")) - ")")) - - (#RecordT fields) - (case fields - #;Nil - "(&)" - - _ - ($ text:++ "(& " - (|> fields - (map (: (-> (, Text Type) Text) - (: (-> (, Text Type) Text) - (lambda [kv] - (let [[k v] kv] - ($ text:++ "(#" k " " (type:show v) ")")))))) - (interpose " ") - (foldL text:++ "")) - ")")) - - (#LambdaT [input output]) - ($ text:++ "(-> " (type:show input) " " (type:show output) ")") - - (#VarT id) - ($ text:++ "⌈" (->text id) "⌋") - - (#BoundT name) - name - - (#ExT ?id) - ($ text:++ "⟨" (->text ?id) "⟩") - - (#AppT [?lambda ?param]) - ($ text:++ "(" (type:show ?lambda) " " (type:show ?param) ")") - - (#AllT [?env ?name ?arg ?body]) - ($ text:++ "(All " ?name " [" ?arg "] " (type:show ?body) ")") - )) - -(def (beta-reduce env type) - (-> (List (, Text Type)) Type Type) - (case type - (#VariantT ?cases) - (#VariantT (map (: (-> (, Text Type) (, Text Type)) - (lambda [kv] - (let [[k v] kv] - [k (beta-reduce env v)]))) - ?cases)) - - (#RecordT ?fields) - (#RecordT (map (: (-> (, Text Type) (, Text Type)) - (lambda [kv] - (let [[k v] kv] - [k (beta-reduce env v)]))) - ?fields)) - - (#TupleT ?members) - (#TupleT (map (beta-reduce env) ?members)) - - (#AppT [?type-fn ?type-arg]) - (#AppT [(beta-reduce env ?type-fn) (beta-reduce env ?type-arg)]) - - (#AllT [?local-env ?local-name ?local-arg ?local-def]) - (case ?local-env - #None - (#AllT [(#Some env) ?local-name ?local-arg ?local-def]) - - (#Some _) - type) - - (#LambdaT [?input ?output]) - (#LambdaT [(beta-reduce env ?input) (beta-reduce env ?output)]) - - (#BoundT ?name) - (case (get ?name env) - (#Some bound) - bound - - _ - type) - - _ - type - )) - -(defmacro #export (? tokens) - (case tokens - (\ (list maybe else)) - (do Lux/Monad - [g!value (gensym "")] - (return (list (` (case (~ maybe) - (#;Some (~ g!value)) - (~ g!value) - - _ - (~ else)))))) - - _ - (fail "Wrong syntax for ?"))) - -(def (apply-type type-fn param) - (-> Type Type (Maybe Type)) - (case type-fn - (#AllT [env name arg body]) - (#Some (beta-reduce (|> (? env (list)) - (put name type-fn) - (put arg param)) - body)) - - (#AppT [F A]) - (do Maybe/Monad - [type-fn* (apply-type F A)] - (apply-type type-fn* param)) - - _ - #None)) - -(def (resolve-struct-type type) - (-> Type (Maybe Type)) - (case type - (#RecordT slots) - (#Some type) - - (#AppT [fun arg]) - (apply-type fun arg) - - (#AllT [_ _ _ body]) - (resolve-struct-type body) - - _ - #None)) - -(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 (show-envs envs) - (-> (List (Env Text (, LuxVar Type))) Text) - (|> envs - (map (lambda [env] - (case env - {#name name #inner-closures _ #locals {#counter _ #mappings locals} #closure _} - ($ text:++ name ": " (|> locals - (map (: (All [a] (-> (, Text a) Text)) - (lambda [b] (let [[label _] b] label)))) - (interpose " ") - (foldL text:++ "")))))) - (interpose "\n") - (foldL text:++ ""))) - -(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 (find-in-defs name state) -## (-> Ident Compiler (Maybe Type)) -## (exec (_jvm_invokevirtual java.io.PrintStream print [java.lang.Object] -## (_jvm_getstatic java.lang.System out) [($ text:++ "find-in-defs #1: " (ident->text name) "\n")]) -## (let [[v-prefix v-name] name -## {#source source #modules modules -## #envs envs #types types #host host -## #seed seed #eval? eval?} state] -## (do Maybe/Monad -## [module (get v-prefix modules) -## #let [{#defs defs #module-aliases _ #imports _} module] -## def (get v-name defs) -## #let [[_ def-data] def]] -## (case def-data -## #TypeD (;return Type) -## (#ValueD type) (;return type) -## (#MacroD m) (;return Macro) -## (#AliasD name') (find-in-defs name' state)))))) - -(def (find-var-type name) - (-> Ident (Lux Type)) - (do Lux/Monad - [name' (normalize name)] - (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))))))))) - -(defmacro #export (using tokens) - (case tokens - (\ (list struct body)) - (case struct - (#Meta [_ (#SymbolS name)]) - (do Lux/Monad - [struct-type (find-var-type name)] - (case (resolve-struct-type struct-type) - (#Some (#RecordT slots)) - (let [pattern (record$ (map (: (-> (, Text Type) (, Syntax Syntax)) - (lambda [slot] - (let [[sname stype] slot - full-name (split-slot sname)] - [(tag$ full-name) (symbol$ full-name)]))) - slots))] - (return (list (` (_lux_case (~ struct) (~ pattern) (~ body)))))) - - _ - (fail "Can only \"use\" records."))) - - _ - (let [dummy (symbol$ ["" ""])] - (return (list (` (_lux_case (~ struct) - (~ dummy) - (using (~ dummy) - (~ body)))))))) - - _ - (fail "Wrong syntax for using"))) - -(def #export (flip f) - (All [a b c] - (-> (-> a b c) (-> b a c))) - (lambda [y x] - (f x y))) - -(def #export (curry f) - (All [a b c] - (-> (-> (, a b) c) - (-> a b c))) - (lambda [x y] - (f [x y]))) - -(def #export (uncurry f) - (All [a b c] - (-> (-> a b c) - (-> (, a b) c))) - (lambda [xy] - (let [[x y] xy] - (f x y)))) - -(defmacro #export (cond tokens) - (if (i= 0 (i% (length tokens) 2)) - (fail "cond requires an even number of arguments.") - (case (reverse tokens) - (\ (list& else branches')) - (return (list (foldL (: (-> Syntax (, Syntax Syntax) Syntax) - (lambda [else branch] - (let [[right left] branch] - (` (if (~ left) (~ right) (~ else)))))) - else - (as-pairs branches')))) - - _ - (fail "Wrong syntax for cond")))) - -(defmacro #export (get@ tokens) - (case tokens - (\ (list (#Meta [_ (#TagS slot')]) record)) - (case record - (#Meta [_ (#SymbolS name)]) - (do Lux/Monad - [type (find-var-type name) - g!blank (gensym "") - g!output (gensym "")] - (case (resolve-struct-type type) - (#Some (#RecordT slots)) - (do Lux/Monad - [slot (normalize slot')] - (let [[s-prefix s-name] (: Ident slot) - pattern (record$ (map (: (-> (, Text Type) (, Syntax Syntax)) - (lambda [slot] - (let [[r-slot-name r-type] slot - [r-prefix r-name] (split-slot r-slot-name)] - [(tag$ [r-prefix r-name]) (if (and (text:= s-prefix r-prefix) - (text:= s-name r-name)) - g!output - g!blank)]))) - slots))] - (return (list (` (_lux_case (~ record) (~ pattern) (~ g!output))))))) - - _ - (fail "get@ can only use records."))) - - _ - (do Lux/Monad - [_record (gensym "")] - (return (list (` (let [(~ _record) (~ record)] - (get@ (~ (tag$ slot')) (~ _record)))))))) - - _ - (fail "Wrong syntax for get@"))) - -(defmacro #export (open tokens) - (case tokens - (\ (list (#Meta [_ (#SymbolS struct-name)]))) - (do Lux/Monad - [struct-type (find-var-type struct-name)] - (case (resolve-struct-type struct-type) - (#Some (#RecordT slots)) - (return (map (: (-> (, Text Type) Syntax) - (lambda [slot] - (let [[sname stype] slot - [module name] (split-slot sname)] - (` (_lux_def (~ (symbol$ ["" name])) - (get@ (~ (tag$ [module name])) (~ (symbol$ struct-name)))))))) - slots)) - - _ - (fail "Can only \"open\" records."))) - - _ - (fail "Wrong syntax for open"))) - -(def (foldL% M f x ys) - (All [m a b] - (-> (Monad m) (-> a b (m a)) a (List b) - (m a))) - (case ys - (#Cons [y ys']) - (do M - [x' (f x y)] - (foldL% M f x' ys')) - - #Nil - ((get@ #return M) x))) - -(defmacro #export (:: tokens) - (case tokens - (\ (list& start parts)) - (do Lux/Monad - [output (foldL% Lux/Monad - (: (-> Syntax Syntax (Lux Syntax)) - (lambda [so-far part] - (case part - (#Meta [_ (#SymbolS slot)]) - (return (` (get@ (~ (tag$ slot)) (~ so-far)))) - - (\ (#Meta [_ (#FormS (list& (#Meta [_ (#SymbolS slot)]) args))])) - (return (` ((get@ (~ (tag$ slot)) (~ so-far)) - (~@ args)))) - - _ - (fail "Wrong syntax for ::")))) - start parts)] - (return (list output))) - - _ - (fail "Wrong syntax for ::"))) - -(defmacro #export (set@ tokens) - (case tokens - (\ (list (#Meta [_ (#TagS slot')]) value record)) - (case record - (#Meta [_ (#SymbolS name)]) - (do Lux/Monad - [type (find-var-type name)] - (case (resolve-struct-type type) - (#Some (#RecordT slots)) - (do Lux/Monad - [pattern' (map% Lux/Monad - (: (-> (, Text Type) (Lux (, Text Syntax))) - (lambda [slot] - (let [[r-slot-name r-type] slot] - (do Lux/Monad - [g!slot (gensym "")] - (return [r-slot-name g!slot]))))) - slots) - slot (normalize slot')] - (let [[s-prefix s-name] (: Ident slot) - pattern (record$ (map (: (-> (, Text Syntax) (, Syntax Syntax)) - (lambda [slot] - (let [[r-slot-name r-var] slot] - [(tag$ (split-slot r-slot-name)) r-var]))) - pattern')) - output (record$ (map (: (-> (, Text Syntax) (, Syntax Syntax)) - (lambda [slot] - (let [[r-slot-name r-var] slot - [r-prefix r-name] (split-slot r-slot-name)] - [(tag$ [r-prefix r-name]) (if (and (text:= s-prefix r-prefix) - (text:= s-name r-name)) - value - r-var)]))) - pattern'))] - (return (list (` (_lux_case (~ record) (~ pattern) (~ output))))))) - - _ - (fail "set@ can only use records."))) - - _ - (do Lux/Monad - [_record (gensym "")] - (return (list (` (let [(~ _record) (~ record)] - (set@ (~ (tag$ slot')) (~ value) (~ _record)))))))) - - _ - (fail "Wrong syntax for set@"))) - -(defmacro #export (update@ tokens) - (case tokens - (\ (list (#Meta [_ (#TagS slot')]) fun record)) - (case record - (#Meta [_ (#SymbolS name)]) - (do Lux/Monad - [type (find-var-type name)] - (case (resolve-struct-type type) - (#Some (#RecordT slots)) - (do Lux/Monad - [pattern' (map% Lux/Monad - (: (-> (, Text Type) (Lux (, Text Syntax))) - (lambda [slot] - (let [[r-slot-name r-type] slot] - (do Lux/Monad - [g!slot (gensym "")] - (return [r-slot-name g!slot]))))) - slots) - slot (normalize slot')] - (let [[s-prefix s-name] (: Ident slot) - pattern (record$ (map (: (-> (, Text Syntax) (, Syntax Syntax)) - (lambda [slot] - (let [[r-slot-name r-var] slot] - [(tag$ (split-slot r-slot-name)) r-var]))) - pattern')) - output (record$ (map (: (-> (, Text Syntax) (, Syntax Syntax)) - (lambda [slot] - (let [[r-slot-name r-var] slot - [r-prefix r-name] (split-slot r-slot-name)] - [(tag$ [r-prefix r-name]) (if (and (text:= s-prefix r-prefix) - (text:= s-name r-name)) - (` ((~ fun) (~ r-var))) - r-var)]))) - pattern'))] - (return (list (` (_lux_case (~ record) (~ pattern) (~ output))))))) - - _ - (fail "update@ can only use records."))) - - _ - (do Lux/Monad - [_record (gensym "")] - (return (list (` (let [(~ _record) (~ record)] - (update@ (~ (tag$ slot')) (~ fun) (~ _record)))))))) - - _ - (fail "Wrong syntax for update@"))) - -(defmacro #export (\template tokens) - (case tokens - (\ (list (#Meta [_ (#TupleS data)]) - (#Meta [_ (#TupleS bindings)]) - (#Meta [_ (#TupleS templates)]))) - (case (: (Maybe (List Syntax)) - (do Maybe/Monad - [bindings' (map% Maybe/Monad get-ident bindings) - data' (map% Maybe/Monad tuple->list data)] - (let [apply (: (-> RepEnv (List Syntax)) - (lambda [env] (map (apply-template env) templates)))] - (|> data' - (join-map (. apply (make-env bindings'))) - ;return)))) - (#Some output) - (return output) - - #None - (fail "Wrong syntax for \\template")) - - _ - (fail "Wrong syntax for \\template"))) - -(def #export complement - (All [a] (-> (-> a Bool) (-> a Bool))) - (. not)) - -## (defmacro #export (loop tokens) -## (case tokens -## (\ (list bindings body)) -## (let [pairs (as-pairs bindings) -## vars (map first pairs) -## inits (map second pairs)] -## (if (every? symbol? inits) -## (do Lux/Monad -## [inits' (map% Maybe/Monad get-ident inits) -## init-types (map% Maybe/Monad find-var-type inits')] -## (return (list (` ((lambda (~ (#SymbolS ["" "recur"])) [(~@ vars)] -## (~ body)) -## (~@ inits)))))) -## (do Lux/Monad -## [aliases (map% Maybe/Monad (lambda [_] (gensym "")) inits)] -## (return (list (` (let [(~@ (interleave aliases inits))] -## (loop [(~@ (interleave vars aliases))] -## (~ body))))))))) - -## _ -## (fail "Wrong syntax for loop"))) -- cgit v1.2.3