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 ---------------------------------------- input/lux/codata/stream.lux | 133 -- input/lux/control/comonad.lux | 54 - input/lux/control/functor.lux | 15 - input/lux/control/lazy.lux | 47 - input/lux/control/monad.lux | 99 -- input/lux/control/monoid.lux | 24 - input/lux/data/bool.lux | 33 - input/lux/data/bounded.lux | 17 - input/lux/data/char.lux | 20 - input/lux/data/dict.lux | 83 -- input/lux/data/either.lux | 46 - input/lux/data/eq.lux | 14 - input/lux/data/error.lux | 34 - input/lux/data/id.lux | 28 - input/lux/data/io.lux | 51 - input/lux/data/list.lux | 250 ---- input/lux/data/maybe.lux | 42 - input/lux/data/number.lux | 119 -- input/lux/data/ord.lux | 44 - input/lux/data/reader.lux | 33 - input/lux/data/show.lux | 14 - input/lux/data/state.lux | 35 - input/lux/data/text.lux | 146 --- input/lux/data/writer.lux | 34 - input/lux/host/java.lux | 312 ----- input/lux/math.lux | 60 - input/lux/meta/lux.lux | 287 ----- input/lux/meta/macro.lux | 54 - input/lux/meta/syntax.lux | 262 ---- input/program.lux | 48 - source/lux.lux | 2784 ++++++++++++++++++++++++++++++++++++++++ source/lux/codata/stream.lux | 133 ++ source/lux/control/comonad.lux | 54 + source/lux/control/functor.lux | 15 + source/lux/control/lazy.lux | 47 + source/lux/control/monad.lux | 99 ++ source/lux/control/monoid.lux | 24 + source/lux/data/bool.lux | 33 + source/lux/data/bounded.lux | 17 + source/lux/data/char.lux | 20 + source/lux/data/dict.lux | 83 ++ source/lux/data/either.lux | 46 + source/lux/data/eq.lux | 14 + source/lux/data/error.lux | 34 + source/lux/data/id.lux | 28 + source/lux/data/io.lux | 51 + source/lux/data/list.lux | 250 ++++ source/lux/data/maybe.lux | 42 + source/lux/data/number.lux | 119 ++ source/lux/data/ord.lux | 44 + source/lux/data/reader.lux | 33 + source/lux/data/show.lux | 14 + source/lux/data/state.lux | 35 + source/lux/data/text.lux | 146 +++ source/lux/data/writer.lux | 34 + source/lux/host/java.lux | 312 +++++ source/lux/math.lux | 60 + source/lux/meta/lux.lux | 287 +++++ source/lux/meta/macro.lux | 54 + source/lux/meta/syntax.lux | 262 ++++ source/program.lux | 48 + src/lux.clj | 4 +- src/lux/analyser/host.clj | 6 +- src/lux/analyser/lux.clj | 2 +- src/lux/compiler.clj | 34 +- src/lux/compiler/base.clj | 144 +-- src/lux/compiler/cache.clj | 135 ++ 68 files changed, 5387 insertions(+), 5382 deletions(-) delete mode 100644 input/lux.lux delete mode 100644 input/lux/codata/stream.lux delete mode 100644 input/lux/control/comonad.lux delete mode 100644 input/lux/control/functor.lux delete mode 100644 input/lux/control/lazy.lux delete mode 100644 input/lux/control/monad.lux delete mode 100644 input/lux/control/monoid.lux delete mode 100644 input/lux/data/bool.lux delete mode 100644 input/lux/data/bounded.lux delete mode 100644 input/lux/data/char.lux delete mode 100644 input/lux/data/dict.lux delete mode 100644 input/lux/data/either.lux delete mode 100644 input/lux/data/eq.lux delete mode 100644 input/lux/data/error.lux delete mode 100644 input/lux/data/id.lux delete mode 100644 input/lux/data/io.lux delete mode 100644 input/lux/data/list.lux delete mode 100644 input/lux/data/maybe.lux delete mode 100644 input/lux/data/number.lux delete mode 100644 input/lux/data/ord.lux delete mode 100644 input/lux/data/reader.lux delete mode 100644 input/lux/data/show.lux delete mode 100644 input/lux/data/state.lux delete mode 100644 input/lux/data/text.lux delete mode 100644 input/lux/data/writer.lux delete mode 100644 input/lux/host/java.lux delete mode 100644 input/lux/math.lux delete mode 100644 input/lux/meta/lux.lux delete mode 100644 input/lux/meta/macro.lux delete mode 100644 input/lux/meta/syntax.lux delete mode 100644 input/program.lux create mode 100644 source/lux.lux create mode 100644 source/lux/codata/stream.lux create mode 100644 source/lux/control/comonad.lux create mode 100644 source/lux/control/functor.lux create mode 100644 source/lux/control/lazy.lux create mode 100644 source/lux/control/monad.lux create mode 100644 source/lux/control/monoid.lux create mode 100644 source/lux/data/bool.lux create mode 100644 source/lux/data/bounded.lux create mode 100644 source/lux/data/char.lux create mode 100644 source/lux/data/dict.lux create mode 100644 source/lux/data/either.lux create mode 100644 source/lux/data/eq.lux create mode 100644 source/lux/data/error.lux create mode 100644 source/lux/data/id.lux create mode 100644 source/lux/data/io.lux create mode 100644 source/lux/data/list.lux create mode 100644 source/lux/data/maybe.lux create mode 100644 source/lux/data/number.lux create mode 100644 source/lux/data/ord.lux create mode 100644 source/lux/data/reader.lux create mode 100644 source/lux/data/show.lux create mode 100644 source/lux/data/state.lux create mode 100644 source/lux/data/text.lux create mode 100644 source/lux/data/writer.lux create mode 100644 source/lux/host/java.lux create mode 100644 source/lux/math.lux create mode 100644 source/lux/meta/lux.lux create mode 100644 source/lux/meta/macro.lux create mode 100644 source/lux/meta/syntax.lux create mode 100644 source/program.lux create mode 100644 src/lux/compiler/cache.clj 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"))) diff --git a/input/lux/codata/stream.lux b/input/lux/codata/stream.lux deleted file mode 100644 index 1d6dd1b50..000000000 --- a/input/lux/codata/stream.lux +++ /dev/null @@ -1,133 +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. - -(;import lux - (lux (control (lazy #as L #refer #all) - (functor #as F #refer #all) - (monad #as M #refer #all) - (comonad #as CM #refer #all)) - (meta lux - macro - syntax) - (data (list #as l #refer (#only list list& List/Monad))))) - -## [Types] -(deftype #export (Stream a) - (Lazy (, a (Stream a)))) - -## [Utils] -(def (cycle' x xs init full) - (All [a] - (-> a (List a) a (List a) (Stream a))) - (case xs - #;Nil (cycle' init full init full) - (#;Cons [y xs']) (... [x (cycle' y xs' init full)]))) - -## [Functions] -(def #export (iterate f x) - (All [a] - (-> (-> a a) a (Stream a))) - (... [x (iterate f (f x))])) - -(def #export (repeat x) - (All [a] - (-> a (Stream a))) - (... [x (repeat x)])) - -(def #export (cycle xs) - (All [a] - (-> (List a) (Maybe (Stream a)))) - (case xs - #;Nil #;None - (#;Cons [x xs']) (#;Some (cycle' x xs' x xs')))) - -(do-template [ ] - [(def #export ( s) - (All [a] (-> (Stream a) )) - (let [[h t] (! s)] - ))] - - [head a h] - [tail (Stream a) t]) - -(def #export (@ idx s) - (All [a] (-> Int (Stream a) a)) - (let [[h t] (! s)] - (if (i> idx 0) - (@ (dec idx) t) - h))) - -(do-template [ ] - [(def #export ( det xs) - (All [a] - (-> (Stream a) (List a))) - (let [[x xs'] (! xs)] - (if - (list& x ( xs')) - (list)))) - - (def #export ( det xs) - (All [a] - (-> (Stream a) (Stream a))) - (let [[x xs'] (! xs)] - (if - ( xs') - xs))) - - (def #export ( det xs) - (All [a] - (-> (Stream a) (, (List a) (Stream a)))) - (let [[x xs'] (! xs)] - (if - (let [[tail next] ( xs')] - [(#;Cons [x tail]) next]) - [(list) xs])))] - - [take-while drop-while split-with (-> a Bool) (det x) det] - [take drop split Int (i> det 0) (dec det)] - ) - -(def #export (unfold step init) - (All [a b] - (-> (-> a (, a b)) a (Stream b))) - (let [[next x] (step init)] - (... [x (unfold step next)]))) - -(def #export (filter p xs) - (All [a] (-> (-> a Bool) (Stream a) (Stream a))) - (let [[x xs'] (! xs)] - (if (p x) - (... [x (filter p xs')]) - (filter p xs')))) - -(def #export (partition p xs) - (All [a] (-> (-> a Bool) (Stream a) (, (Stream a) (Stream a)))) - [(filter p xs) (filter (complement p) xs)]) - -## [Structures] -(defstruct #export Stream/Functor (Functor Stream) - (def (F;map f fa) - (let [[h t] (! fa)] - (... [(f h) (F;map f t)])))) - -(defstruct #export Stream/CoMonad (CoMonad Stream) - (def CM;_functor Stream/Functor) - (def CM;unwrap head) - (def (CM;split wa) - (:: Stream/Functor (F;map repeat wa)))) - -## [Pattern-matching] -(defsyntax #export (\stream body [patterns' (+^ id^)]) - (do Lux/Monad - [patterns (map% Lux/Monad macro-expand-1 patterns') - g!s (gensym "s") - #let [patterns+ (: (List Syntax) - (do List/Monad - [pattern (l;reverse patterns)] - (list (` [(~ pattern) (~ g!s)]) (` (L;! (~ g!s))))))]] - (M;wrap (list g!s (` (;let [(~@ patterns+)] (~ body))))))) diff --git a/input/lux/control/comonad.lux b/input/lux/control/comonad.lux deleted file mode 100644 index 1830ff44f..000000000 --- a/input/lux/control/comonad.lux +++ /dev/null @@ -1,54 +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. - -(;import lux - (../functor #as F) - lux/data/list - lux/meta/macro) - -## Signatures -(defsig #export (CoMonad w) - (: (F;Functor w) - _functor) - (: (All [a] - (-> (w a) a)) - unwrap) - (: (All [a] - (-> (w a) (w (w a)))) - split)) - -## Functions -(def #export (extend w f ma) - (All [w a b] - (-> (CoMonad w) (-> (w a) b) (w a) (w b))) - (using w - (using ;;_functor - (F;map f (;;split ma))))) - -## Syntax -(defmacro #export (be tokens state) - (case tokens - (\ (list monad (#;Meta [_ (#;TupleS bindings)]) body)) - (let [body' (foldL (: (-> Syntax (, Syntax Syntax) Syntax) - (lambda [body' binding] - (let [[var value] binding] - (case var - (#;Meta [_ (#;TagS ["" "let"])]) - (` (;let (~ value) (~ body'))) - - _ - (` (extend (;lambda [(~ var)] (~ body')) - (~ value))))))) - body - (reverse (as-pairs bindings)))] - (#;Right [state (list (` (;case (~ monad) - {#;return ;return #;bind ;bind} - (~ body'))))])) - - _ - (#;Left "Wrong syntax for be"))) diff --git a/input/lux/control/functor.lux b/input/lux/control/functor.lux deleted file mode 100644 index 6a9dcfff8..000000000 --- a/input/lux/control/functor.lux +++ /dev/null @@ -1,15 +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. - -(;import lux) - -## Signatures -(defsig #export (Functor f) - (: (All [a b] - (-> (-> a b) (f a) (f b))) - map)) diff --git a/input/lux/control/lazy.lux b/input/lux/control/lazy.lux deleted file mode 100644 index 22dac74fe..000000000 --- a/input/lux/control/lazy.lux +++ /dev/null @@ -1,47 +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. - -(;import lux - (lux/meta macro) - (.. (functor #as F #refer #all) - (monad #as M #refer #all)) - (lux/data list)) - -## Types -(deftype #export (Lazy a) - (All [b] - (-> (-> a b) b))) - -## Syntax -(defmacro #export (... tokens state) - (case tokens - (\ (list value)) - (let [blank (symbol$ ["" ""])] - (#;Right [state (list (` (;lambda [(~ blank)] ((~ blank) (~ value)))))])) - - _ - (#;Left "Wrong syntax for ..."))) - -## Functions -(def #export (! thunk) - (All [a] - (-> (Lazy a) a)) - (thunk id)) - -## Structs -(defstruct #export Lazy/Functor (Functor Lazy) - (def (F;map f ma) - (lambda [k] (ma (. k f))))) - -(defstruct #export Lazy/Monad (Monad Lazy) - (def M;_functor Lazy/Functor) - - (def (M;wrap a) - (... a)) - - (def M;join !)) diff --git a/input/lux/control/monad.lux b/input/lux/control/monad.lux deleted file mode 100644 index b5552f987..000000000 --- a/input/lux/control/monad.lux +++ /dev/null @@ -1,99 +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. - -(;import lux - (.. (functor #as F) - (monoid #as M)) - lux/meta/macro) - -## [Utils] -(def (foldL f init xs) - (All [a b] - (-> (-> a b a) a (List b) a)) - (case xs - #;Nil - init - - (#;Cons [x xs']) - (foldL f (f init x) xs'))) - -(def (reverse xs) - (All [a] - (-> (List a) (List a))) - (foldL (lambda [tail head] (#;Cons [head tail])) - #;Nil - xs)) - -(def (as-pairs xs) - (All [a] (-> (List a) (List (, a a)))) - (case xs - (#;Cons [x1 (#;Cons [x2 xs'])]) - (#;Cons [[x1 x2] (as-pairs xs')]) - - _ - #;Nil)) - -## [Signatures] -(defsig #export (Monad m) - (: (F;Functor m) - _functor) - (: (All [a] - (-> a (m a))) - wrap) - (: (All [a] - (-> (m (m a)) (m a))) - join)) - -## [Syntax] -(defmacro #export (do tokens state) - (case tokens - ## (\ (list monad (#;Meta [_ (#;TupleS bindings)]) body)) - (#;Cons [monad (#;Cons [(#;Meta [_ (#;TupleS bindings)]) (#;Cons [body #;Nil])])]) - (let [body' (foldL (: (-> Syntax (, Syntax Syntax) Syntax) - (lambda [body' binding] - (let [[var value] binding] - (case var - (#;Meta [_ (#;TagS ["" "let"])]) - (` (;let (~ value) (~ body'))) - - _ - (` (;case ;;_functor - {#F;map F;map} - (;|> (~ value) (F;map (;lambda [(~ var)] (~ body'))) (;;join)))) - ## (` (;|> (~ value) (F;map (;lambda [(~ var)] (~ body'))) (;:: ;;_functor) (;;join))) - )))) - body - (reverse (as-pairs bindings)))] - (#;Right [state (#;Cons [(` (;case (~ monad) - {#;;_functor ;;_functor #;;wrap ;;wrap #;;join ;;join} - (~ body'))) - #;Nil])])) - - _ - (#;Left "Wrong syntax for do"))) - -## [Functions] -(def #export (bind m f ma) - (All [m a b] - (-> (Monad m) (-> a (m b)) (m a) (m b))) - (using m - (;;join (:: ;;_functor (F;map f ma))))) - -(def #export (map% m f xs) - (All [m a b] - (-> (Monad m) (-> a (m b)) (List a) (m (List b)))) - (case xs - #;Nil - (:: m (;;wrap #;Nil)) - - (#;Cons [x xs']) - (do m - [y (f x) - ys (map% m f xs')] - (;;wrap (#;Cons [y ys]))) - )) diff --git a/input/lux/control/monoid.lux b/input/lux/control/monoid.lux deleted file mode 100644 index d32baabc5..000000000 --- a/input/lux/control/monoid.lux +++ /dev/null @@ -1,24 +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. - -(;import lux) - -## Signatures -(defsig #export (Monoid a) - (: a - unit) - (: (-> a a a) - ++)) - -## Constructors -(def #export (monoid$ unit ++) - (All [a] - (-> a (-> a a a) (Monoid a))) - (struct - (def unit unit) - (def ++ ++))) diff --git a/input/lux/data/bool.lux b/input/lux/data/bool.lux deleted file mode 100644 index d4f223612..000000000 --- a/input/lux/data/bool.lux +++ /dev/null @@ -1,33 +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. - -(;import lux - (lux/control (monoid #as m)) - (.. (eq #as E) - (show #as S))) - -## [Structures] -(defstruct #export Bool/Eq (E;Eq Bool) - (def (E;= x y) - (if x - y - (not y)))) - -(defstruct #export Bool/Show (S;Show Bool) - (def (S;show x) - (if x "true" "false"))) - -(do-template [ ] - [(defstruct #export (m;Monoid Bool) - (def m;unit ) - (def (m;++ x y) - ( x y)))] - - [ Or/Monoid false or] - [And/Monoid true and] - ) diff --git a/input/lux/data/bounded.lux b/input/lux/data/bounded.lux deleted file mode 100644 index 9d2dabde1..000000000 --- a/input/lux/data/bounded.lux +++ /dev/null @@ -1,17 +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. - -(;import lux) - -## Signatures -(defsig #export (Bounded a) - (: a - top) - - (: a - bottom)) diff --git a/input/lux/data/char.lux b/input/lux/data/char.lux deleted file mode 100644 index 42e57509e..000000000 --- a/input/lux/data/char.lux +++ /dev/null @@ -1,20 +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. - -(;import lux - (.. (eq #as E) - (show #as S))) - -## [Structures] -(defstruct #export Char/Eq (E;Eq Char) - (def (E;= x y) - (_jvm_ceq x y))) - -(defstruct #export Char/Show (S;Show Char) - (def (S;show x) - ($ text:++ "#\"" (_jvm_invokevirtual java.lang.Object toString [] x []) "\""))) diff --git a/input/lux/data/dict.lux b/input/lux/data/dict.lux deleted file mode 100644 index 63a66d49b..000000000 --- a/input/lux/data/dict.lux +++ /dev/null @@ -1,83 +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. - -(;import lux - (lux/data (eq #as E))) - -## Signatures -(defsig #export (Dict d) - (: (All [k v] - (-> k (d k v) (Maybe v))) - get) - (: (All [k v] - (-> k v (d k v) (d k v))) - put) - (: (All [k v] - (-> k (d k v) (d k v))) - remove)) - -## Types -(deftype #export (PList k v) - (| (#PList (, (E;Eq k) (List (, k v)))))) - -## Constructors -(def #export (plist eq) - (All [k v] - (-> (E;Eq k) (PList k v))) - (#PList [eq #;Nil])) - -## Utils -(def (pl-get eq k kvs) - (All [k v] - (-> (E;Eq k) k (List (, k v)) (Maybe v))) - (case kvs - #;Nil - #;None - - (#;Cons [[k' v'] kvs']) - (if (:: eq (E;= k k')) - (#;Some v') - (pl-get eq k kvs')))) - -(def (pl-put eq k v kvs) - (All [k v] - (-> (E;Eq k) k v (List (, k v)) (List (, k v)))) - (case kvs - #;Nil - (#;Cons [[k v] kvs]) - - (#;Cons [[k' v'] kvs']) - (if (:: eq (E;= k k')) - (#;Cons [[k v] kvs']) - (#;Cons [[k' v'] (pl-put eq k v kvs')])))) - -(def (pl-remove eq k kvs) - (All [k v] - (-> (E;Eq k) k (List (, k v)) (List (, k v)))) - (case kvs - #;Nil - kvs - - (#;Cons [[k' v'] kvs']) - (if (:: eq (E;= k k')) - kvs' - (#;Cons [[k' v'] (pl-remove eq k kvs')])))) - -## Structs -(defstruct #export PList/Dict (Dict PList) - (def (get k plist) - (let [(#PList [eq kvs]) plist] - (pl-get eq k kvs))) - - (def (put k v plist) - (let [(#PList [eq kvs]) plist] - (#PList [eq (pl-put eq k v kvs)]))) - - (def (remove k plist) - (let [(#PList [eq kvs]) plist] - (#PList [eq (pl-remove eq k kvs)])))) diff --git a/input/lux/data/either.lux b/input/lux/data/either.lux deleted file mode 100644 index 7166688b5..000000000 --- a/input/lux/data/either.lux +++ /dev/null @@ -1,46 +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. - -(;import lux - (lux/data (list #refer (#except partition)))) - -## [Types] -## (deftype (Either l r) -## (| (#;Left l) -## (#;Right r))) - -## [Functions] -(def #export (either f g e) - (All [a b c] (-> (-> a c) (-> b c) (Either a b) c)) - (case e - (#;Left x) (f x) - (#;Right x) (g x))) - -(do-template [ ] - [(def #export ( es) - (All [a b] (-> (List (Either a b)) (List ))) - (case es - #;Nil #;Nil - (#;Cons [( x) es']) (#;Cons [x ( es')]) - (#;Cons [_ es']) ( es')))] - - [lefts a #;Left] - [rights b #;Right] - ) - -(def #export (partition es) - (All [a b] (-> (List (Either a b)) (, (List a) (List b)))) - (foldL (: (All [a b] - (-> (, (List a) (List b)) (Either a b) (, (List a) (List b)))) - (lambda [tails e] - (let [[ltail rtail] tails] - (case e - (#;Left x) [(#;Cons [x ltail]) rtail] - (#;Right x) [ltail (#;Cons [x rtail])])))) - [(list) (list)] - (reverse es))) diff --git a/input/lux/data/eq.lux b/input/lux/data/eq.lux deleted file mode 100644 index be3400208..000000000 --- a/input/lux/data/eq.lux +++ /dev/null @@ -1,14 +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. - -(;import lux) - -## [Signatures] -(defsig #export (Eq a) - (: (-> a a Bool) - =)) diff --git a/input/lux/data/error.lux b/input/lux/data/error.lux deleted file mode 100644 index cb5c309a6..000000000 --- a/input/lux/data/error.lux +++ /dev/null @@ -1,34 +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. - -(;import lux - (lux/control (functor #as F #refer #all) - (monad #as M #refer #all))) - -## [Types] -(deftype #export (Error a) - (| (#Fail Text) - (#Ok a))) - -## [Structures] -(defstruct #export Error/Functor (Functor Error) - (def (F;map f ma) - (case ma - (#Fail msg) (#Fail msg) - (#Ok datum) (#Ok (f datum))))) - -(defstruct #export Error/Monad (Monad Error) - (def M;_functor Error/Functor) - - (def (M;wrap a) - (#Ok a)) - - (def (M;join mma) - (case mma - (#Fail msg) (#Fail msg) - (#Ok ma) ma))) diff --git a/input/lux/data/id.lux b/input/lux/data/id.lux deleted file mode 100644 index 0e3bdbee6..000000000 --- a/input/lux/data/id.lux +++ /dev/null @@ -1,28 +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. - -(;import lux - (lux/control (functor #as F #refer #all) - (monad #as M #refer #all))) - -## [Types] -(deftype #export (Id a) - (| (#Id a))) - -## [Structures] -(defstruct #export Id/Functor (Functor Id) - (def (F;map f fa) - (let [(#Id a) fa] - (#Id (f a))))) - -(defstruct #export Id/Monad (Monad Id) - (def M;_functor Id/Functor) - (def (M;wrap a) (#Id a)) - (def (M;join mma) - (let [(#Id ma) mma] - ma))) diff --git a/input/lux/data/io.lux b/input/lux/data/io.lux deleted file mode 100644 index c08023df5..000000000 --- a/input/lux/data/io.lux +++ /dev/null @@ -1,51 +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. - -(;import lux - (lux/meta macro) - (lux/control (functor #as F) - (monad #as M)) - lux/data/list) - -## Types -(deftype #export (IO a) - (-> (,) a)) - -## Syntax -(defmacro #export (io tokens state) - (case tokens - (\ (list value)) - (let [blank (symbol$ ["" ""])] - (#;Right [state (list (` (_lux_lambda (~ blank) (~ blank) (~ value))))])) - - _ - (#;Left "Wrong syntax for io"))) - -## Structures -(defstruct #export IO/Functor (F;Functor IO) - (def (F;map f ma) - (io (f (ma []))))) - -(defstruct #export IO/Monad (M;Monad IO) - (def M;_functor IO/Functor) - - (def (M;wrap x) - (io x)) - - (def (M;join mma) - (mma []))) - -## Functions -(def #export (print x) - (-> Text (IO (,))) - (io (_jvm_invokevirtual java.io.PrintStream print [java.lang.Object] - (_jvm_getstatic java.lang.System out) [x]))) - -(def #export (println x) - (-> Text (IO (,))) - (print (text:++ x "\n"))) diff --git a/input/lux/data/list.lux b/input/lux/data/list.lux deleted file mode 100644 index 450dee275..000000000 --- a/input/lux/data/list.lux +++ /dev/null @@ -1,250 +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. - -(;import lux - (lux/control (monoid #as m #refer #all) - (functor #as F #refer #all) - (monad #as M #refer #all)) - lux/meta/macro) - -## Types -## (deftype (List a) -## (| #Nil -## (#Cons (, a (List a))))) - -## Functions -(def #export (foldL f init xs) - (All [a b] - (-> (-> a b a) a (List b) a)) - (case xs - #;Nil - init - - (#;Cons [x xs']) - (foldL f (f init x) xs'))) - -(def #export (foldR f init xs) - (All [a b] - (-> (-> b a a) a (List b) a)) - (case xs - #;Nil - init - - (#;Cons [x xs']) - (f x (foldR f init xs')))) - -(def #export (reverse xs) - (All [a] - (-> (List a) (List a))) - (foldL (lambda [tail head] (#;Cons [head tail])) - #;Nil - xs)) - -(def #export (filter p xs) - (All [a] - (-> (-> a Bool) (List a) (List a))) - (case xs - #;Nil - #;Nil - - (#;Cons [x xs']) - (if (p x) - (#;Cons [x (filter p xs')]) - (filter p xs')))) - -(def #export (partition p xs) - (All [a] (-> (-> a Bool) (List a) (, (List a) (List a)))) - [(filter p xs) (filter (complement p) xs)]) - -(def #export (as-pairs xs) - (All [a] (-> (List a) (List (, a a)))) - (case xs - (\ (#;Cons [x1 (#;Cons [x2 xs'])])) - (#;Cons [[x1 x2] (as-pairs xs')]) - - _ - #;Nil)) - -(do-template [ ] - [(def #export ( n xs) - (All [a] - (-> Int (List a) (List a))) - (if (i> n 0) - (case xs - #;Nil - #;Nil - - (#;Cons [x xs']) - ) - ))] - - [take (#;Cons [x (take (dec n) xs')]) #;Nil] - [drop (drop (dec n) xs') xs] - ) - -(do-template [ ] - [(def #export ( p xs) - (All [a] - (-> (-> a Bool) (List a) (List a))) - (case xs - #;Nil - #;Nil - - (#;Cons [x xs']) - (if (p x) - - )))] - - [take-while (#;Cons [x (take-while p xs')]) #;Nil] - [drop-while (drop-while p xs') xs] - ) - -(def #export (split n xs) - (All [a] - (-> Int (List a) (, (List a) (List a)))) - (if (i> n 0) - (case xs - #;Nil - [#;Nil #;Nil] - - (#;Cons [x xs']) - (let [[tail rest] (split (dec n) xs')] - [(#;Cons [x tail]) rest])) - [#;Nil 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 (#;Cons [x ys]) xs') - [ys xs]))) - -(def #export (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 #export (repeat n x) - (All [a] - (-> Int a (List a))) - (if (i> n 0) - (#;Cons [x (repeat (dec n) x)]) - #;Nil)) - -(def #export (iterate f x) - (All [a] - (-> (-> a (Maybe a)) a (List a))) - (case (f x) - (#;Some x') - (#;Cons [x (iterate f x')]) - - #;None - (#;Cons [x #;Nil]))) - -(def #export (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 #export (interpose sep xs) - (All [a] - (-> a (List a) (List a))) - (case xs - #;Nil - xs - - (#;Cons [x #;Nil]) - xs - - (#;Cons [x xs']) - (#;Cons [x (#;Cons [sep (interpose sep xs')])]))) - -(def #export (size list) - (-> List Int) - (foldL (lambda [acc _] (i+ 1 acc)) 0 list)) - -(do-template [ ] - [(def #export ( p xs) - (All [a] - (-> (-> a Bool) (List a) Bool)) - (foldL (lambda [_1 _2] ( _1 (p _2))) xs))] - - [every? true and] - [any? false or]) - -(def #export (@ i xs) - (All [a] - (-> Int (List a) (Maybe a))) - (case xs - #;Nil - #;None - - (#;Cons [x xs']) - (if (i= 0 i) - (#;Some x) - (@ (dec i) xs')))) - -## Syntax -(defmacro #export (list xs state) - (#;Right [state (#;Cons [(foldL (lambda [tail head] - (` (#;Cons [(~ head) (~ tail)]))) - (` #;Nil) - (reverse xs)) - #;Nil])])) - -(defmacro #export (list& xs state) - (case (reverse xs) - (#;Cons [last init]) - (#;Right [state (list (foldL (lambda [tail head] - (` (#;Cons [(~ head) (~ tail)]))) - last - init))]) - - _ - (#;Left "Wrong syntax for list&"))) - -## Structures -(defstruct #export List/Monoid (All [a] - (Monoid (List a))) - (def m;unit #;Nil) - (def (m;++ xs ys) - (case xs - #;Nil ys - (#;Cons [x xs']) (#;Cons [x (m;++ xs' ys)])))) - -(defstruct #export List/Functor (Functor List) - (def (F;map f ma) - (case ma - #;Nil #;Nil - (#;Cons [a ma']) (#;Cons [(f a) (F;map f ma')])))) - -(defstruct #export List/Monad (Monad List) - (def M;_functor List/Functor) - - (def (M;wrap a) - (#;Cons [a #;Nil])) - - (def (M;join mma) - (using List/Monoid - (foldL m;++ m;unit mma)))) diff --git a/input/lux/data/maybe.lux b/input/lux/data/maybe.lux deleted file mode 100644 index faec53c2e..000000000 --- a/input/lux/data/maybe.lux +++ /dev/null @@ -1,42 +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. - -(;import lux - (lux/control (monoid #as m #refer #all) - (functor #as F #refer #all) - (monad #as M #refer #all))) - -## [Types] -## (deftype (Maybe a) -## (| #;None -## (#;Some a))) - -## [Structures] -(defstruct #export Maybe/Monoid (Monoid Maybe) - (def m;unit #;None) - (def (m;++ xs ys) - (case xs - #;None ys - (#;Some x) (#;Some x)))) - -(defstruct #export Maybe/Functor (Functor Maybe) - (def (F;map f ma) - (case ma - #;None #;None - (#;Some a) (#;Some (f a))))) - -(defstruct #export Maybe/Monad (Monad Maybe) - (def M;_functor Maybe/Functor) - - (def (M;wrap x) - (#;Some x)) - - (def (M;join mma) - (case mma - #;None #;None - (#;Some xs) xs))) diff --git a/input/lux/data/number.lux b/input/lux/data/number.lux deleted file mode 100644 index 8da674d88..000000000 --- a/input/lux/data/number.lux +++ /dev/null @@ -1,119 +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. - -(;import lux - (lux/control (monoid #as m)) - (lux/data (eq #as E) - (ord #as O) - (bounded #as B) - (show #as S))) - -## Signatures -(defsig #export (Number n) - (do-template [] - [(: (-> n n n) )] - [+] [-] [*] [/] [%]) - - (: (-> Int n) - from-int) - - (do-template [] - [(: (-> n n) )] - [negate] [signum] [abs]) - ) - -## [Structures] -## Number -(do-template [ <+> <-> <*> <%> <=> <<> <0> <1> <-1>] - [(defstruct #export (Number ) - (def + <+>) - (def - <->) - (def * <*>) - (def / ) - (def % <%>) - (def (from-int x) - ( x)) - (def (negate x) - (<*> <-1> x)) - (def (abs x) - (if (<<> x <0>) - (<*> <-1> x) - x)) - (def (signum x) - (cond (<=> x <0>) <0> - (<<> x <0>) <-1> - ## else - <1>)) - )] - - [ Int/Number Int i+ i- i* i/ i% i= i< id 0 1 -1] - [Real/Number Real r+ r- r* r/ r% r= r< _jvm_l2d 0.0 1.0 -1.0]) - -## Eq -(defstruct #export Int/Eq (E;Eq Int) - (def E;= i=)) - -(defstruct #export Real/Eq (E;Eq Real) - (def E;= r=)) - -## Ord -## (def #export Int/Ord (O;Ord Int) -## (O;ord$ Int/Eq i< i>)) - -## (def #export Real/Ord (O;Ord Real) -## (O;ord$ Real/Eq r< r>)) - -(do-template [ ] - [(defstruct #export (O;Ord ) - (def O;_eq ) - (def O;< ) - (def (O;<= x y) - (or ( x y) - (using (E;= x y)))) - (def O;> ) - (def (O;>= x y) - (or ( x y) - (using (E;= x y)))))] - - [ Int/Ord Int Int/Eq i< i>] - [Real/Ord Real Real/Eq r< r>]) - -## Bounded -(do-template [ ] - [(defstruct #export (B;Bounded ) - (def B;top ) - (def B;bottom ))] - - [ Int/Bounded Int (_jvm_getstatic java.lang.Long MAX_VALUE) (_jvm_getstatic java.lang.Long MIN_VALUE)] - [Real/Bounded Real (_jvm_getstatic java.lang.Double MAX_VALUE) (_jvm_getstatic java.lang.Double MIN_VALUE)]) - -## Monoid -(do-template [ <++>] - [(defstruct #export (m;Monoid ) - (def m;unit ) - (def m;++ <++>))] - - [ IntAdd/Monoid Int 0 i+] - [ IntMul/Monoid Int 1 i*] - [RealAdd/Monoid Real 0.0 r+] - [RealMul/Monoid Real 1.0 r*] - [ IntMax/Monoid Int (:: Int/Bounded B;bottom) (O;max Int/Ord)] - [ IntMin/Monoid Int (:: Int/Bounded B;top) (O;min Int/Ord)] - [RealMax/Monoid Real (:: Real/Bounded B;bottom) (O;max Real/Ord)] - [RealMin/Monoid Real (:: Real/Bounded B;top) (O;min Real/Ord)] - ) - -## Show -(do-template [ ] - [(defstruct #export (S;Show ) - (def (S;show x) - ))] - - [ Int/Show Int (_jvm_invokevirtual java.lang.Object toString [] x [])] - [Real/Show Real (_jvm_invokevirtual java.lang.Object toString [] x [])] - ) diff --git a/input/lux/data/ord.lux b/input/lux/data/ord.lux deleted file mode 100644 index 80f2e4fb5..000000000 --- a/input/lux/data/ord.lux +++ /dev/null @@ -1,44 +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. - -(;import lux - (../eq #as E)) - -## [Signatures] -(defsig #export (Ord a) - (: (E;Eq a) - _eq) - (do-template [] - [(: (-> a a Bool) )] - - [<] [<=] [>] [>=])) - -## [Constructors] -(def #export (ord$ eq < >) - (All [a] - (-> (E;Eq a) (-> a a Bool) (-> a a Bool) (Ord a))) - (struct - (def _eq eq) - (def < <) - (def (<= x y) - (or (< x y) - (:: eq (E;= x y)))) - (def > >) - (def (>= x y) - (or (> x y) - (:: eq (E;= x y)))))) - -## [Functions] -(do-template [ ] - [(def #export ( ord x y) - (All [a] - (-> (Ord a) a a a)) - (if (:: ord ( x y)) x y))] - - [max ;;>] - [min ;;<]) diff --git a/input/lux/data/reader.lux b/input/lux/data/reader.lux deleted file mode 100644 index c3bbc2830..000000000 --- a/input/lux/data/reader.lux +++ /dev/null @@ -1,33 +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. - -(;import (lux #refer (#except Reader)) - (lux/control (functor #as F #refer #all) - (monad #as M #refer #all))) - -## [Types] -(deftype #export (Reader r a) - (-> r a)) - -## [Structures] -(defstruct #export Reader/Functor (All [r] - (Functor (Reader r))) - (def (F;map f fa) - (lambda [env] - (f (fa env))))) - -(defstruct #export Reader/Monad (All [r] - (Monad (Reader r))) - (def M;_functor Reader/Functor) - - (def (M;wrap x) - (lambda [env] x)) - - (def (M;join mma) - (lambda [env] - (mma env env)))) diff --git a/input/lux/data/show.lux b/input/lux/data/show.lux deleted file mode 100644 index f4e1cf762..000000000 --- a/input/lux/data/show.lux +++ /dev/null @@ -1,14 +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. - -(;import lux) - -## Signatures -(defsig #export (Show a) - (: (-> a Text) - show)) diff --git a/input/lux/data/state.lux b/input/lux/data/state.lux deleted file mode 100644 index bc9858a29..000000000 --- a/input/lux/data/state.lux +++ /dev/null @@ -1,35 +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. - -(;import lux - (lux/control (functor #as F #refer #all) - (monad #as M #refer #all))) - -## [Types] -(deftype #export (State s a) - (-> s (, s a))) - -## [Structures] -(defstruct #export State/Functor (Functor State) - (def (F;map f ma) - (lambda [state] - (let [[state' a] (ma state)] - [state' (f a)])))) - -(defstruct #export State/Monad (All [s] - (Monad (State s))) - (def M;_functor State/Functor) - - (def (M;wrap x) - (lambda [state] - [state x])) - - (def (M;join mma) - (lambda [state] - (let [[state' ma] (mma state)] - (ma state'))))) diff --git a/input/lux/data/text.lux b/input/lux/data/text.lux deleted file mode 100644 index a3192a1d5..000000000 --- a/input/lux/data/text.lux +++ /dev/null @@ -1,146 +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. - -(;import lux - (lux/control (monoid #as m)) - (lux/data (eq #as E) - (ord #as O) - (show #as S))) - -## [Functions] -(def #export (size x) - (-> Text Int) - (_jvm_i2l (_jvm_invokevirtual java.lang.String length [] - x []))) - -(def #export (@ idx x) - (-> Int Text (Maybe Char)) - (if (and (i< idx (size x)) - (i>= idx 0)) - (#;Some (_jvm_invokevirtual java.lang.String charAt [int] - x [(_jvm_l2i idx)])) - #;None)) - -(def #export (contains? x y) - (-> Text Text Bool) - (_jvm_invokevirtual java.lang.String contains [java.lang.CharSequence] - x [y])) - -(do-template [ ] - [(def #export ( x) - (-> Text Text) - (_jvm_invokevirtual java.lang.String [] - x []))] - [lower-case toLowerCase] - [upper-case toUpperCase] - [trim trim] - ) - -(def #export (sub' from to x) - (-> Int Int Text (Maybe Text)) - (if (and (i< from to) - (i>= from 0) - (i<= to (size x))) - (_jvm_invokevirtual java.lang.String substring [int int] - x [(_jvm_l2i from) (_jvm_l2i to)]) - #;None)) - -(def #export (sub from x) - (-> Int Text (Maybe Text)) - (sub' from (size x) x)) - -(def #export (split at x) - (-> Int Text (Maybe (, Text Text))) - (if (and (i< at (size x)) - (i>= at 0)) - (let [pre (_jvm_invokevirtual java.lang.String substring [int int] - x [(_jvm_l2i 0) (_jvm_l2i at)]) - post (_jvm_invokevirtual java.lang.String substring [int] - x [(_jvm_l2i at)])] - (#;Some [pre post])) - #;None)) - -(def #export (replace pattern value template) - (-> Text Text Text Text) - (_jvm_invokevirtual java.lang.String replace [java.lang.CharSequence java.lang.CharSequence] - template [pattern value])) - -(do-template [ ] - [(def #export ( pattern from x) - (-> Text Int Text (Maybe Int)) - (if (and (i< from (size x)) (i>= from 0)) - (case (_jvm_i2l (_jvm_invokevirtual java.lang.String [java.lang.String int] - x [pattern (_jvm_l2i from)])) - -1 #;None - idx (#;Some idx)) - #;None)) - - (def #export ( pattern x) - (-> Text Text (Maybe Int)) - (case (_jvm_i2l (_jvm_invokevirtual java.lang.String [java.lang.String] - x [pattern])) - -1 #;None - idx (#;Some idx)))] - - [index-of index-of' indexOf] - [last-index-of last-index-of' lastIndexOf] - ) - -(def #export (starts-with? prefix x) - (-> Text Text Bool) - (case (index-of prefix x) - (#;Some 0) - true - - _ - false)) - -(def #export (ends-with? postfix x) - (-> Text Text Bool) - (case (last-index-of postfix x) - (#;Some n) - (i= (i+ n (size postfix)) - (size x)) - - _ - false)) - -## [Structures] -(defstruct #export Text/Eq (E;Eq Text) - (def (E;= x y) - (_jvm_invokevirtual java.lang.Object equals [java.lang.Object] - x [y]))) - -(defstruct #export Text/Ord (O;Ord Text) - (def O;_eq Text/Eq) - (def (O;< x y) - (i< (_jvm_i2l (_jvm_invokevirtual java.lang.String compareTo [java.lang.String] - x [y])) - 0)) - (def (O;<= x y) - (i<= (_jvm_i2l (_jvm_invokevirtual java.lang.String compareTo [java.lang.String] - x [y])) - 0)) - (def (O;> x y) - (i> (_jvm_i2l (_jvm_invokevirtual java.lang.String compareTo [java.lang.String] - x [y])) - 0)) - (def (O;>= x y) - (i>= (_jvm_i2l (_jvm_invokevirtual java.lang.String compareTo [java.lang.String] - x [y])) - 0))) - -(defstruct #export Text/Show (S;Show Text) - (def (S;show x) - x)) - -(defstruct #export Text/Monoid (m;Monoid Text) - (def m;unit "") - (def (m;++ x y) - (_jvm_invokevirtual java.lang.String concat [java.lang.String] - x [y]))) diff --git a/input/lux/data/writer.lux b/input/lux/data/writer.lux deleted file mode 100644 index f71492e35..000000000 --- a/input/lux/data/writer.lux +++ /dev/null @@ -1,34 +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. - -(;import lux - (lux/control (monoid #as m #refer #all) - (functor #as F #refer #all) - (monad #as M #refer #all))) - -## [Types] -(deftype #export (Writer l a) - (, l a)) - -## [Structures] -(defstruct #export Writer/Functor (All [l] - (Functor (Writer l))) - (def (F;map f fa) - (let [[log datum] fa] - [log (f datum)]))) - -(defstruct #export (Writer/Monad mon) (All [l] - (-> (Monoid l) (Monad (Writer l)))) - (def M;_functor Writer/Functor) - - (def (M;wrap x) - [(:: mon m;unit) x]) - - (def (M;join mma) - (let [[log1 [log2 a]] mma] - [(:: mon (m;++ log1 log2)) a]))) diff --git a/input/lux/host/java.lux b/input/lux/host/java.lux deleted file mode 100644 index 12525d3f2..000000000 --- a/input/lux/host/java.lux +++ /dev/null @@ -1,312 +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. - -(;import lux - (lux (control (monoid #as m) - (functor #as F) - (monad #as M #refer (#only do))) - (data list - (text #as text)) - (meta lux - macro - syntax))) - -## (open List/Functor) - -## [Utils/Parsers] -(def finally^ - (Parser Syntax) - (form^ (do Parser/Monad - [_ (symbol?^ ["" "finally"]) - expr id^ - _ end^] - (M;wrap expr)))) - -(def catch^ - (Parser (, Text Ident Syntax)) - (form^ (do Parser/Monad - [_ (symbol?^ ["" "catch"]) - ex-class local-symbol^ - ex symbol^ - expr id^ - _ end^] - (M;wrap [ex-class ex expr])))) - -(def method-decl^ - (Parser (, (List Text) Text (List Text) Text)) - (form^ (do Parser/Monad - [modifiers (*^ local-tag^) - name local-symbol^ - inputs (tuple^ (*^ local-symbol^)) - output local-symbol^ - _ end^] - (M;wrap [modifiers name inputs output])))) - -(def field-decl^ - (Parser (, (List Text) Text Text)) - (form^ (do Parser/Monad - [modifiers (*^ local-tag^) - name local-symbol^ - class local-symbol^ - _ end^] - (M;wrap [modifiers name class])))) - -(def arg-decl^ - (Parser (, Text Text)) - (form^ (do Parser/Monad - [arg-name local-symbol^ - arg-class local-symbol^ - _ end^] - (M;wrap [arg-name arg-class])))) - -(def method-def^ - (Parser (, (List Text) Text (List (, Text Text)) Text Syntax)) - (form^ (do Parser/Monad - [modifiers (*^ local-tag^) - name local-symbol^ - inputs (tuple^ (*^ arg-decl^)) - output local-symbol^ - body id^ - _ end^] - (M;wrap [modifiers name inputs output body])))) - -(def method-call^ - (Parser (, Text (List Text) (List Syntax))) - (form^ (do Parser/Monad - [method local-symbol^ - arity-classes (tuple^ (*^ local-symbol^)) - arity-args (tuple^ (*^ id^)) - _ end^ - _ (: (Parser (,)) - (if (i= (size arity-classes) - (size arity-args)) - (M;wrap []) - (lambda [_] #;None)))] - (M;wrap [method arity-classes arity-args]) - ))) - -## [Utils/Lux] -## (def (find-class-field field class) -## (-> Text Text (Lux Type)) -## ...) - -## (def (find-virtual-method method class) -## (-> Text Text (Lux (List (, (List Type) Type)))) -## ...) - -## (def (find-static-method method class) -## (-> Text Text (Lux (List (, (List Type) Type)))) -## ...) - - -## [Syntax] -(defsyntax #export (throw ex) - (emit (list (` (_jvm_throw (~ ex)))))) - -(defsyntax #export (try body [catches (*^ catch^)] [finally (?^ finally^)]) - (emit (list (` (_jvm_try (~ body) - (~@ (list:++ (:: List/Functor (F;map (: (-> (, Text Ident Syntax) Syntax) - (lambda [catch] - (let [[class ex body] catch] - (` (_jvm_catch (~ (text$ class)) (~ (symbol$ ex)) (~ body)))))) - catches)) - (case finally - #;None - (list) - - (#;Some finally) - (list (` (_jvm_finally (~ finally)))))))))))) - -(defsyntax #export (definterface [name local-symbol^] [supers (tuple^ (*^ local-symbol^))] [members (*^ method-decl^)]) - (do Lux/Monad - [current-module get-module-name - #let [full-name (:: text;Text/Monoid (m;++ (text;replace "/" "." current-module) - name))]] - (let [members' (:: List/Functor (F;map (: (-> (, (List Text) Text (List Text) Text) Syntax) - (lambda [member] - (let [[modifiers name inputs output] member] - (` ((~ (symbol$ ["" name])) [(~@ (:: List/Functor (F;map text$ inputs)))] (~ (text$ output)) [(~@ (:: List/Functor (F;map text$ modifiers)))]))))) - members))] - (emit (list (` (_jvm_interface (~ (text$ full-name)) [(~@ (:: List/Functor (F;map text$ supers)))] - (~@ members')))))))) - -(defsyntax #export (defclass [name local-symbol^] [super local-symbol^] [interfaces (tuple^ (*^ local-symbol^))] - [fields (*^ field-decl^)] - [methods (*^ method-def^)]) - (do Lux/Monad - [current-module get-module-name - #let [full-name (:: text;Text/Monoid (m;++ (text;replace "/" "." current-module) - name)) - fields' (:: List/Functor (F;map (: (-> (, (List Text) Text Text) Syntax) - (lambda [field] - (let [[modifiers name class] field] - (` ((~ (symbol$ ["" name])) - (~ (text$ class)) - [(~@ (:: List/Functor (F;map text$ modifiers)))]))))) - fields)) - methods' (:: List/Functor (F;map (: (-> (, (List Text) Text (List (, Text Text)) Text Syntax) Syntax) - (lambda [methods] - (let [[modifiers name inputs output body] methods] - (` ((~ (symbol$ ["" name])) - [(~@ (:: List/Functor (F;map (: (-> (, Text Text) Syntax) - (lambda [in] - (let [[left right] in] - (form$ (list (text$ left) - (text$ right)))))) - inputs)))] - (~ (text$ output)) - [(~@ (:: List/Functor (F;map text$ modifiers)))] - (~ body)))))) - methods))]] - (emit (list (` (_jvm_class (~ (text$ full-name)) (~ (text$ super)) - [(~@ (:: List/Functor (F;map text$ interfaces)))] - [(~@ fields')] - [(~@ methods')])))))) - -(defsyntax #export (new [class local-symbol^] [arg-classes (tuple^ (*^ local-symbol^))] [args (tuple^ (*^ id^))]) - (emit (list (` (_jvm_new (~ (text$ class)) - [(~@ (:: List/Functor (F;map text$ arg-classes)))] - [(~@ args)]))))) - -(defsyntax #export (instance? [class local-symbol^] obj) - (emit (list (` (_jvm_instanceof (~ (text$ class)) (~ obj)))))) - -(defsyntax #export (locking lock body) - (do Lux/Monad - [g!lock (gensym "") - g!body (gensym "")] - (emit (list (` (;let [(~ g!lock) (~ lock) - _ (_jvm_monitor-enter (~ g!lock)) - (~ g!body) (~ body) - _ (_jvm_monitor-exit (~ g!lock))] - (~ g!body))))) - )) - -(defsyntax #export (null? obj) - (emit (list (` (_jvm_null? (~ obj)))))) - -(defsyntax #export (program [args symbol^] body) - (emit (list (` (_jvm_program (~ (symbol$ args)) - (~ body)))))) - -## (defsyntax #export (.? [field local-symbol^] obj) -## (case obj -## (#;Meta [_ (#;SymbolS obj-name)]) -## (do Lux/Monad -## [obj-type (find-var-type obj-name)] -## (case obj-type -## (#;DataT class) -## (do Lux/Monad -## [field-class (find-field field class)] -## (_jvm_getfield (~ (text$ class)) (~ (text$ field)) (~ (text$ field-class)))) - -## _ -## (fail "Can only get field from object."))) - -## _ -## (do Lux/Monad -## [g!obj (gensym "")] -## (emit (list (` (;let [(~ g!obj) (~ obj)] -## (.? (~ field) (~ g!obj))))))))) - -## (defsyntax #export (.= [field local-symbol^] value obj) -## (case obj -## (#;Meta [_ (#;SymbolS obj-name)]) -## (do Lux/Monad -## [obj-type (find-var-type obj-name)] -## (case obj-type -## (#;DataT class) -## (do Lux/Monad -## [field-class (find-field field class)] -## (_jvm_putfield (~ (text$ class)) (~ (text$ field)) (~ (text$ field-class)) (~ value))) - -## _ -## (fail "Can only set field of object."))) - -## _ -## (do Lux/Monad -## [g!obj (gensym "")] -## (emit (list (` (;let [(~ g!obj) (~ obj)] -## (.= (~ field) (~ value) (~ g!obj))))))))) - -## (defsyntax #export (.! [call method-call^] obj) -## (case obj -## (#;Meta [_ (#;SymbolS obj-name)]) -## (do Lux/Monad -## [obj-type (find-var-type obj-name)] -## (case obj-type -## (#;DataT class) -## (do Lux/Monad -## [#let [[m-name ?m-classes m-args] call] -## all-m-details (find-virtual-method m-name class) -## m-ins (case [?m-classes all-m-details] -## (\ [#;None (list [m-ins m-out])]) -## (M;wrap m-ins) - -## (\ [(#;Some m-ins) _]) -## (M;wrap m-ins) - -## _ -## #;None)] -## (emit (list (` (_jvm_invokevirtual (~ (text$ m-name)) (~ (text$ class)) [(~@ (:: List/Functor (F;map text$ m-ins)))] -## (~ obj) [(~@ m-args)]))))) - -## _ -## (fail "Can only call method on object."))) - -## _ -## (do Lux/Monad -## [g!obj (gensym "")] -## (emit (list (` (;let [(~ g!obj) (~ obj)] -## (.! (~@ *tokens*))))))))) - -## (defsyntax #export (..? [field local-symbol^] [class local-symbol^]) -## (emit (list (` (_jvm_getstatic (~ (text$ class)) (~ (text$ field))))))) - -## (defsyntax #export (..= [field local-symbol^] value [class local-symbol^]) -## (emit (list (` (_jvm_putstatic (~ (text$ class)) (~ (text$ field)) (~ value)))))) - -## (defsyntax #export (..! [call method-call^] [class local-symbol^]) -## (do Lux/Monad -## [#let [[m-name ?m-classes m-args] call] -## all-m-details (find-static-method m-name class) -## m-ins (case [?m-classes all-m-details] -## (\ [#;None (list [m-ins m-out])]) -## (M;wrap m-ins) - -## (\ [(#;Some m-ins) _]) -## (M;wrap m-ins) - -## _ -## #;None)] -## (emit (list (` (_jvm_invokestatic (~ (text$ m-name)) (~ (text$ class)) -## [(~@ (:: List/Functor (F;map text$ m-ins)))] -## [(~@ m-args)])))) -## )) - -## (definterface Function [] -## (#public #abstract apply [java.lang.Object] java.lang.Object)) - -## (_jvm_interface "Function" [] -## (apply ["java.lang.Object"] "java.lang.Object" ["public" "abstract"])) - -## (defclass MyFunction [Function] -## (#public #static foo java.lang.Object) -## (#public [] void -## (_jvm_invokespecial java.lang.Object [] this [])) -## (#public apply [(arg java.lang.Object)] java.lang.Object -## "YOLO")) - -## (_jvm_class "lux.MyFunction" "java.lang.Object" ["lux.Function"] -## [(foo "java.lang.Object" ["public" "static"])] -## ( [] "void" -## ["public"] -## (_jvm_invokespecial java.lang.Object [] this [])) -## (apply [(arg "java.lang.Object")] "java.lang.Object" -## ["public"] -## "YOLO")) diff --git a/input/lux/math.lux b/input/lux/math.lux deleted file mode 100644 index 2e29c5da7..000000000 --- a/input/lux/math.lux +++ /dev/null @@ -1,60 +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. - -(;import lux) - -## [Constants] -(do-template [ ] - [(def #export - Real - (_jvm_getstatic java.lang.Math ))] - - [e E] - [pi PI] - ) - -## [Functions] -(do-template [ ] - [(def #export ( n) - (-> Real Real) - (_jvm_invokestatic java.lang.Math [double] [n]))] - - [cos cos] - [sin sin] - [tan tan] - - [acos acos] - [asin asin] - [atan atan] - - [cosh cosh] - [sinh sinh] - [tanh tanh] - - [ceil ceil] - [floor floor] - [round round] - - [exp exp] - [log log] - - [cbrt cbrt] - [sqrt sqrt] - - [->degrees toDegrees] - [->radians toRadians] - ) - -(do-template [ ] - [(def #export ( x y) - (-> Real Real Real) - (_jvm_invokestatic java.lang.Math [double double] [x y]))] - - [atan2 atan2] - [pow pow] - ) diff --git a/input/lux/meta/lux.lux b/input/lux/meta/lux.lux deleted file mode 100644 index a28d6e5d4..000000000 --- a/input/lux/meta/lux.lux +++ /dev/null @@ -1,287 +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. - -(;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)))))))) - )) diff --git a/input/lux/meta/macro.lux b/input/lux/meta/macro.lux deleted file mode 100644 index 22aeaf874..000000000 --- a/input/lux/meta/macro.lux +++ /dev/null @@ -1,54 +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. - -(;import lux) - -## [Utils] -(def (_meta x) - (-> (Syntax' (Meta Cursor)) Syntax) - (#;Meta [["" -1 -1] x])) - -## [Syntax] -(def #export (defmacro tokens state) - Macro - (case tokens - (#;Cons [(#;Meta [_ (#;FormS (#;Cons [name args]))]) (#;Cons [body #;Nil])]) - (#;Right [state (#;Cons [(` ((~ (_meta (#;SymbolS ["lux" "def"]))) ((~ name) (~@ args)) - (~ (_meta (#;SymbolS ["lux" "Macro"]))) - (~ body))) - (#;Cons [(` ((~ (_meta (#;SymbolS ["" "_lux_declare-macro"]))) (~ name))) - #;Nil])])]) - - (#;Cons [(#;Meta [_ (#;TagS ["" "export"])]) (#;Cons [(#;Meta [_ (#;FormS (#;Cons [name args]))]) (#;Cons [body #;Nil])])]) - (#;Right [state (#;Cons [(` ((~ (_meta (#;SymbolS ["lux" "def"]))) (~ (_meta (#;TagS ["" "export"]))) ((~ name) (~@ args)) - (~ (_meta (#;SymbolS ["lux" "Macro"]))) - (~ body))) - (#;Cons [(` ((~ (_meta (#;SymbolS ["" "_lux_declare-macro"]))) (~ name))) - #;Nil])])]) - - _ - (#;Left "Wrong syntax for defmacro"))) -(_lux_declare-macro defmacro) - -## [Functions] -(do-template [ ] - [(def #export ( x) - (-> Syntax) - (#;Meta [["" -1 -1] ( x)]))] - - [bool$ Bool #;BoolS] - [int$ Int #;IntS] - [real$ Real #;RealS] - [char$ Char #;CharS] - [text$ Text #;TextS] - [symbol$ Ident #;SymbolS] - [tag$ Ident #;TagS] - [form$ (List Syntax) #;FormS] - [tuple$ (List Syntax) #;TupleS] - [record$ (List (, Syntax Syntax)) #;RecordS] - ) diff --git a/input/lux/meta/syntax.lux b/input/lux/meta/syntax.lux deleted file mode 100644 index 1fe85c32f..000000000 --- a/input/lux/meta/syntax.lux +++ /dev/null @@ -1,262 +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. - -(;import lux - (.. (macro #as m #refer #all) - (lux #as l #refer (#only Lux/Monad gensym))) - (lux (control (functor #as F) - (monad #as M #refer (#only do))) - (data (eq #as E) - (bool #as b) - (char #as c) - (text #as t) - list))) - -## [Utils] -(def (first xy) - (All [a b] (-> (, a b) a)) - (let [[x y] xy] - x)) - -(def (join-pairs pairs) - (All [a] (-> (List (, a a)) (List a))) - (case pairs - #;Nil #;Nil - (#;Cons [[x y] pairs']) (list& x y (join-pairs pairs')))) - -## Types -(deftype #export (Parser a) - (-> (List Syntax) (Maybe (, (List Syntax) a)))) - -## Structures -(defstruct #export Parser/Functor (F;Functor Parser) - (def (F;map f ma) - (lambda [tokens] - (case (ma tokens) - #;None - #;None - - (#;Some [tokens' a]) - (#;Some [tokens' (f a)]))))) - -(defstruct #export Parser/Monad (M;Monad Parser) - (def M;_functor Parser/Functor) - - (def (M;wrap x tokens) - (#;Some [tokens x])) - - (def (M;join mma) - (lambda [tokens] - (case (mma tokens) - #;None - #;None - - (#;Some [tokens' ma]) - (ma tokens'))))) - -## Parsers -(def #export (id^ tokens) - (Parser Syntax) - (case tokens - #;Nil #;None - (#;Cons [t tokens']) (#;Some [tokens' t]))) - -(do-template [ ] - [(def #export ( tokens) - (Parser ) - (case tokens - (#;Cons [(#;Meta [_ ( x)]) tokens']) - (#;Some [tokens' x]) - - _ - #;None))] - - [ bool^ Bool #;BoolS] - [ int^ Int #;IntS] - [ real^ Real #;RealS] - [ char^ Char #;CharS] - [ text^ Text #;TextS] - [symbol^ Ident #;SymbolS] - [ tag^ Ident #;TagS] - ) - -(do-template [ ] - [(def #export ( tokens) - (Parser Text) - (case tokens - (#;Cons [(#;Meta [_ ( ["" x])]) tokens']) - (#;Some [tokens' x]) - - _ - #;None))] - - [local-symbol^ #;SymbolS] - [ local-tag^ #;TagS] - ) - -(def (ident:= x y) - (-> Ident Ident Bool) - (let [[x1 x2] x - [y1 y2] y] - (and (text:= x1 y1) - (text:= x2 y2)))) - -(do-template [ ] - [(def #export ( v tokens) - (-> (Parser (,))) - (case tokens - (#;Cons [(#;Meta [_ ( x)]) tokens']) - (if ( v x) - (#;Some [tokens' []]) - #;None) - - _ - #;None))] - - [ bool?^ Bool #;BoolS (:: b;Bool/Eq E;=)] - [ int?^ Int #;IntS i=] - [ real?^ Real #;RealS r=] - [ char?^ Char #;CharS (:: c;Char/Eq E;=)] - [ text?^ Text #;TextS (:: t;Text/Eq E;=)] - [symbol?^ Ident #;SymbolS ident:=] - [ tag?^ Ident #;TagS ident:=] - ) - -(do-template [ ] - [(def #export ( p tokens) - (All [a] - (-> (Parser a) (Parser a))) - (case tokens - (#;Cons [(#;Meta [_ ( form)]) tokens']) - (case (p form) - (#;Some [#;Nil x]) (#;Some [tokens' x]) - _ #;None) - - _ - #;None))] - - [ form^ #;FormS] - [tuple^ #;TupleS] - ) - -(def #export (?^ p tokens) - (All [a] - (-> (Parser a) (Parser (Maybe a)))) - (case (p tokens) - #;None (#;Some [tokens #;None]) - (#;Some [tokens' x]) (#;Some [tokens' (#;Some x)]))) - -(def (run-parser p tokens) - (All [a] - (-> (Parser a) (List Syntax) (Maybe (, (List Syntax) a)))) - (p tokens)) - -(def #export (*^ p tokens) - (All [a] - (-> (Parser a) (Parser (List a)))) - (case (p tokens) - #;None (#;Some [tokens (list)]) - (#;Some [tokens' x]) (run-parser (do Parser/Monad - [xs (*^ p)] - (M;wrap (list& x xs))) - tokens'))) - -(def #export (+^ p) - (All [a] - (-> (Parser a) (Parser (List a)))) - (do Parser/Monad - [x p - xs (*^ p)] - (M;wrap (list& x xs)))) - -(def #export (&^ p1 p2) - (All [a b] - (-> (Parser a) (Parser b) (Parser (, a b)))) - (do Parser/Monad - [x1 p1 - x2 p2] - (M;wrap [x1 x2]))) - -(def #export (|^ p1 p2 tokens) - (All [a b] - (-> (Parser a) (Parser b) (Parser (Either b)))) - (case (p1 tokens) - (#;Some [tokens' x1]) (#;Some [tokens' (#;Left x1)]) - #;None (run-parser (do Parser/Monad - [x2 p2] - (M;wrap (#;Right x2))) - tokens))) - -(def #export (||^ ps tokens) - (All [a] - (-> (List (Parser a)) (Parser (Maybe a)))) - (case ps - #;Nil #;None - (#;Cons [p ps']) (case (p tokens) - #;None (||^ ps' tokens) - (#;Some [tokens' x]) (#;Some [tokens' (#;Some x)])) - )) - -(def #export (end^ tokens) - (Parser (,)) - (case tokens - #;Nil (#;Some [tokens []]) - _ #;None)) - -## Syntax -(defmacro #export (defsyntax tokens) - (let [[exported? tokens] (: (, Bool (List Syntax)) - (case tokens - (\ (list& (#;Meta [_ (#;TagS ["" "export"])]) tokens')) - [true tokens'] - - _ - [false tokens]))] - (case tokens - (\ (list (#;Meta [_ (#;FormS (list& (#;Meta [_ (#;SymbolS ["" name])]) args))]) - body)) - (do Lux/Monad - [names+parsers (M;map% Lux/Monad - (: (-> Syntax (Lux (, Syntax Syntax))) - (lambda [arg] - (case arg - (\ (#;Meta [_ (#;TupleS (list (#;Meta [_ (#;SymbolS var-name)]) - parser))])) - (M;wrap [(symbol$ var-name) parser]) - - (\ (#;Meta [_ (#;SymbolS var-name)])) - (M;wrap [(symbol$ var-name) (` id^)]) - - _ - (l;fail "Syntax pattern expects 2-tuples or symbols.")))) - args) - g!tokens (gensym "tokens") - g!_ (gensym "_") - #let [names (:: List/Functor (F;map first names+parsers)) - error-msg (text$ (text:++ "Wrong syntax for " name)) - body' (foldL (: (-> Syntax (, Syntax Syntax) Syntax) - (lambda [body name+parser] - (let [[name parser] name+parser] - (` (_lux_case ((~ parser) (~ g!tokens)) - (#;Some [(~ g!tokens) (~ name)]) - (~ body) - - (~ g!_) - (l;fail (~ error-msg))))))) - body - (reverse names+parsers)) - macro-def (: Syntax - (` (m;defmacro ((~ (symbol$ ["" name])) (~ g!tokens)) - (~ body'))))]] - (M;wrap (list& macro-def - (if exported? - (list (` (_lux_export (~ (symbol$ ["" name]))))) - (list))))) - - _ - (l;fail "Wrong syntax for defsyntax")))) diff --git a/input/program.lux b/input/program.lux deleted file mode 100644 index 984d8610f..000000000 --- a/input/program.lux +++ /dev/null @@ -1,48 +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. - -(;import lux - (lux (codata (stream #as S)) - (control monoid - functor - monad - lazy - comonad) - (data bool - bounded - char - ## cont - dict - (either #as e) - eq - error - id - io - list - maybe - number - ord - (reader #as r) - show - state - (text #as t) - writer) - (host java) - (meta lux - macro - syntax) - math - )) - -(program args - (case args - #;Nil - (println "Hello, world!") - - (#;Cons [name _]) - (println ($ text:++ "Hello, " name "!")))) diff --git a/source/lux.lux b/source/lux.lux new file mode 100644 index 000000000..50f8f1af2 --- /dev/null +++ b/source/lux.lux @@ -0,0 +1,2784 @@ +## 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)) + (#Exclude (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/exclude 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 ["" "exclude"])]) defs))])) + (do Lux/Monad + [defs' (extract-defs defs)] + (return (: (, Referrals (List Syntax)) [(#Exclude 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))) + + (#Exclude -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"))) diff --git a/source/lux/codata/stream.lux b/source/lux/codata/stream.lux new file mode 100644 index 000000000..1d6dd1b50 --- /dev/null +++ b/source/lux/codata/stream.lux @@ -0,0 +1,133 @@ +## 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 + (lux (control (lazy #as L #refer #all) + (functor #as F #refer #all) + (monad #as M #refer #all) + (comonad #as CM #refer #all)) + (meta lux + macro + syntax) + (data (list #as l #refer (#only list list& List/Monad))))) + +## [Types] +(deftype #export (Stream a) + (Lazy (, a (Stream a)))) + +## [Utils] +(def (cycle' x xs init full) + (All [a] + (-> a (List a) a (List a) (Stream a))) + (case xs + #;Nil (cycle' init full init full) + (#;Cons [y xs']) (... [x (cycle' y xs' init full)]))) + +## [Functions] +(def #export (iterate f x) + (All [a] + (-> (-> a a) a (Stream a))) + (... [x (iterate f (f x))])) + +(def #export (repeat x) + (All [a] + (-> a (Stream a))) + (... [x (repeat x)])) + +(def #export (cycle xs) + (All [a] + (-> (List a) (Maybe (Stream a)))) + (case xs + #;Nil #;None + (#;Cons [x xs']) (#;Some (cycle' x xs' x xs')))) + +(do-template [ ] + [(def #export ( s) + (All [a] (-> (Stream a) )) + (let [[h t] (! s)] + ))] + + [head a h] + [tail (Stream a) t]) + +(def #export (@ idx s) + (All [a] (-> Int (Stream a) a)) + (let [[h t] (! s)] + (if (i> idx 0) + (@ (dec idx) t) + h))) + +(do-template [ ] + [(def #export ( det xs) + (All [a] + (-> (Stream a) (List a))) + (let [[x xs'] (! xs)] + (if + (list& x ( xs')) + (list)))) + + (def #export ( det xs) + (All [a] + (-> (Stream a) (Stream a))) + (let [[x xs'] (! xs)] + (if + ( xs') + xs))) + + (def #export ( det xs) + (All [a] + (-> (Stream a) (, (List a) (Stream a)))) + (let [[x xs'] (! xs)] + (if + (let [[tail next] ( xs')] + [(#;Cons [x tail]) next]) + [(list) xs])))] + + [take-while drop-while split-with (-> a Bool) (det x) det] + [take drop split Int (i> det 0) (dec det)] + ) + +(def #export (unfold step init) + (All [a b] + (-> (-> a (, a b)) a (Stream b))) + (let [[next x] (step init)] + (... [x (unfold step next)]))) + +(def #export (filter p xs) + (All [a] (-> (-> a Bool) (Stream a) (Stream a))) + (let [[x xs'] (! xs)] + (if (p x) + (... [x (filter p xs')]) + (filter p xs')))) + +(def #export (partition p xs) + (All [a] (-> (-> a Bool) (Stream a) (, (Stream a) (Stream a)))) + [(filter p xs) (filter (complement p) xs)]) + +## [Structures] +(defstruct #export Stream/Functor (Functor Stream) + (def (F;map f fa) + (let [[h t] (! fa)] + (... [(f h) (F;map f t)])))) + +(defstruct #export Stream/CoMonad (CoMonad Stream) + (def CM;_functor Stream/Functor) + (def CM;unwrap head) + (def (CM;split wa) + (:: Stream/Functor (F;map repeat wa)))) + +## [Pattern-matching] +(defsyntax #export (\stream body [patterns' (+^ id^)]) + (do Lux/Monad + [patterns (map% Lux/Monad macro-expand-1 patterns') + g!s (gensym "s") + #let [patterns+ (: (List Syntax) + (do List/Monad + [pattern (l;reverse patterns)] + (list (` [(~ pattern) (~ g!s)]) (` (L;! (~ g!s))))))]] + (M;wrap (list g!s (` (;let [(~@ patterns+)] (~ body))))))) diff --git a/source/lux/control/comonad.lux b/source/lux/control/comonad.lux new file mode 100644 index 000000000..1830ff44f --- /dev/null +++ b/source/lux/control/comonad.lux @@ -0,0 +1,54 @@ +## 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 + (../functor #as F) + lux/data/list + lux/meta/macro) + +## Signatures +(defsig #export (CoMonad w) + (: (F;Functor w) + _functor) + (: (All [a] + (-> (w a) a)) + unwrap) + (: (All [a] + (-> (w a) (w (w a)))) + split)) + +## Functions +(def #export (extend w f ma) + (All [w a b] + (-> (CoMonad w) (-> (w a) b) (w a) (w b))) + (using w + (using ;;_functor + (F;map f (;;split ma))))) + +## Syntax +(defmacro #export (be tokens state) + (case tokens + (\ (list monad (#;Meta [_ (#;TupleS bindings)]) body)) + (let [body' (foldL (: (-> Syntax (, Syntax Syntax) Syntax) + (lambda [body' binding] + (let [[var value] binding] + (case var + (#;Meta [_ (#;TagS ["" "let"])]) + (` (;let (~ value) (~ body'))) + + _ + (` (extend (;lambda [(~ var)] (~ body')) + (~ value))))))) + body + (reverse (as-pairs bindings)))] + (#;Right [state (list (` (;case (~ monad) + {#;return ;return #;bind ;bind} + (~ body'))))])) + + _ + (#;Left "Wrong syntax for be"))) diff --git a/source/lux/control/functor.lux b/source/lux/control/functor.lux new file mode 100644 index 000000000..6a9dcfff8 --- /dev/null +++ b/source/lux/control/functor.lux @@ -0,0 +1,15 @@ +## 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) + +## Signatures +(defsig #export (Functor f) + (: (All [a b] + (-> (-> a b) (f a) (f b))) + map)) diff --git a/source/lux/control/lazy.lux b/source/lux/control/lazy.lux new file mode 100644 index 000000000..22dac74fe --- /dev/null +++ b/source/lux/control/lazy.lux @@ -0,0 +1,47 @@ +## 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 + (lux/meta macro) + (.. (functor #as F #refer #all) + (monad #as M #refer #all)) + (lux/data list)) + +## Types +(deftype #export (Lazy a) + (All [b] + (-> (-> a b) b))) + +## Syntax +(defmacro #export (... tokens state) + (case tokens + (\ (list value)) + (let [blank (symbol$ ["" ""])] + (#;Right [state (list (` (;lambda [(~ blank)] ((~ blank) (~ value)))))])) + + _ + (#;Left "Wrong syntax for ..."))) + +## Functions +(def #export (! thunk) + (All [a] + (-> (Lazy a) a)) + (thunk id)) + +## Structs +(defstruct #export Lazy/Functor (Functor Lazy) + (def (F;map f ma) + (lambda [k] (ma (. k f))))) + +(defstruct #export Lazy/Monad (Monad Lazy) + (def M;_functor Lazy/Functor) + + (def (M;wrap a) + (... a)) + + (def M;join !)) diff --git a/source/lux/control/monad.lux b/source/lux/control/monad.lux new file mode 100644 index 000000000..b5552f987 --- /dev/null +++ b/source/lux/control/monad.lux @@ -0,0 +1,99 @@ +## 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 + (.. (functor #as F) + (monoid #as M)) + lux/meta/macro) + +## [Utils] +(def (foldL f init xs) + (All [a b] + (-> (-> a b a) a (List b) a)) + (case xs + #;Nil + init + + (#;Cons [x xs']) + (foldL f (f init x) xs'))) + +(def (reverse xs) + (All [a] + (-> (List a) (List a))) + (foldL (lambda [tail head] (#;Cons [head tail])) + #;Nil + xs)) + +(def (as-pairs xs) + (All [a] (-> (List a) (List (, a a)))) + (case xs + (#;Cons [x1 (#;Cons [x2 xs'])]) + (#;Cons [[x1 x2] (as-pairs xs')]) + + _ + #;Nil)) + +## [Signatures] +(defsig #export (Monad m) + (: (F;Functor m) + _functor) + (: (All [a] + (-> a (m a))) + wrap) + (: (All [a] + (-> (m (m a)) (m a))) + join)) + +## [Syntax] +(defmacro #export (do tokens state) + (case tokens + ## (\ (list monad (#;Meta [_ (#;TupleS bindings)]) body)) + (#;Cons [monad (#;Cons [(#;Meta [_ (#;TupleS bindings)]) (#;Cons [body #;Nil])])]) + (let [body' (foldL (: (-> Syntax (, Syntax Syntax) Syntax) + (lambda [body' binding] + (let [[var value] binding] + (case var + (#;Meta [_ (#;TagS ["" "let"])]) + (` (;let (~ value) (~ body'))) + + _ + (` (;case ;;_functor + {#F;map F;map} + (;|> (~ value) (F;map (;lambda [(~ var)] (~ body'))) (;;join)))) + ## (` (;|> (~ value) (F;map (;lambda [(~ var)] (~ body'))) (;:: ;;_functor) (;;join))) + )))) + body + (reverse (as-pairs bindings)))] + (#;Right [state (#;Cons [(` (;case (~ monad) + {#;;_functor ;;_functor #;;wrap ;;wrap #;;join ;;join} + (~ body'))) + #;Nil])])) + + _ + (#;Left "Wrong syntax for do"))) + +## [Functions] +(def #export (bind m f ma) + (All [m a b] + (-> (Monad m) (-> a (m b)) (m a) (m b))) + (using m + (;;join (:: ;;_functor (F;map f ma))))) + +(def #export (map% m f xs) + (All [m a b] + (-> (Monad m) (-> a (m b)) (List a) (m (List b)))) + (case xs + #;Nil + (:: m (;;wrap #;Nil)) + + (#;Cons [x xs']) + (do m + [y (f x) + ys (map% m f xs')] + (;;wrap (#;Cons [y ys]))) + )) diff --git a/source/lux/control/monoid.lux b/source/lux/control/monoid.lux new file mode 100644 index 000000000..d32baabc5 --- /dev/null +++ b/source/lux/control/monoid.lux @@ -0,0 +1,24 @@ +## 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) + +## Signatures +(defsig #export (Monoid a) + (: a + unit) + (: (-> a a a) + ++)) + +## Constructors +(def #export (monoid$ unit ++) + (All [a] + (-> a (-> a a a) (Monoid a))) + (struct + (def unit unit) + (def ++ ++))) diff --git a/source/lux/data/bool.lux b/source/lux/data/bool.lux new file mode 100644 index 000000000..d4f223612 --- /dev/null +++ b/source/lux/data/bool.lux @@ -0,0 +1,33 @@ +## 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 + (lux/control (monoid #as m)) + (.. (eq #as E) + (show #as S))) + +## [Structures] +(defstruct #export Bool/Eq (E;Eq Bool) + (def (E;= x y) + (if x + y + (not y)))) + +(defstruct #export Bool/Show (S;Show Bool) + (def (S;show x) + (if x "true" "false"))) + +(do-template [ ] + [(defstruct #export (m;Monoid Bool) + (def m;unit ) + (def (m;++ x y) + ( x y)))] + + [ Or/Monoid false or] + [And/Monoid true and] + ) diff --git a/source/lux/data/bounded.lux b/source/lux/data/bounded.lux new file mode 100644 index 000000000..9d2dabde1 --- /dev/null +++ b/source/lux/data/bounded.lux @@ -0,0 +1,17 @@ +## 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) + +## Signatures +(defsig #export (Bounded a) + (: a + top) + + (: a + bottom)) diff --git a/source/lux/data/char.lux b/source/lux/data/char.lux new file mode 100644 index 000000000..42e57509e --- /dev/null +++ b/source/lux/data/char.lux @@ -0,0 +1,20 @@ +## 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 + (.. (eq #as E) + (show #as S))) + +## [Structures] +(defstruct #export Char/Eq (E;Eq Char) + (def (E;= x y) + (_jvm_ceq x y))) + +(defstruct #export Char/Show (S;Show Char) + (def (S;show x) + ($ text:++ "#\"" (_jvm_invokevirtual java.lang.Object toString [] x []) "\""))) diff --git a/source/lux/data/dict.lux b/source/lux/data/dict.lux new file mode 100644 index 000000000..63a66d49b --- /dev/null +++ b/source/lux/data/dict.lux @@ -0,0 +1,83 @@ +## 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 + (lux/data (eq #as E))) + +## Signatures +(defsig #export (Dict d) + (: (All [k v] + (-> k (d k v) (Maybe v))) + get) + (: (All [k v] + (-> k v (d k v) (d k v))) + put) + (: (All [k v] + (-> k (d k v) (d k v))) + remove)) + +## Types +(deftype #export (PList k v) + (| (#PList (, (E;Eq k) (List (, k v)))))) + +## Constructors +(def #export (plist eq) + (All [k v] + (-> (E;Eq k) (PList k v))) + (#PList [eq #;Nil])) + +## Utils +(def (pl-get eq k kvs) + (All [k v] + (-> (E;Eq k) k (List (, k v)) (Maybe v))) + (case kvs + #;Nil + #;None + + (#;Cons [[k' v'] kvs']) + (if (:: eq (E;= k k')) + (#;Some v') + (pl-get eq k kvs')))) + +(def (pl-put eq k v kvs) + (All [k v] + (-> (E;Eq k) k v (List (, k v)) (List (, k v)))) + (case kvs + #;Nil + (#;Cons [[k v] kvs]) + + (#;Cons [[k' v'] kvs']) + (if (:: eq (E;= k k')) + (#;Cons [[k v] kvs']) + (#;Cons [[k' v'] (pl-put eq k v kvs')])))) + +(def (pl-remove eq k kvs) + (All [k v] + (-> (E;Eq k) k (List (, k v)) (List (, k v)))) + (case kvs + #;Nil + kvs + + (#;Cons [[k' v'] kvs']) + (if (:: eq (E;= k k')) + kvs' + (#;Cons [[k' v'] (pl-remove eq k kvs')])))) + +## Structs +(defstruct #export PList/Dict (Dict PList) + (def (get k plist) + (let [(#PList [eq kvs]) plist] + (pl-get eq k kvs))) + + (def (put k v plist) + (let [(#PList [eq kvs]) plist] + (#PList [eq (pl-put eq k v kvs)]))) + + (def (remove k plist) + (let [(#PList [eq kvs]) plist] + (#PList [eq (pl-remove eq k kvs)])))) diff --git a/source/lux/data/either.lux b/source/lux/data/either.lux new file mode 100644 index 000000000..eba6438db --- /dev/null +++ b/source/lux/data/either.lux @@ -0,0 +1,46 @@ +## 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 + (lux/data (list #refer (#exclude partition)))) + +## [Types] +## (deftype (Either l r) +## (| (#;Left l) +## (#;Right r))) + +## [Functions] +(def #export (either f g e) + (All [a b c] (-> (-> a c) (-> b c) (Either a b) c)) + (case e + (#;Left x) (f x) + (#;Right x) (g x))) + +(do-template [ ] + [(def #export ( es) + (All [a b] (-> (List (Either a b)) (List ))) + (case es + #;Nil #;Nil + (#;Cons [( x) es']) (#;Cons [x ( es')]) + (#;Cons [_ es']) ( es')))] + + [lefts a #;Left] + [rights b #;Right] + ) + +(def #export (partition es) + (All [a b] (-> (List (Either a b)) (, (List a) (List b)))) + (foldL (: (All [a b] + (-> (, (List a) (List b)) (Either a b) (, (List a) (List b)))) + (lambda [tails e] + (let [[ltail rtail] tails] + (case e + (#;Left x) [(#;Cons [x ltail]) rtail] + (#;Right x) [ltail (#;Cons [x rtail])])))) + [(list) (list)] + (reverse es))) diff --git a/source/lux/data/eq.lux b/source/lux/data/eq.lux new file mode 100644 index 000000000..be3400208 --- /dev/null +++ b/source/lux/data/eq.lux @@ -0,0 +1,14 @@ +## 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) + +## [Signatures] +(defsig #export (Eq a) + (: (-> a a Bool) + =)) diff --git a/source/lux/data/error.lux b/source/lux/data/error.lux new file mode 100644 index 000000000..cb5c309a6 --- /dev/null +++ b/source/lux/data/error.lux @@ -0,0 +1,34 @@ +## 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 + (lux/control (functor #as F #refer #all) + (monad #as M #refer #all))) + +## [Types] +(deftype #export (Error a) + (| (#Fail Text) + (#Ok a))) + +## [Structures] +(defstruct #export Error/Functor (Functor Error) + (def (F;map f ma) + (case ma + (#Fail msg) (#Fail msg) + (#Ok datum) (#Ok (f datum))))) + +(defstruct #export Error/Monad (Monad Error) + (def M;_functor Error/Functor) + + (def (M;wrap a) + (#Ok a)) + + (def (M;join mma) + (case mma + (#Fail msg) (#Fail msg) + (#Ok ma) ma))) diff --git a/source/lux/data/id.lux b/source/lux/data/id.lux new file mode 100644 index 000000000..0e3bdbee6 --- /dev/null +++ b/source/lux/data/id.lux @@ -0,0 +1,28 @@ +## 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 + (lux/control (functor #as F #refer #all) + (monad #as M #refer #all))) + +## [Types] +(deftype #export (Id a) + (| (#Id a))) + +## [Structures] +(defstruct #export Id/Functor (Functor Id) + (def (F;map f fa) + (let [(#Id a) fa] + (#Id (f a))))) + +(defstruct #export Id/Monad (Monad Id) + (def M;_functor Id/Functor) + (def (M;wrap a) (#Id a)) + (def (M;join mma) + (let [(#Id ma) mma] + ma))) diff --git a/source/lux/data/io.lux b/source/lux/data/io.lux new file mode 100644 index 000000000..c08023df5 --- /dev/null +++ b/source/lux/data/io.lux @@ -0,0 +1,51 @@ +## 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 + (lux/meta macro) + (lux/control (functor #as F) + (monad #as M)) + lux/data/list) + +## Types +(deftype #export (IO a) + (-> (,) a)) + +## Syntax +(defmacro #export (io tokens state) + (case tokens + (\ (list value)) + (let [blank (symbol$ ["" ""])] + (#;Right [state (list (` (_lux_lambda (~ blank) (~ blank) (~ value))))])) + + _ + (#;Left "Wrong syntax for io"))) + +## Structures +(defstruct #export IO/Functor (F;Functor IO) + (def (F;map f ma) + (io (f (ma []))))) + +(defstruct #export IO/Monad (M;Monad IO) + (def M;_functor IO/Functor) + + (def (M;wrap x) + (io x)) + + (def (M;join mma) + (mma []))) + +## Functions +(def #export (print x) + (-> Text (IO (,))) + (io (_jvm_invokevirtual java.io.PrintStream print [java.lang.Object] + (_jvm_getstatic java.lang.System out) [x]))) + +(def #export (println x) + (-> Text (IO (,))) + (print (text:++ x "\n"))) diff --git a/source/lux/data/list.lux b/source/lux/data/list.lux new file mode 100644 index 000000000..450dee275 --- /dev/null +++ b/source/lux/data/list.lux @@ -0,0 +1,250 @@ +## 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 + (lux/control (monoid #as m #refer #all) + (functor #as F #refer #all) + (monad #as M #refer #all)) + lux/meta/macro) + +## Types +## (deftype (List a) +## (| #Nil +## (#Cons (, a (List a))))) + +## Functions +(def #export (foldL f init xs) + (All [a b] + (-> (-> a b a) a (List b) a)) + (case xs + #;Nil + init + + (#;Cons [x xs']) + (foldL f (f init x) xs'))) + +(def #export (foldR f init xs) + (All [a b] + (-> (-> b a a) a (List b) a)) + (case xs + #;Nil + init + + (#;Cons [x xs']) + (f x (foldR f init xs')))) + +(def #export (reverse xs) + (All [a] + (-> (List a) (List a))) + (foldL (lambda [tail head] (#;Cons [head tail])) + #;Nil + xs)) + +(def #export (filter p xs) + (All [a] + (-> (-> a Bool) (List a) (List a))) + (case xs + #;Nil + #;Nil + + (#;Cons [x xs']) + (if (p x) + (#;Cons [x (filter p xs')]) + (filter p xs')))) + +(def #export (partition p xs) + (All [a] (-> (-> a Bool) (List a) (, (List a) (List a)))) + [(filter p xs) (filter (complement p) xs)]) + +(def #export (as-pairs xs) + (All [a] (-> (List a) (List (, a a)))) + (case xs + (\ (#;Cons [x1 (#;Cons [x2 xs'])])) + (#;Cons [[x1 x2] (as-pairs xs')]) + + _ + #;Nil)) + +(do-template [ ] + [(def #export ( n xs) + (All [a] + (-> Int (List a) (List a))) + (if (i> n 0) + (case xs + #;Nil + #;Nil + + (#;Cons [x xs']) + ) + ))] + + [take (#;Cons [x (take (dec n) xs')]) #;Nil] + [drop (drop (dec n) xs') xs] + ) + +(do-template [ ] + [(def #export ( p xs) + (All [a] + (-> (-> a Bool) (List a) (List a))) + (case xs + #;Nil + #;Nil + + (#;Cons [x xs']) + (if (p x) + + )))] + + [take-while (#;Cons [x (take-while p xs')]) #;Nil] + [drop-while (drop-while p xs') xs] + ) + +(def #export (split n xs) + (All [a] + (-> Int (List a) (, (List a) (List a)))) + (if (i> n 0) + (case xs + #;Nil + [#;Nil #;Nil] + + (#;Cons [x xs']) + (let [[tail rest] (split (dec n) xs')] + [(#;Cons [x tail]) rest])) + [#;Nil 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 (#;Cons [x ys]) xs') + [ys xs]))) + +(def #export (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 #export (repeat n x) + (All [a] + (-> Int a (List a))) + (if (i> n 0) + (#;Cons [x (repeat (dec n) x)]) + #;Nil)) + +(def #export (iterate f x) + (All [a] + (-> (-> a (Maybe a)) a (List a))) + (case (f x) + (#;Some x') + (#;Cons [x (iterate f x')]) + + #;None + (#;Cons [x #;Nil]))) + +(def #export (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 #export (interpose sep xs) + (All [a] + (-> a (List a) (List a))) + (case xs + #;Nil + xs + + (#;Cons [x #;Nil]) + xs + + (#;Cons [x xs']) + (#;Cons [x (#;Cons [sep (interpose sep xs')])]))) + +(def #export (size list) + (-> List Int) + (foldL (lambda [acc _] (i+ 1 acc)) 0 list)) + +(do-template [ ] + [(def #export ( p xs) + (All [a] + (-> (-> a Bool) (List a) Bool)) + (foldL (lambda [_1 _2] ( _1 (p _2))) xs))] + + [every? true and] + [any? false or]) + +(def #export (@ i xs) + (All [a] + (-> Int (List a) (Maybe a))) + (case xs + #;Nil + #;None + + (#;Cons [x xs']) + (if (i= 0 i) + (#;Some x) + (@ (dec i) xs')))) + +## Syntax +(defmacro #export (list xs state) + (#;Right [state (#;Cons [(foldL (lambda [tail head] + (` (#;Cons [(~ head) (~ tail)]))) + (` #;Nil) + (reverse xs)) + #;Nil])])) + +(defmacro #export (list& xs state) + (case (reverse xs) + (#;Cons [last init]) + (#;Right [state (list (foldL (lambda [tail head] + (` (#;Cons [(~ head) (~ tail)]))) + last + init))]) + + _ + (#;Left "Wrong syntax for list&"))) + +## Structures +(defstruct #export List/Monoid (All [a] + (Monoid (List a))) + (def m;unit #;Nil) + (def (m;++ xs ys) + (case xs + #;Nil ys + (#;Cons [x xs']) (#;Cons [x (m;++ xs' ys)])))) + +(defstruct #export List/Functor (Functor List) + (def (F;map f ma) + (case ma + #;Nil #;Nil + (#;Cons [a ma']) (#;Cons [(f a) (F;map f ma')])))) + +(defstruct #export List/Monad (Monad List) + (def M;_functor List/Functor) + + (def (M;wrap a) + (#;Cons [a #;Nil])) + + (def (M;join mma) + (using List/Monoid + (foldL m;++ m;unit mma)))) diff --git a/source/lux/data/maybe.lux b/source/lux/data/maybe.lux new file mode 100644 index 000000000..faec53c2e --- /dev/null +++ b/source/lux/data/maybe.lux @@ -0,0 +1,42 @@ +## 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 + (lux/control (monoid #as m #refer #all) + (functor #as F #refer #all) + (monad #as M #refer #all))) + +## [Types] +## (deftype (Maybe a) +## (| #;None +## (#;Some a))) + +## [Structures] +(defstruct #export Maybe/Monoid (Monoid Maybe) + (def m;unit #;None) + (def (m;++ xs ys) + (case xs + #;None ys + (#;Some x) (#;Some x)))) + +(defstruct #export Maybe/Functor (Functor Maybe) + (def (F;map f ma) + (case ma + #;None #;None + (#;Some a) (#;Some (f a))))) + +(defstruct #export Maybe/Monad (Monad Maybe) + (def M;_functor Maybe/Functor) + + (def (M;wrap x) + (#;Some x)) + + (def (M;join mma) + (case mma + #;None #;None + (#;Some xs) xs))) diff --git a/source/lux/data/number.lux b/source/lux/data/number.lux new file mode 100644 index 000000000..8da674d88 --- /dev/null +++ b/source/lux/data/number.lux @@ -0,0 +1,119 @@ +## 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 + (lux/control (monoid #as m)) + (lux/data (eq #as E) + (ord #as O) + (bounded #as B) + (show #as S))) + +## Signatures +(defsig #export (Number n) + (do-template [] + [(: (-> n n n) )] + [+] [-] [*] [/] [%]) + + (: (-> Int n) + from-int) + + (do-template [] + [(: (-> n n) )] + [negate] [signum] [abs]) + ) + +## [Structures] +## Number +(do-template [ <+> <-> <*> <%> <=> <<> <0> <1> <-1>] + [(defstruct #export (Number ) + (def + <+>) + (def - <->) + (def * <*>) + (def / ) + (def % <%>) + (def (from-int x) + ( x)) + (def (negate x) + (<*> <-1> x)) + (def (abs x) + (if (<<> x <0>) + (<*> <-1> x) + x)) + (def (signum x) + (cond (<=> x <0>) <0> + (<<> x <0>) <-1> + ## else + <1>)) + )] + + [ Int/Number Int i+ i- i* i/ i% i= i< id 0 1 -1] + [Real/Number Real r+ r- r* r/ r% r= r< _jvm_l2d 0.0 1.0 -1.0]) + +## Eq +(defstruct #export Int/Eq (E;Eq Int) + (def E;= i=)) + +(defstruct #export Real/Eq (E;Eq Real) + (def E;= r=)) + +## Ord +## (def #export Int/Ord (O;Ord Int) +## (O;ord$ Int/Eq i< i>)) + +## (def #export Real/Ord (O;Ord Real) +## (O;ord$ Real/Eq r< r>)) + +(do-template [ ] + [(defstruct #export (O;Ord ) + (def O;_eq ) + (def O;< ) + (def (O;<= x y) + (or ( x y) + (using (E;= x y)))) + (def O;> ) + (def (O;>= x y) + (or ( x y) + (using (E;= x y)))))] + + [ Int/Ord Int Int/Eq i< i>] + [Real/Ord Real Real/Eq r< r>]) + +## Bounded +(do-template [ ] + [(defstruct #export (B;Bounded ) + (def B;top ) + (def B;bottom ))] + + [ Int/Bounded Int (_jvm_getstatic java.lang.Long MAX_VALUE) (_jvm_getstatic java.lang.Long MIN_VALUE)] + [Real/Bounded Real (_jvm_getstatic java.lang.Double MAX_VALUE) (_jvm_getstatic java.lang.Double MIN_VALUE)]) + +## Monoid +(do-template [ <++>] + [(defstruct #export (m;Monoid ) + (def m;unit ) + (def m;++ <++>))] + + [ IntAdd/Monoid Int 0 i+] + [ IntMul/Monoid Int 1 i*] + [RealAdd/Monoid Real 0.0 r+] + [RealMul/Monoid Real 1.0 r*] + [ IntMax/Monoid Int (:: Int/Bounded B;bottom) (O;max Int/Ord)] + [ IntMin/Monoid Int (:: Int/Bounded B;top) (O;min Int/Ord)] + [RealMax/Monoid Real (:: Real/Bounded B;bottom) (O;max Real/Ord)] + [RealMin/Monoid Real (:: Real/Bounded B;top) (O;min Real/Ord)] + ) + +## Show +(do-template [ ] + [(defstruct #export (S;Show ) + (def (S;show x) + ))] + + [ Int/Show Int (_jvm_invokevirtual java.lang.Object toString [] x [])] + [Real/Show Real (_jvm_invokevirtual java.lang.Object toString [] x [])] + ) diff --git a/source/lux/data/ord.lux b/source/lux/data/ord.lux new file mode 100644 index 000000000..80f2e4fb5 --- /dev/null +++ b/source/lux/data/ord.lux @@ -0,0 +1,44 @@ +## 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 + (../eq #as E)) + +## [Signatures] +(defsig #export (Ord a) + (: (E;Eq a) + _eq) + (do-template [] + [(: (-> a a Bool) )] + + [<] [<=] [>] [>=])) + +## [Constructors] +(def #export (ord$ eq < >) + (All [a] + (-> (E;Eq a) (-> a a Bool) (-> a a Bool) (Ord a))) + (struct + (def _eq eq) + (def < <) + (def (<= x y) + (or (< x y) + (:: eq (E;= x y)))) + (def > >) + (def (>= x y) + (or (> x y) + (:: eq (E;= x y)))))) + +## [Functions] +(do-template [ ] + [(def #export ( ord x y) + (All [a] + (-> (Ord a) a a a)) + (if (:: ord ( x y)) x y))] + + [max ;;>] + [min ;;<]) diff --git a/source/lux/data/reader.lux b/source/lux/data/reader.lux new file mode 100644 index 000000000..e91687c3a --- /dev/null +++ b/source/lux/data/reader.lux @@ -0,0 +1,33 @@ +## 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 #refer (#exclude Reader)) + (lux/control (functor #as F #refer #all) + (monad #as M #refer #all))) + +## [Types] +(deftype #export (Reader r a) + (-> r a)) + +## [Structures] +(defstruct #export Reader/Functor (All [r] + (Functor (Reader r))) + (def (F;map f fa) + (lambda [env] + (f (fa env))))) + +(defstruct #export Reader/Monad (All [r] + (Monad (Reader r))) + (def M;_functor Reader/Functor) + + (def (M;wrap x) + (lambda [env] x)) + + (def (M;join mma) + (lambda [env] + (mma env env)))) diff --git a/source/lux/data/show.lux b/source/lux/data/show.lux new file mode 100644 index 000000000..f4e1cf762 --- /dev/null +++ b/source/lux/data/show.lux @@ -0,0 +1,14 @@ +## 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) + +## Signatures +(defsig #export (Show a) + (: (-> a Text) + show)) diff --git a/source/lux/data/state.lux b/source/lux/data/state.lux new file mode 100644 index 000000000..bc9858a29 --- /dev/null +++ b/source/lux/data/state.lux @@ -0,0 +1,35 @@ +## 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 + (lux/control (functor #as F #refer #all) + (monad #as M #refer #all))) + +## [Types] +(deftype #export (State s a) + (-> s (, s a))) + +## [Structures] +(defstruct #export State/Functor (Functor State) + (def (F;map f ma) + (lambda [state] + (let [[state' a] (ma state)] + [state' (f a)])))) + +(defstruct #export State/Monad (All [s] + (Monad (State s))) + (def M;_functor State/Functor) + + (def (M;wrap x) + (lambda [state] + [state x])) + + (def (M;join mma) + (lambda [state] + (let [[state' ma] (mma state)] + (ma state'))))) diff --git a/source/lux/data/text.lux b/source/lux/data/text.lux new file mode 100644 index 000000000..a3192a1d5 --- /dev/null +++ b/source/lux/data/text.lux @@ -0,0 +1,146 @@ +## 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 + (lux/control (monoid #as m)) + (lux/data (eq #as E) + (ord #as O) + (show #as S))) + +## [Functions] +(def #export (size x) + (-> Text Int) + (_jvm_i2l (_jvm_invokevirtual java.lang.String length [] + x []))) + +(def #export (@ idx x) + (-> Int Text (Maybe Char)) + (if (and (i< idx (size x)) + (i>= idx 0)) + (#;Some (_jvm_invokevirtual java.lang.String charAt [int] + x [(_jvm_l2i idx)])) + #;None)) + +(def #export (contains? x y) + (-> Text Text Bool) + (_jvm_invokevirtual java.lang.String contains [java.lang.CharSequence] + x [y])) + +(do-template [ ] + [(def #export ( x) + (-> Text Text) + (_jvm_invokevirtual java.lang.String [] + x []))] + [lower-case toLowerCase] + [upper-case toUpperCase] + [trim trim] + ) + +(def #export (sub' from to x) + (-> Int Int Text (Maybe Text)) + (if (and (i< from to) + (i>= from 0) + (i<= to (size x))) + (_jvm_invokevirtual java.lang.String substring [int int] + x [(_jvm_l2i from) (_jvm_l2i to)]) + #;None)) + +(def #export (sub from x) + (-> Int Text (Maybe Text)) + (sub' from (size x) x)) + +(def #export (split at x) + (-> Int Text (Maybe (, Text Text))) + (if (and (i< at (size x)) + (i>= at 0)) + (let [pre (_jvm_invokevirtual java.lang.String substring [int int] + x [(_jvm_l2i 0) (_jvm_l2i at)]) + post (_jvm_invokevirtual java.lang.String substring [int] + x [(_jvm_l2i at)])] + (#;Some [pre post])) + #;None)) + +(def #export (replace pattern value template) + (-> Text Text Text Text) + (_jvm_invokevirtual java.lang.String replace [java.lang.CharSequence java.lang.CharSequence] + template [pattern value])) + +(do-template [ ] + [(def #export ( pattern from x) + (-> Text Int Text (Maybe Int)) + (if (and (i< from (size x)) (i>= from 0)) + (case (_jvm_i2l (_jvm_invokevirtual java.lang.String [java.lang.String int] + x [pattern (_jvm_l2i from)])) + -1 #;None + idx (#;Some idx)) + #;None)) + + (def #export ( pattern x) + (-> Text Text (Maybe Int)) + (case (_jvm_i2l (_jvm_invokevirtual java.lang.String [java.lang.String] + x [pattern])) + -1 #;None + idx (#;Some idx)))] + + [index-of index-of' indexOf] + [last-index-of last-index-of' lastIndexOf] + ) + +(def #export (starts-with? prefix x) + (-> Text Text Bool) + (case (index-of prefix x) + (#;Some 0) + true + + _ + false)) + +(def #export (ends-with? postfix x) + (-> Text Text Bool) + (case (last-index-of postfix x) + (#;Some n) + (i= (i+ n (size postfix)) + (size x)) + + _ + false)) + +## [Structures] +(defstruct #export Text/Eq (E;Eq Text) + (def (E;= x y) + (_jvm_invokevirtual java.lang.Object equals [java.lang.Object] + x [y]))) + +(defstruct #export Text/Ord (O;Ord Text) + (def O;_eq Text/Eq) + (def (O;< x y) + (i< (_jvm_i2l (_jvm_invokevirtual java.lang.String compareTo [java.lang.String] + x [y])) + 0)) + (def (O;<= x y) + (i<= (_jvm_i2l (_jvm_invokevirtual java.lang.String compareTo [java.lang.String] + x [y])) + 0)) + (def (O;> x y) + (i> (_jvm_i2l (_jvm_invokevirtual java.lang.String compareTo [java.lang.String] + x [y])) + 0)) + (def (O;>= x y) + (i>= (_jvm_i2l (_jvm_invokevirtual java.lang.String compareTo [java.lang.String] + x [y])) + 0))) + +(defstruct #export Text/Show (S;Show Text) + (def (S;show x) + x)) + +(defstruct #export Text/Monoid (m;Monoid Text) + (def m;unit "") + (def (m;++ x y) + (_jvm_invokevirtual java.lang.String concat [java.lang.String] + x [y]))) diff --git a/source/lux/data/writer.lux b/source/lux/data/writer.lux new file mode 100644 index 000000000..f71492e35 --- /dev/null +++ b/source/lux/data/writer.lux @@ -0,0 +1,34 @@ +## 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 + (lux/control (monoid #as m #refer #all) + (functor #as F #refer #all) + (monad #as M #refer #all))) + +## [Types] +(deftype #export (Writer l a) + (, l a)) + +## [Structures] +(defstruct #export Writer/Functor (All [l] + (Functor (Writer l))) + (def (F;map f fa) + (let [[log datum] fa] + [log (f datum)]))) + +(defstruct #export (Writer/Monad mon) (All [l] + (-> (Monoid l) (Monad (Writer l)))) + (def M;_functor Writer/Functor) + + (def (M;wrap x) + [(:: mon m;unit) x]) + + (def (M;join mma) + (let [[log1 [log2 a]] mma] + [(:: mon (m;++ log1 log2)) a]))) diff --git a/source/lux/host/java.lux b/source/lux/host/java.lux new file mode 100644 index 000000000..12525d3f2 --- /dev/null +++ b/source/lux/host/java.lux @@ -0,0 +1,312 @@ +## 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 + (lux (control (monoid #as m) + (functor #as F) + (monad #as M #refer (#only do))) + (data list + (text #as text)) + (meta lux + macro + syntax))) + +## (open List/Functor) + +## [Utils/Parsers] +(def finally^ + (Parser Syntax) + (form^ (do Parser/Monad + [_ (symbol?^ ["" "finally"]) + expr id^ + _ end^] + (M;wrap expr)))) + +(def catch^ + (Parser (, Text Ident Syntax)) + (form^ (do Parser/Monad + [_ (symbol?^ ["" "catch"]) + ex-class local-symbol^ + ex symbol^ + expr id^ + _ end^] + (M;wrap [ex-class ex expr])))) + +(def method-decl^ + (Parser (, (List Text) Text (List Text) Text)) + (form^ (do Parser/Monad + [modifiers (*^ local-tag^) + name local-symbol^ + inputs (tuple^ (*^ local-symbol^)) + output local-symbol^ + _ end^] + (M;wrap [modifiers name inputs output])))) + +(def field-decl^ + (Parser (, (List Text) Text Text)) + (form^ (do Parser/Monad + [modifiers (*^ local-tag^) + name local-symbol^ + class local-symbol^ + _ end^] + (M;wrap [modifiers name class])))) + +(def arg-decl^ + (Parser (, Text Text)) + (form^ (do Parser/Monad + [arg-name local-symbol^ + arg-class local-symbol^ + _ end^] + (M;wrap [arg-name arg-class])))) + +(def method-def^ + (Parser (, (List Text) Text (List (, Text Text)) Text Syntax)) + (form^ (do Parser/Monad + [modifiers (*^ local-tag^) + name local-symbol^ + inputs (tuple^ (*^ arg-decl^)) + output local-symbol^ + body id^ + _ end^] + (M;wrap [modifiers name inputs output body])))) + +(def method-call^ + (Parser (, Text (List Text) (List Syntax))) + (form^ (do Parser/Monad + [method local-symbol^ + arity-classes (tuple^ (*^ local-symbol^)) + arity-args (tuple^ (*^ id^)) + _ end^ + _ (: (Parser (,)) + (if (i= (size arity-classes) + (size arity-args)) + (M;wrap []) + (lambda [_] #;None)))] + (M;wrap [method arity-classes arity-args]) + ))) + +## [Utils/Lux] +## (def (find-class-field field class) +## (-> Text Text (Lux Type)) +## ...) + +## (def (find-virtual-method method class) +## (-> Text Text (Lux (List (, (List Type) Type)))) +## ...) + +## (def (find-static-method method class) +## (-> Text Text (Lux (List (, (List Type) Type)))) +## ...) + + +## [Syntax] +(defsyntax #export (throw ex) + (emit (list (` (_jvm_throw (~ ex)))))) + +(defsyntax #export (try body [catches (*^ catch^)] [finally (?^ finally^)]) + (emit (list (` (_jvm_try (~ body) + (~@ (list:++ (:: List/Functor (F;map (: (-> (, Text Ident Syntax) Syntax) + (lambda [catch] + (let [[class ex body] catch] + (` (_jvm_catch (~ (text$ class)) (~ (symbol$ ex)) (~ body)))))) + catches)) + (case finally + #;None + (list) + + (#;Some finally) + (list (` (_jvm_finally (~ finally)))))))))))) + +(defsyntax #export (definterface [name local-symbol^] [supers (tuple^ (*^ local-symbol^))] [members (*^ method-decl^)]) + (do Lux/Monad + [current-module get-module-name + #let [full-name (:: text;Text/Monoid (m;++ (text;replace "/" "." current-module) + name))]] + (let [members' (:: List/Functor (F;map (: (-> (, (List Text) Text (List Text) Text) Syntax) + (lambda [member] + (let [[modifiers name inputs output] member] + (` ((~ (symbol$ ["" name])) [(~@ (:: List/Functor (F;map text$ inputs)))] (~ (text$ output)) [(~@ (:: List/Functor (F;map text$ modifiers)))]))))) + members))] + (emit (list (` (_jvm_interface (~ (text$ full-name)) [(~@ (:: List/Functor (F;map text$ supers)))] + (~@ members')))))))) + +(defsyntax #export (defclass [name local-symbol^] [super local-symbol^] [interfaces (tuple^ (*^ local-symbol^))] + [fields (*^ field-decl^)] + [methods (*^ method-def^)]) + (do Lux/Monad + [current-module get-module-name + #let [full-name (:: text;Text/Monoid (m;++ (text;replace "/" "." current-module) + name)) + fields' (:: List/Functor (F;map (: (-> (, (List Text) Text Text) Syntax) + (lambda [field] + (let [[modifiers name class] field] + (` ((~ (symbol$ ["" name])) + (~ (text$ class)) + [(~@ (:: List/Functor (F;map text$ modifiers)))]))))) + fields)) + methods' (:: List/Functor (F;map (: (-> (, (List Text) Text (List (, Text Text)) Text Syntax) Syntax) + (lambda [methods] + (let [[modifiers name inputs output body] methods] + (` ((~ (symbol$ ["" name])) + [(~@ (:: List/Functor (F;map (: (-> (, Text Text) Syntax) + (lambda [in] + (let [[left right] in] + (form$ (list (text$ left) + (text$ right)))))) + inputs)))] + (~ (text$ output)) + [(~@ (:: List/Functor (F;map text$ modifiers)))] + (~ body)))))) + methods))]] + (emit (list (` (_jvm_class (~ (text$ full-name)) (~ (text$ super)) + [(~@ (:: List/Functor (F;map text$ interfaces)))] + [(~@ fields')] + [(~@ methods')])))))) + +(defsyntax #export (new [class local-symbol^] [arg-classes (tuple^ (*^ local-symbol^))] [args (tuple^ (*^ id^))]) + (emit (list (` (_jvm_new (~ (text$ class)) + [(~@ (:: List/Functor (F;map text$ arg-classes)))] + [(~@ args)]))))) + +(defsyntax #export (instance? [class local-symbol^] obj) + (emit (list (` (_jvm_instanceof (~ (text$ class)) (~ obj)))))) + +(defsyntax #export (locking lock body) + (do Lux/Monad + [g!lock (gensym "") + g!body (gensym "")] + (emit (list (` (;let [(~ g!lock) (~ lock) + _ (_jvm_monitor-enter (~ g!lock)) + (~ g!body) (~ body) + _ (_jvm_monitor-exit (~ g!lock))] + (~ g!body))))) + )) + +(defsyntax #export (null? obj) + (emit (list (` (_jvm_null? (~ obj)))))) + +(defsyntax #export (program [args symbol^] body) + (emit (list (` (_jvm_program (~ (symbol$ args)) + (~ body)))))) + +## (defsyntax #export (.? [field local-symbol^] obj) +## (case obj +## (#;Meta [_ (#;SymbolS obj-name)]) +## (do Lux/Monad +## [obj-type (find-var-type obj-name)] +## (case obj-type +## (#;DataT class) +## (do Lux/Monad +## [field-class (find-field field class)] +## (_jvm_getfield (~ (text$ class)) (~ (text$ field)) (~ (text$ field-class)))) + +## _ +## (fail "Can only get field from object."))) + +## _ +## (do Lux/Monad +## [g!obj (gensym "")] +## (emit (list (` (;let [(~ g!obj) (~ obj)] +## (.? (~ field) (~ g!obj))))))))) + +## (defsyntax #export (.= [field local-symbol^] value obj) +## (case obj +## (#;Meta [_ (#;SymbolS obj-name)]) +## (do Lux/Monad +## [obj-type (find-var-type obj-name)] +## (case obj-type +## (#;DataT class) +## (do Lux/Monad +## [field-class (find-field field class)] +## (_jvm_putfield (~ (text$ class)) (~ (text$ field)) (~ (text$ field-class)) (~ value))) + +## _ +## (fail "Can only set field of object."))) + +## _ +## (do Lux/Monad +## [g!obj (gensym "")] +## (emit (list (` (;let [(~ g!obj) (~ obj)] +## (.= (~ field) (~ value) (~ g!obj))))))))) + +## (defsyntax #export (.! [call method-call^] obj) +## (case obj +## (#;Meta [_ (#;SymbolS obj-name)]) +## (do Lux/Monad +## [obj-type (find-var-type obj-name)] +## (case obj-type +## (#;DataT class) +## (do Lux/Monad +## [#let [[m-name ?m-classes m-args] call] +## all-m-details (find-virtual-method m-name class) +## m-ins (case [?m-classes all-m-details] +## (\ [#;None (list [m-ins m-out])]) +## (M;wrap m-ins) + +## (\ [(#;Some m-ins) _]) +## (M;wrap m-ins) + +## _ +## #;None)] +## (emit (list (` (_jvm_invokevirtual (~ (text$ m-name)) (~ (text$ class)) [(~@ (:: List/Functor (F;map text$ m-ins)))] +## (~ obj) [(~@ m-args)]))))) + +## _ +## (fail "Can only call method on object."))) + +## _ +## (do Lux/Monad +## [g!obj (gensym "")] +## (emit (list (` (;let [(~ g!obj) (~ obj)] +## (.! (~@ *tokens*))))))))) + +## (defsyntax #export (..? [field local-symbol^] [class local-symbol^]) +## (emit (list (` (_jvm_getstatic (~ (text$ class)) (~ (text$ field))))))) + +## (defsyntax #export (..= [field local-symbol^] value [class local-symbol^]) +## (emit (list (` (_jvm_putstatic (~ (text$ class)) (~ (text$ field)) (~ value)))))) + +## (defsyntax #export (..! [call method-call^] [class local-symbol^]) +## (do Lux/Monad +## [#let [[m-name ?m-classes m-args] call] +## all-m-details (find-static-method m-name class) +## m-ins (case [?m-classes all-m-details] +## (\ [#;None (list [m-ins m-out])]) +## (M;wrap m-ins) + +## (\ [(#;Some m-ins) _]) +## (M;wrap m-ins) + +## _ +## #;None)] +## (emit (list (` (_jvm_invokestatic (~ (text$ m-name)) (~ (text$ class)) +## [(~@ (:: List/Functor (F;map text$ m-ins)))] +## [(~@ m-args)])))) +## )) + +## (definterface Function [] +## (#public #abstract apply [java.lang.Object] java.lang.Object)) + +## (_jvm_interface "Function" [] +## (apply ["java.lang.Object"] "java.lang.Object" ["public" "abstract"])) + +## (defclass MyFunction [Function] +## (#public #static foo java.lang.Object) +## (#public [] void +## (_jvm_invokespecial java.lang.Object [] this [])) +## (#public apply [(arg java.lang.Object)] java.lang.Object +## "YOLO")) + +## (_jvm_class "lux.MyFunction" "java.lang.Object" ["lux.Function"] +## [(foo "java.lang.Object" ["public" "static"])] +## ( [] "void" +## ["public"] +## (_jvm_invokespecial java.lang.Object [] this [])) +## (apply [(arg "java.lang.Object")] "java.lang.Object" +## ["public"] +## "YOLO")) diff --git a/source/lux/math.lux b/source/lux/math.lux new file mode 100644 index 000000000..2e29c5da7 --- /dev/null +++ b/source/lux/math.lux @@ -0,0 +1,60 @@ +## 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) + +## [Constants] +(do-template [ ] + [(def #export + Real + (_jvm_getstatic java.lang.Math ))] + + [e E] + [pi PI] + ) + +## [Functions] +(do-template [ ] + [(def #export ( n) + (-> Real Real) + (_jvm_invokestatic java.lang.Math [double] [n]))] + + [cos cos] + [sin sin] + [tan tan] + + [acos acos] + [asin asin] + [atan atan] + + [cosh cosh] + [sinh sinh] + [tanh tanh] + + [ceil ceil] + [floor floor] + [round round] + + [exp exp] + [log log] + + [cbrt cbrt] + [sqrt sqrt] + + [->degrees toDegrees] + [->radians toRadians] + ) + +(do-template [ ] + [(def #export ( x y) + (-> Real Real Real) + (_jvm_invokestatic java.lang.Math [double double] [x y]))] + + [atan2 atan2] + [pow pow] + ) 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)))))))) + )) diff --git a/source/lux/meta/macro.lux b/source/lux/meta/macro.lux new file mode 100644 index 000000000..22aeaf874 --- /dev/null +++ b/source/lux/meta/macro.lux @@ -0,0 +1,54 @@ +## 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) + +## [Utils] +(def (_meta x) + (-> (Syntax' (Meta Cursor)) Syntax) + (#;Meta [["" -1 -1] x])) + +## [Syntax] +(def #export (defmacro tokens state) + Macro + (case tokens + (#;Cons [(#;Meta [_ (#;FormS (#;Cons [name args]))]) (#;Cons [body #;Nil])]) + (#;Right [state (#;Cons [(` ((~ (_meta (#;SymbolS ["lux" "def"]))) ((~ name) (~@ args)) + (~ (_meta (#;SymbolS ["lux" "Macro"]))) + (~ body))) + (#;Cons [(` ((~ (_meta (#;SymbolS ["" "_lux_declare-macro"]))) (~ name))) + #;Nil])])]) + + (#;Cons [(#;Meta [_ (#;TagS ["" "export"])]) (#;Cons [(#;Meta [_ (#;FormS (#;Cons [name args]))]) (#;Cons [body #;Nil])])]) + (#;Right [state (#;Cons [(` ((~ (_meta (#;SymbolS ["lux" "def"]))) (~ (_meta (#;TagS ["" "export"]))) ((~ name) (~@ args)) + (~ (_meta (#;SymbolS ["lux" "Macro"]))) + (~ body))) + (#;Cons [(` ((~ (_meta (#;SymbolS ["" "_lux_declare-macro"]))) (~ name))) + #;Nil])])]) + + _ + (#;Left "Wrong syntax for defmacro"))) +(_lux_declare-macro defmacro) + +## [Functions] +(do-template [ ] + [(def #export ( x) + (-> Syntax) + (#;Meta [["" -1 -1] ( x)]))] + + [bool$ Bool #;BoolS] + [int$ Int #;IntS] + [real$ Real #;RealS] + [char$ Char #;CharS] + [text$ Text #;TextS] + [symbol$ Ident #;SymbolS] + [tag$ Ident #;TagS] + [form$ (List Syntax) #;FormS] + [tuple$ (List Syntax) #;TupleS] + [record$ (List (, Syntax Syntax)) #;RecordS] + ) diff --git a/source/lux/meta/syntax.lux b/source/lux/meta/syntax.lux new file mode 100644 index 000000000..1fe85c32f --- /dev/null +++ b/source/lux/meta/syntax.lux @@ -0,0 +1,262 @@ +## 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 #as m #refer #all) + (lux #as l #refer (#only Lux/Monad gensym))) + (lux (control (functor #as F) + (monad #as M #refer (#only do))) + (data (eq #as E) + (bool #as b) + (char #as c) + (text #as t) + list))) + +## [Utils] +(def (first xy) + (All [a b] (-> (, a b) a)) + (let [[x y] xy] + x)) + +(def (join-pairs pairs) + (All [a] (-> (List (, a a)) (List a))) + (case pairs + #;Nil #;Nil + (#;Cons [[x y] pairs']) (list& x y (join-pairs pairs')))) + +## Types +(deftype #export (Parser a) + (-> (List Syntax) (Maybe (, (List Syntax) a)))) + +## Structures +(defstruct #export Parser/Functor (F;Functor Parser) + (def (F;map f ma) + (lambda [tokens] + (case (ma tokens) + #;None + #;None + + (#;Some [tokens' a]) + (#;Some [tokens' (f a)]))))) + +(defstruct #export Parser/Monad (M;Monad Parser) + (def M;_functor Parser/Functor) + + (def (M;wrap x tokens) + (#;Some [tokens x])) + + (def (M;join mma) + (lambda [tokens] + (case (mma tokens) + #;None + #;None + + (#;Some [tokens' ma]) + (ma tokens'))))) + +## Parsers +(def #export (id^ tokens) + (Parser Syntax) + (case tokens + #;Nil #;None + (#;Cons [t tokens']) (#;Some [tokens' t]))) + +(do-template [ ] + [(def #export ( tokens) + (Parser ) + (case tokens + (#;Cons [(#;Meta [_ ( x)]) tokens']) + (#;Some [tokens' x]) + + _ + #;None))] + + [ bool^ Bool #;BoolS] + [ int^ Int #;IntS] + [ real^ Real #;RealS] + [ char^ Char #;CharS] + [ text^ Text #;TextS] + [symbol^ Ident #;SymbolS] + [ tag^ Ident #;TagS] + ) + +(do-template [ ] + [(def #export ( tokens) + (Parser Text) + (case tokens + (#;Cons [(#;Meta [_ ( ["" x])]) tokens']) + (#;Some [tokens' x]) + + _ + #;None))] + + [local-symbol^ #;SymbolS] + [ local-tag^ #;TagS] + ) + +(def (ident:= x y) + (-> Ident Ident Bool) + (let [[x1 x2] x + [y1 y2] y] + (and (text:= x1 y1) + (text:= x2 y2)))) + +(do-template [ ] + [(def #export ( v tokens) + (-> (Parser (,))) + (case tokens + (#;Cons [(#;Meta [_ ( x)]) tokens']) + (if ( v x) + (#;Some [tokens' []]) + #;None) + + _ + #;None))] + + [ bool?^ Bool #;BoolS (:: b;Bool/Eq E;=)] + [ int?^ Int #;IntS i=] + [ real?^ Real #;RealS r=] + [ char?^ Char #;CharS (:: c;Char/Eq E;=)] + [ text?^ Text #;TextS (:: t;Text/Eq E;=)] + [symbol?^ Ident #;SymbolS ident:=] + [ tag?^ Ident #;TagS ident:=] + ) + +(do-template [ ] + [(def #export ( p tokens) + (All [a] + (-> (Parser a) (Parser a))) + (case tokens + (#;Cons [(#;Meta [_ ( form)]) tokens']) + (case (p form) + (#;Some [#;Nil x]) (#;Some [tokens' x]) + _ #;None) + + _ + #;None))] + + [ form^ #;FormS] + [tuple^ #;TupleS] + ) + +(def #export (?^ p tokens) + (All [a] + (-> (Parser a) (Parser (Maybe a)))) + (case (p tokens) + #;None (#;Some [tokens #;None]) + (#;Some [tokens' x]) (#;Some [tokens' (#;Some x)]))) + +(def (run-parser p tokens) + (All [a] + (-> (Parser a) (List Syntax) (Maybe (, (List Syntax) a)))) + (p tokens)) + +(def #export (*^ p tokens) + (All [a] + (-> (Parser a) (Parser (List a)))) + (case (p tokens) + #;None (#;Some [tokens (list)]) + (#;Some [tokens' x]) (run-parser (do Parser/Monad + [xs (*^ p)] + (M;wrap (list& x xs))) + tokens'))) + +(def #export (+^ p) + (All [a] + (-> (Parser a) (Parser (List a)))) + (do Parser/Monad + [x p + xs (*^ p)] + (M;wrap (list& x xs)))) + +(def #export (&^ p1 p2) + (All [a b] + (-> (Parser a) (Parser b) (Parser (, a b)))) + (do Parser/Monad + [x1 p1 + x2 p2] + (M;wrap [x1 x2]))) + +(def #export (|^ p1 p2 tokens) + (All [a b] + (-> (Parser a) (Parser b) (Parser (Either b)))) + (case (p1 tokens) + (#;Some [tokens' x1]) (#;Some [tokens' (#;Left x1)]) + #;None (run-parser (do Parser/Monad + [x2 p2] + (M;wrap (#;Right x2))) + tokens))) + +(def #export (||^ ps tokens) + (All [a] + (-> (List (Parser a)) (Parser (Maybe a)))) + (case ps + #;Nil #;None + (#;Cons [p ps']) (case (p tokens) + #;None (||^ ps' tokens) + (#;Some [tokens' x]) (#;Some [tokens' (#;Some x)])) + )) + +(def #export (end^ tokens) + (Parser (,)) + (case tokens + #;Nil (#;Some [tokens []]) + _ #;None)) + +## Syntax +(defmacro #export (defsyntax tokens) + (let [[exported? tokens] (: (, Bool (List Syntax)) + (case tokens + (\ (list& (#;Meta [_ (#;TagS ["" "export"])]) tokens')) + [true tokens'] + + _ + [false tokens]))] + (case tokens + (\ (list (#;Meta [_ (#;FormS (list& (#;Meta [_ (#;SymbolS ["" name])]) args))]) + body)) + (do Lux/Monad + [names+parsers (M;map% Lux/Monad + (: (-> Syntax (Lux (, Syntax Syntax))) + (lambda [arg] + (case arg + (\ (#;Meta [_ (#;TupleS (list (#;Meta [_ (#;SymbolS var-name)]) + parser))])) + (M;wrap [(symbol$ var-name) parser]) + + (\ (#;Meta [_ (#;SymbolS var-name)])) + (M;wrap [(symbol$ var-name) (` id^)]) + + _ + (l;fail "Syntax pattern expects 2-tuples or symbols.")))) + args) + g!tokens (gensym "tokens") + g!_ (gensym "_") + #let [names (:: List/Functor (F;map first names+parsers)) + error-msg (text$ (text:++ "Wrong syntax for " name)) + body' (foldL (: (-> Syntax (, Syntax Syntax) Syntax) + (lambda [body name+parser] + (let [[name parser] name+parser] + (` (_lux_case ((~ parser) (~ g!tokens)) + (#;Some [(~ g!tokens) (~ name)]) + (~ body) + + (~ g!_) + (l;fail (~ error-msg))))))) + body + (reverse names+parsers)) + macro-def (: Syntax + (` (m;defmacro ((~ (symbol$ ["" name])) (~ g!tokens)) + (~ body'))))]] + (M;wrap (list& macro-def + (if exported? + (list (` (_lux_export (~ (symbol$ ["" name]))))) + (list))))) + + _ + (l;fail "Wrong syntax for defsyntax")))) diff --git a/source/program.lux b/source/program.lux new file mode 100644 index 000000000..052c0bf41 --- /dev/null +++ b/source/program.lux @@ -0,0 +1,48 @@ +## 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 + (lux (codata (stream #as S)) + (control monoid + functor + monad + lazy + comonad) + (data bool + bounded + char + ## cont + dict + (either #as e) + eq + error + id + io + list + maybe + number + ord + (reader #as r) + show + state + (text #as t) + writer) + (host java) + (meta lux + macro + syntax) + (math #as m) + )) + +(program args + (case args + #;Nil + (println "Hello, world!") + + (#;Cons [name _]) + (println ($ text:++ "Hello, " name "!")))) diff --git a/src/lux.clj b/src/lux.clj index 7ff8fda37..9c913c9ac 100644 --- a/src/lux.clj +++ b/src/lux.clj @@ -14,9 +14,7 @@ :reload-all)) (defn -main [& _] - (do (time (&compiler/compile-all (&/|list "lux" "program"))) - ;; (prn @&type/counter) - ) + (time (&compiler/compile-all (&/|list "lux" "program"))) (System/exit 0)) (comment diff --git a/src/lux/analyser/host.clj b/src/lux/analyser/host.clj index 68bd627fc..e490bc62f 100644 --- a/src/lux/analyser/host.clj +++ b/src/lux/analyser/host.clj @@ -117,9 +117,9 @@ (defn analyse-jvm-invokestatic [analyse ?class ?method ?classes ?args] (|do [=classes (&/map% &host/extract-jvm-param ?classes) =return (&host/lookup-static-method ?class ?method =classes) - :let [_ (matchv ::M/objects [=return] - [["lux;DataT" _return-class]] - (prn 'analyse-jvm-invokestatic ?class ?method _return-class))] + ;; :let [_ (matchv ::M/objects [=return] + ;; [["lux;DataT" _return-class]] + ;; (prn 'analyse-jvm-invokestatic ?class ?method _return-class))] =args (&/map2% (fn [_class _arg] (&&/analyse-1 analyse (&/V "lux;DataT" _class) _arg)) =classes diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj index 6acae193f..b25dff9eb 100644 --- a/src/lux/analyser/lux.clj +++ b/src/lux/analyser/lux.clj @@ -394,7 +394,7 @@ (return nil))] (&/save-module (|do [already-compiled? (&&module/exists? ?path) - :let [_ (prn 'analyse-import module-name ?path already-compiled?)] + ;; :let [_ (prn 'analyse-import module-name ?path already-compiled?)] _ (&&module/add-import ?path) _ (&/when% (not already-compiled?) (compile-module ?path))] (return (&/|list)))))) diff --git a/src/lux/compiler.clj b/src/lux/compiler.clj index 05ab12bf1..bb1c72f66 100644 --- a/src/lux/compiler.clj +++ b/src/lux/compiler.clj @@ -24,6 +24,7 @@ [lux.analyser.base :as &a] [lux.analyser.module :as &a-module] (lux.compiler [base :as &&] + [cache :as &&cache] [lux :as &&lux] [host :as &&host] [case :as &&case] @@ -369,12 +370,12 @@ return)))) (defn ^:private compile-module [name] - ;; (prn 'compile-module name (&&/cached? name)) - (let [file-name (str "input/" name ".lux") + ;; (prn 'compile-module name (&&cache/cached? name)) + (let [file-name (str &&/input-dir "/" name ".lux") file-content (slurp file-name) file-hash (hash file-content)] - (if (&&/cached? name) - (&&/load-cache name file-hash compile-module) + (if (&&cache/cached? name) + (&&cache/load name file-hash compile-module) (let [compiler-step (|do [analysis+ (&optimizer/optimize eval! compile-module)] (&/map% compile-statement analysis+))] (|do [module-exists? (&a-module/exists? name)] @@ -416,31 +417,16 @@ (fail* ?message))))))) ))) -(defn ^:private clean-file [^java.io.File file] - (if (.isDirectory file) - (do (doseq [f (seq (.listFiles file))] - (clean-file f)) - (.delete file)) - (.delete file))) - -(defn ^:private setup-dirs! [] - (.mkdir (java.io.File. "cache")) - (.mkdir (java.io.File. "cache/jvm")) - (.mkdir (java.io.File. "output")) - (.mkdir (java.io.File. "output/jvm")) - (doseq [f (seq (.listFiles (java.io.File. "output/jvm")))] - (clean-file f))) +(defn ^:private init! [] + (.mkdirs (java.io.File. &&/output-dir))) ;; [Resources] (defn compile-all [modules] - (setup-dirs!) + (init!) (matchv ::M/objects [((&/map% compile-module modules) (&/init-state nil))] [["lux;Right" [?state _]]] - (println "Compilation complete!") + (do (println "Compilation complete!") + (&&cache/clean ?state)) [["lux;Left" ?message]] (assert false ?message))) - -(comment - (compile-all ["lux"]) - ) diff --git a/src/lux/compiler/base.clj b/src/lux/compiler/base.clj index d3dfc8746..e7b338b16 100644 --- a/src/lux/compiler/base.clj +++ b/src/lux/compiler/base.clj @@ -25,43 +25,28 @@ FileOutputStream) (java.lang.reflect Field))) +;; [Constants] +(def ^String version "0.2") +(def ^String input-dir "source") +(def ^String output-dir "target/jvm") + +(def ^String local-prefix "l") +(def ^String partial-prefix "p") +(def ^String closure-prefix "c") +(def ^String apply-signature "(Ljava/lang/Object;)Ljava/lang/Object;") + ;; [Utils] (defn ^:private write-file [^String file ^bytes data] (with-open [stream (BufferedOutputStream. (FileOutputStream. file))] (.write stream data))) (defn ^:private write-output [module name data] - (let [module* (&host/->module-class module)] - (.mkdirs (File. (str "output/jvm/" module*))) - (write-file (str "output/jvm/" module* "/" name ".class") data))) - -(defn ^:private write-cache [module name data] - (let [module* (&host/->module-class module)] - (.mkdirs (File. (str "cache/jvm/" module*))) - (write-file (str "cache/jvm/" module* "/" name ".class") data))) - -(defn ^:private clean-file [^File file] - (if (.isDirectory file) - (do (doseq [f (seq (.listFiles file))] - (clean-file f)) - (.delete file)) - (.delete file))) - -(defn ^:private read-file [^File file] - (with-open [reader (io/input-stream file)] - (let [length (.length file) - buffer (byte-array length)] - (.read reader buffer 0 length) - buffer))) + (let [module* (&host/->module-class module) + module-dir (str output-dir "/" module*)] + (.mkdirs (File. module-dir)) + (write-file (str module-dir "/" name ".class") data))) ;; [Exports] -(def version "0.2") - -(def local-prefix "l") -(def partial-prefix "p") -(def closure-prefix "c") -(def apply-signature "(Ljava/lang/Object;)Ljava/lang/Object;") - (defn load-class! [^ClassLoader loader name] ;; (prn 'load-class! name) (.loadClass loader name)) @@ -75,104 +60,5 @@ _ (swap! !classes assoc real-name bytecode) _ (load-class! loader real-name) _ (when (not eval?) - (do (write-output module name bytecode) - (write-cache module name bytecode)))]] + (write-output module name bytecode))]] (return nil))) - -(defn cached? [module] - (.exists (File. (str "cache/jvm/" (&host/->module-class module) "/_.class")))) - -(defn delete-cache [module] - (fn [state] - (do (clean-file (File. (str "cache/jvm/" (&host/->module-class module)))) - (return* state nil)))) - -(defn ^:private replace-several [content & replacements] - (let [replacement-list (partition 2 replacements)] - (reduce #(try (let [[_pattern _rep] %2] - (string/replace %1 _pattern (string/re-quote-replacement _rep))) - (catch Exception e - (prn 'replace-several content %1 %2) - (throw e))) - content replacement-list))) - -(defn ^:private get-field [^String field-name ^Class class] - (-> class ^Field (.getField field-name) (.get nil)) - ;; (try (-> class ^Field (.getField field-name) (.get nil)) - ;; (catch Error e - ;; (assert false (prn-str 'get-field field-name class)))) - ) - -(defn load-cache [module module-hash compile-module] - (|do [loader &/loader - !classes &/classes - already-loaded? (&a-module/exists? module) - _modules &/modules - :let [redo-cache (|do [_ (delete-cache module) - _ (compile-module module)] - (return false))]] - (do (prn 'load-cache module 'sources already-loaded? - (&/->seq _modules)) - (if already-loaded? - (return true) - (if (cached? module) - (do (prn 'load-cache/HASH module module-hash) - (let [module* (&host/->module-class module) - module-path (str "cache/jvm/" module*) - class-name (str module* "._") - ^Class module-meta (do (swap! !classes assoc class-name (read-file (File. (str module-path "/_.class")))) - (load-class! loader class-name))] - (if (and (= module-hash (get-field "_hash" module-meta)) - (= version (get-field "_compiler" module-meta))) - (let [imports (string/split (-> module-meta (.getField "_imports") (.get nil)) #"\t") - _ (prn 'load-cache/IMPORTS module imports) - ] - (|do [loads (&/map% (fn [_import] - (load-cache _import (-> (str "input/" _import ".lux") slurp hash) compile-module)) - (if (= [""] imports) - (&/|list) - (&/->list imports)))] - (if (->> loads &/->seq (every? true?)) - (do (doseq [^File file (seq (.listFiles (File. module-path))) - :let [file-name (.getName file)] - :when (not= "_.class" file-name)] - (let [real-name (second (re-find #"^(.*)\.class$" file-name)) - bytecode (read-file file) - ;; _ (prn 'load-cache module real-name) - ] - (swap! !classes assoc (str module* "." real-name) bytecode) - (write-output module real-name bytecode))) - (let [defs (string/split (get-field "_defs" module-meta) #"\t")] - ;; (prn 'load-cache module defs) - (|do [_ (&a-module/enter-module module) - _ (&/map% (fn [_def] - (let [[_exported? _name _ann] (string/split _def #" ") - ;; _ (prn '[_exported? _name _ann] [_exported? _name _ann]) - ] - (|do [_ (case _ann - "T" (&a-module/define module _name (&/V "lux;TypeD" nil) &type/Type) - "M" (|do [_ (&a-module/define module _name (&/V "lux;ValueD" &type/Macro) &type/Macro)] - (&a-module/declare-macro module _name)) - "V" (let [def-class (load-class! loader (str module* "." (&/normalize-name _name))) - ;; _ (println "Fetching _meta" module _name (str module* "." (&/normalize-name _name)) def-class) - def-type (get-field "_meta" def-class)] - (matchv ::M/objects [def-type] - [["lux;ValueD" _def-type]] - (&a-module/define module _name def-type _def-type))) - ;; else - (let [[_ __module __name] (re-find #"^A(.*);(.*)$" _ann)] - (|do [__type (&a-module/def-type __module __name)] - (do ;; (prn '__type [__module __name] (&type/show-type __type)) - (&a-module/def-alias module _name __module __name __type)))))] - (if (= "1" _exported?) - (&a-module/export module _name) - (return nil))) - )) - (if (= [""] defs) - (&/|list) - (&/->list defs)))] - (return true)))) - redo-cache))) - redo-cache) - )) - redo-cache))))) diff --git a/src/lux/compiler/cache.clj b/src/lux/compiler/cache.clj new file mode 100644 index 000000000..d6f0b1db7 --- /dev/null +++ b/src/lux/compiler/cache.clj @@ -0,0 +1,135 @@ +;; 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. + +(ns lux.compiler.cache + (:refer-clojure :exclude [load]) + (:require [clojure.string :as string] + [clojure.java.io :as io] + [clojure.core.match :as M :refer [matchv]] + clojure.core.match.array + (lux [base :as & :refer [|do return* return fail fail*]] + [type :as &type] + [host :as &host]) + (lux.analyser [base :as &a] + [module :as &a-module]) + (lux.compiler [base :as &&])) + (:import (java.io File + BufferedOutputStream + FileOutputStream) + (java.lang.reflect Field))) + +;; [Utils] +(defn ^:private read-file [^File file] + (with-open [reader (io/input-stream file)] + (let [length (.length file) + buffer (byte-array length)] + (.read reader buffer 0 length) + buffer))) + +(defn ^:private clean-file [^File file] + (if (.isDirectory file) + (do (doseq [f (seq (.listFiles file))] + (clean-file f)) + (.delete file)) + (.delete file))) + +(defn ^:private get-field [^String field-name ^Class class] + (-> class ^Field (.getField field-name) (.get nil))) + +;; [Resources] +(defn cached? [module] + "(-> Text Bool)" + (.exists (new File (str &&/output-dir "/" (&host/->module-class module) "/_.class")))) + +(defn delete [module] + "(-> Text (Lux (,)))" + (fn [state] + (do (clean-file (new File (str &&/output-dir "/" (&host/->module-class module)))) + (return* state nil)))) + +(defn clean [state] + "(-> Compiler (,))" + (let [needed-modules (->> state (&/get$ &/$MODULES) &/|keys &/->seq set) + outdated? #(-> % .getName (string/replace " " "/") (->> (contains? needed-modules)) not) + outdate-files (->> &&/output-dir (new File) .listFiles seq (filter outdated?))] + (doseq [f outdate-files] + (clean-file f)) + nil)) + +(defn load [module module-hash compile-module] + (|do [loader &/loader + !classes &/classes + already-loaded? (&a-module/exists? module) + _modules &/modules + :let [redo-cache (|do [_ (delete module) + _ (compile-module module)] + (return false))]] + (do ;; (prn 'load module 'sources already-loaded? + ;; (&/->seq _modules)) + (if already-loaded? + (return true) + (if (cached? module) + (do ;; (prn 'load/HASH module module-hash) + (let [module* (&host/->module-class module) + module-path (str &&/output-dir "/" module*) + class-name (str module* "._") + ^Class module-meta (do (swap! !classes assoc class-name (read-file (File. (str module-path "/_.class")))) + (&&/load-class! loader class-name))] + (if (and (= module-hash (get-field "_hash" module-meta)) + (= &&/version (get-field "_compiler" module-meta))) + (let [imports (string/split (-> module-meta (.getField "_imports") (.get nil)) #"\t") + ;; _ (prn 'load/IMPORTS module imports) + ] + (|do [loads (&/map% (fn [_import] + (load _import (-> (str &&/input-dir "/" _import ".lux") slurp hash) compile-module)) + (if (= [""] imports) + (&/|list) + (&/->list imports)))] + (if (->> loads &/->seq (every? true?)) + (do (doseq [^File file (seq (.listFiles (File. module-path))) + :let [file-name (.getName file)] + :when (not= "_.class" file-name)] + (let [real-name (second (re-find #"^(.*)\.class$" file-name)) + bytecode (read-file file) + ;; _ (prn 'load module real-name) + ] + (swap! !classes assoc (str module* "." real-name) bytecode))) + (let [defs (string/split (get-field "_defs" module-meta) #"\t")] + ;; (prn 'load module defs) + (|do [_ (&a-module/enter-module module) + _ (&/map% (fn [_def] + (let [[_exported? _name _ann] (string/split _def #" ") + ;; _ (prn '[_exported? _name _ann] [_exported? _name _ann]) + ] + (|do [_ (case _ann + "T" (&a-module/define module _name (&/V "lux;TypeD" nil) &type/Type) + "M" (|do [_ (&a-module/define module _name (&/V "lux;ValueD" &type/Macro) &type/Macro)] + (&a-module/declare-macro module _name)) + "V" (let [def-class (&&/load-class! loader (str module* "." (&/normalize-name _name))) + ;; _ (println "Fetching _meta" module _name (str module* "." (&/normalize-name _name)) def-class) + def-type (get-field "_meta" def-class)] + (matchv ::M/objects [def-type] + [["lux;ValueD" _def-type]] + (&a-module/define module _name def-type _def-type))) + ;; else + (let [[_ __module __name] (re-find #"^A(.*);(.*)$" _ann)] + (|do [__type (&a-module/def-type __module __name)] + (do ;; (prn '__type [__module __name] (&type/show-type __type)) + (&a-module/def-alias module _name __module __name __type)))))] + (if (= "1" _exported?) + (&a-module/export module _name) + (return nil))) + )) + (if (= [""] defs) + (&/|list) + (&/->list defs)))] + (return true)))) + redo-cache))) + redo-cache) + )) + redo-cache))))) -- cgit v1.2.3