diff options
59 files changed, 7920 insertions, 4622 deletions
diff --git a/.gitignore b/.gitignore index fdc7212fc..9c8887842 100644 --- a/.gitignore +++ b/.gitignore @@ -10,3 +10,5 @@ pom.xml.asc LICENSE README.md doc/intro.md +/jbe + @@ -5,37 +5,34 @@ It's meant to be a functional, statically-typed Lisp that will run on several pl ### What's the current version? -v0.1 +v0.2 ### How far ahead is the project? -The Java-bytecode compiler is close to completion. +The Java-bytecode compiler is almost complete. -Some features are missing and the compiler is not as fast as I would like. +A few features are missing and the compiler is not as fast as I would like. -However, some small programs can be written to try out Lux and get a feeling for the language. +However, programs can be written to try out Lux and get a feeling for the language. ### How can I use it? -Download the 0.1 compiler from here: https://github.com/LuxLang/lux/releases/download/0.1.0/lux-jvm-0.1.0-standalone.jar +Download the 0.2 compiler from here: https://github.com/LuxLang/lux/releases/download/0.2.0/lux-jvm-0.2.0-standalone.jar -Right now, the current version of Lux (0.1) is mostly to play around with the language, so it's a bit limited on what you can do. Once you download the compiler, you'll want to create a directory named "source" in the same directory where the compiler is located. -"source" must contain 2 files. -One will be the Lux prelude (lux.lux), the other will be program.lux -You can write anything you want inside program.lux to play around with the language. +You can run the compiler like this: -##### Note: You can download the lux.lux & program.lux files in the source/ directory in this repo to get started. + java -jar -Xss4m lux-jvm-0.2.0-standalone.jar program -To run the compiler, open your terminal and write this: +The **program** module is already inside **source/** to make it easier to start. - java -jar lux-jvm-0.1.0-standalone.jar +##### Note: You can download all the files inside the source/ directory in this repo to get started. -This will generate a directory named "output" and put all the .class files there. -Then, you can package the program and run it using this: +This will generate a directory named "target" and put all the .class files there. +Then, you can run the program like this: - cd output && jar cvf program.jar * && java -cp "program.jar" program && cd .. + cd target/jvm/ && java -jar program.jar ### What's the license? @@ -87,7 +84,7 @@ Functions are curried and partial application is as simple as just applying a fu e.g. - (let [inc (int:+ 1)] + (let [inc (i+ 1)] (map inc (list 1 2 3 4 5))) ### Code portability @@ -105,15 +102,11 @@ The mechanism hasn't been added yet to the language (mainly because there's only ### Macros Unlike in most other lisps, Lux macros are monadic. -The **(Lux a)** type is the one responsibly for the magic by treading **CompilerState** instances through macros. +The **(Lux a)** type is the one responsibly for the magic by treading **Compiler** instances through macros. Macros must have the **Macro** type and then be declared as macros. However, just using the **defmacro** macro will take care of it for you. - -Also, in an upcoming release you'll get another macro for defining macros. -It will be named **defsyntax** and will use monadic parsing of AST tokens to parse the syntax. - -If you want to see how macros are implemented, you can take a look at *lux.lux*. +Alternatively, you can use the **defsyntax** macro, which also offers monadic parsing of AST tokens for convenience. ### Custom pattern-matching @@ -176,639 +169,9 @@ If you want to communicate with me directly, just email me at luxlisp@gmail.com Check out the Emacs plugin for it: https://github.com/LuxLang/lux-mode -## What's available? - -### Base syntax - -Comments - - ## This is a single-line comment - ## Multi-line comments are comming soon - -Bool (implemented as java.lang.Boolean) - - true - false - -Int (implemented as java.lang.Long) - - 1 - -20 - 12345 - -Real (implemented as java.lang.Double) - - 1.23 - -0.5 - -Char (implemented as java.lang.Character) - - #"a" - #"\n" - -Text (implemented as java.lang.String) - - "yolo" - "Hello\tWorld!" - -Forms - - (+ 1 2) - (lambda [x] (foo 10 x)) - -Symbols - - foo ## Unprefixed symbol (compiler will assume it's in the current module) - bar;baz ## Prefixed symbol (compiler will assume it's in the module specified by the prefix) - ;fold ## With just the semi-colon, compiler wil assume it's the same as lux;fold - ;;quux ## With 2 semi-colons, it will get automatically prefixed with the current-module - -Tags - - #Nil - #lux;Cons - #;Some - #;;MyTag - -Tuples - - [] - ["yolo" 10 true] - -Variants (aka sum-types, aka discriminated unions) - - #Nil - (#Cons [10 #Nil]) - -Records - - {#name "Lux" #awesome? true} - -### Types - (deftype Bool (^ java.lang.Boolean)) - - (deftype Int (^ java.lang.Long)) - - (deftype Real (^ java.lang.Double)) - - (deftype Char (^ java.lang.Character)) - - (deftype Text (^ java.lang.String)) - - (deftype Void (|)) - - (deftype Ident (, Text Text)) - - (deftype (List a) - (| #Nil - (#Cons (, a (List a))))) - - (deftype (Maybe a) - (| #None - (#Some a))) - - (deftype #rec Type - (| (#DataT Text) ## Host data-type - (#TupleT (List Type)) ## Tuple types - (#VariantT (List (, Text Type))) ## Sum-types - (#RecordT (List (, Text Type))) ## Records - (#LambdaT (, Type Type)) ## Function-types - (#BoundT Text) - (#VarT Int) ## Type variables - (#ExT Int) ## Existential types - (#AllT (, (Maybe (List (, Text Type))) ## Polymorphic types - Text Text Type)) - (#AppT (, Type Type)))) ## Application of polymorphic types - - (deftype (Meta m d) - (| (#Meta (, m d)))) - - (deftype Syntax ...) - - (deftype (Either l r) - (| (#Left l) - (#Right r))) - - (deftype Reader ...) - - (deftype LuxVar ...) - - (deftype CompilerState ...) - - (deftype (Lux a) - (-> CompilerState (Either Text (, CompilerState a)))) - - (deftype Macro - (-> (List Syntax) (Lux (List Syntax)))) - - (deftype (IO a) - (-> (,) a)) - -### Macros -###### defmacro -e.g. - - (defmacro #export (and tokens) - (case (reverse tokens) - (\ (list& last init)) - (return (: (List Syntax) - (list (fold (: (-> Syntax Syntax Syntax) - (lambda [post pre] - (` (if (~ pre) - true - (~ post))))) - last - init)))) - - _ - (fail "and requires >=1 clauses."))) - -###### comment -e.g. - - (comment 1 2 3 4) ## Same as not writing anything... - -###### list -e.g. - - (list 1 2 3) - => (#Cons [1 (#Cons [2 (#Cons [3 #Nil])])]) - -###### list& -e.g. - - (list& 0 (list 1 2 3)) - => (#Cons [0 (list 1 2 3)]) - -###### lambda -e.g. - - (def const - (lambda [x y] x)) - - (def const - (lambda const [x y] x)) - -###### let -e.g. - - (let [x (foo bar) - y (baz quux)] - ...) - -###### $ -e.g. - - ## Application of binary functions over variadic arguments. - ($ text:++ "Hello, " name ".\nHow are you?") - => (text:++ "Hello, " (text:++ name ".\nHow are you?")) - -###### |> -e.g. - - ## Piping - (|> elems (map ->text) (interpose " ") (fold text:++ "")) - => - (fold text:++ "" - (interpose " " - (map ->text elems))) - -###### if -e.g. - - (if true - "Oh, yeah!" - "Aw hell naw!") - -###### ^ -e.g. - - ## Macro to treat classes as types - (^ java.lang.Object) - -###### , -e.g. - - ## Tuples - (, Text Int Bool) - - (,) ## The empty tuple, aka "unit" - -###### | -e.g. - - (| #Yes #No) - - (|) ## The empty variant, aka "void" - -###### & -e.g. - - ## Records - (& #name Text - #age Int - #alive? Bool) - -###### -> -e.g. - - ## Function types - (-> Int Int Int) ## This is the type of a function that takes 2 Ints and returns an Int - -###### All -e.g. - - ## Universal quantification. - (All List [a] - (| #Nil - (#Cons (, a (List a))))) - - ## It must be explicit, unlike in Haskell. - ## Rank-n types will be possible as well as existential types - (All [a] - (-> a a)) - -###### type` - - ## This macro is not meant to be used directly. It's used by :, :!, deftype, struct, sig - -###### io - - ## Just makes sure whatever computation you do returns an IO type. It's here mostly for host-interop. - (io (println "Hello, World!")) - -###### : -e.g. - - ## The type-annotation macro - (: (List Int) (list 1 2 3)) - -###### :! -e.g. - - ## The type-coercion macro - (:! Dinosaur (list 1 2 3)) - -###### deftype -e.g. - - ## The type-definition macro - (deftype (List a) - (| #Nil - (#Cons (, a (List a))))) - -###### exec -e.g. - - ## Sequential execution of expressions (great for side-effects). - ## But please use the io macro to help keep the purity. - (io (exec - (println "#1") - (println "#2") - (println "#3") - "YOLO")) - -###### def -e.g. - - ## Macro for definining global constants/functions. - (def (rejoin-pair pair) - (-> (, Syntax Syntax) (List Syntax)) - (let [[left right] pair] - (list left right))) - -###### case -e.g. - - ## The pattern-matching macro. - ## Allows the usage of macros within the patterns to provide custom syntax. - (case (: (List Int) (list 1 2 3)) - (#Cons [x (#Cons [y (#Cons [z #Nil])])]) - (#Some ($ int:* x y z)) - - _ - #None) - - (case (: (List Int) (list 1 2 3)) - (\ (list x y z)) - (#Some ($ int:* x y z)) - - _ - #None) - - (deftype Weekday - (| #Monday - #Tuesday - #Wednesday - #Thursday - #Friday - #Saturday - #Sunday)) - - (def (weekend? day) - (-> Weekday Bool) - (case day - (\or #Saturday #Sunday) - true - - _ - false)) - -###### \ - - ## It's a special macro meant to be used with case - -###### \or - - ## It's a special macro meant to be used with case - -###### ` - - ## Quasi-quotation as a macro. Unquote (~) and unquote-splice (~@) must also be used as forms - e.g. - (` (def (~ name) - (lambda [(~@ args)] - (~ body)))) - -###### sig - - ## Not mean to be used directly. Prefer defsig - -###### struct - - ## Not mean to be used directly. Prefer defstruct - -###### defsig -e.g. - - ## Definition of signatures ala ML - (defsig #export (Ord a) - (: (-> a a Bool) - <) - (: (-> a a Bool) - <=) - (: (-> a a Bool) - >) - (: (-> a a Bool) - >=)) - -###### defstruct -e.g. - - ## Definition of structures ala ML - (defstruct #export Int:Ord (Ord Int) - (def (< x y) - (jvm-llt x y)) - (def (<= x y) - (or (jvm-llt x y) - (jvm-leq x y))) - (def (> x y) - (jvm-lgt x y)) - (def (>= x y) - (or (jvm-lgt x y) - (jvm-leq x y)))) - -###### and -e.g. - - (and true false true) ## => false - -###### or -e.g. - - (or true false true) ## => true - -###### alias-lux - - ## Just creates local aliases of everything defined & exported in lux.lux -e.g. - - (;alias-lux) - -###### using -e.g. - - ## The Lux equivalent to ML's open. - ## Opens up a structure and provides all the definitions as local variables. - (using Int:Ord - (< 5 10)) - -### Functions -###### fold - - (All [a b] - (-> (-> a b a) a (List b) a)) - - (fold text:++ "" (list "Hello, " "World!")) - => "Hello, World!" - -###### reverse - - (All [a] - (-> (List a) (List a))) - - (reverse (list 1 2 3)) - => (list 3 2 1) - -###### map - - (All [a b] - (-> (-> a b) (List a) (List b))) - - (map (int:+ 1) (list 1 2 3)) - => (list 2 3 4) - -###### any? - - (All [a] - (-> (-> a Bool) (List a) Bool)) - - (any? even? (list 1 2 3)) - => true - -###### . - - ## Function composition: (. f g) => (lambda [x] (f (g x))) - (All [a b c] - (-> (-> b c) (-> a b) (-> a c))) - -###### int:+ - - (-> Int Int Int) - -###### int:- - - (-> Int Int Int) - -###### int:* - - (-> Int Int Int) - -###### int:/ - - (-> Int Int Int) - -###### int:% - - (-> Int Int Int) - -###### int:= - - (-> Int Int Bool) - -###### int:> - - (-> Int Int Bool) - -###### int:< - - (-> Int Int Bool) - -###### real:+ - - (-> Real Real Real) - -###### real:- - - (-> Real Real Real) - -###### real:* - - (-> Real Real Real) - -###### real:/ - - (-> Real Real Real) - -###### real:% - - (-> Real Real Real) - -###### real:= - - (-> Real Real Bool) - -###### real:> - - (-> Real Real Bool) - -###### real:< - - (-> Real Real Bool) - -###### length - - ## List length - (All [a] - (-> (List a) Int)) - -###### not - - (-> Bool Bool) - -###### text:++ - - ## Text/string concatenation - (-> Text Text Text) - -###### get-module-name - - ## Obtain the name of the currently-compiling module while in a macro. - (Lux Text) - -###### find-macro - - ## Given the name of a macro, try to obtain it. - (-> Ident (Lux (Maybe Macro))) - -###### normalize - - ## Normalizes a name so if it lacks a module prefix, it gets the one of the current module. - (-> Ident (Lux Ident)) - -###### ->text - - (-> (^ java.lang.Object) Text) - -###### interpose - - (All [a] - (-> a (List a) (List a))) - -###### syntax:show - - ## Turn Lux syntax into user-readable text. (Note: it's not pretty-printed) - (-> Syntax Text) - -###### macro-expand - - ## The standard macro-expand function. - (-> Syntax (Lux (List Syntax))) - -###### gensym - - ## Can't forget gensym! - (-> Text (Lux Syntax)) - -###### macro-expand-1 - - (-> Syntax (Lux Syntax)) - -###### id - - (All [a] - (-> a a)) - -###### print - - ## Neither print or println return IO right now because I've yet to implement monads & do-notation - (-> Text (,)) - -###### println - - (-> Text (,)) - -###### some - - (All [a b] - (-> (-> a (Maybe b)) (List a) (Maybe b))) - -### Signatures -###### Eq - - (defsig #export (Eq a) - (: (-> a a Bool) - =)) - -###### Show - - (defsig #export (Show a) - (: (-> a Text) - show)) - -###### Ord - - (defsig #export (Ord a) - (: (-> a a Bool) - <) - (: (-> a a Bool) - <=) - (: (-> a a Bool) - >) - (: (-> a a Bool) - >=)) - -### Structures -###### Int:Eq -###### Real:Eq - -###### Bool:Show -###### Int:Show -###### Real:Show -###### Char:Show +## Where do I learn Lux? -###### Int:Ord -###### Real:Ord +Just head to the wiki and check out the documentation for the currently available modules, and the tutorials. ## Caveats @@ -817,7 +180,7 @@ The compiler is not fully stable so you might get an error if you do anything fu Also, the error messages could really use an overhaul, so any error message you get will probably startle you. -Don't worry about it, version 0.2 will improve error reporting a lot. +Don't worry about it, version 0.3 will improve error reporting a lot. If you have any doubts, feel free to ask/complain in the Google Group. ### Tags diff --git a/project.clj b/project.clj index 9f647fcd4..a0fd8d1cb 100644 --- a/project.clj +++ b/project.clj @@ -1,6 +1,6 @@ -(defproject lux-jvm "0.1.0" +(defproject lux-jvm "0.2.0" :description "The JVM compiler for the Lux programming language." - :url "http://example.com/FIXME" + :url "https://github.com/LuxLang/lux" :license {:name "Eclipse Public License" :url "http://www.eclipse.org/legal/epl-v10.html"} :dependencies [[org.clojure/clojure "1.6.0"] diff --git a/source/lux.lux b/source/lux.lux index acaee2265..8861bc241 100644 --- a/source/lux.lux +++ b/source/lux.lux @@ -7,53 +7,55 @@ ## You must not remove this notice, or any other, from this software. ## First things first, must define functions -(jvm-interface Function - (:' (-> [java.lang.Object] java.lang.Object) - apply)) +(_jvm_interface "Function" [] + ("apply" ["java.lang.Object"] "java.lang.Object" ["public" "abstract"])) ## Basic types -(def' Bool (#DataT "java.lang.Boolean")) -(export' Bool) +(_lux_def Bool (#DataT "java.lang.Boolean")) +(_lux_export Bool) -(def' Int (#DataT "java.lang.Long")) -(export' Int) +(_lux_def Int (#DataT "java.lang.Long")) +(_lux_export Int) -(def' Real (#DataT "java.lang.Double")) -(export' Real) +(_lux_def Real (#DataT "java.lang.Double")) +(_lux_export Real) -(def' Char (#DataT "java.lang.Character")) -(export' Char) +(_lux_def Char (#DataT "java.lang.Character")) +(_lux_export Char) -(def' Text (#DataT "java.lang.String")) -(export' Text) +(_lux_def Text (#DataT "java.lang.String")) +(_lux_export Text) -(def' Void (#VariantT #Nil)) -(export' Void) +(_lux_def Unit (#TupleT #Nil)) +(_lux_export Unit) -(def' Ident (#TupleT (#Cons [Text (#Cons [Text #Nil])]))) -(export' Ident) +(_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))))) -(def' List - (#AllT [#None "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 "List") (#BoundT "a")]) + (#Cons [(#AppT [(#BoundT "lux;List") (#BoundT "a")]) #Nil])]))] #Nil])]))])) -(export' List) +(_lux_export List) ## (deftype (Maybe a) ## (| #None ## (#Some a))) -(def' Maybe - (#AllT [#None "Maybe" "a" +(_lux_def Maybe + (#AllT [(#Some #Nil) "lux;Maybe" "a" (#VariantT (#Cons [["lux;None" (#TupleT #Nil)] (#Cons [["lux;Some" (#BoundT "a")] #Nil])]))])) -(export' Maybe) +(_lux_export Maybe) ## (deftype #rec Type ## (| (#DataT Text) @@ -65,31 +67,31 @@ ## (#VarT Int) ## (#AllT (, (Maybe (List (, Text Type))) Text Text Type)) ## (#AppT (, Type Type)))) -(def' Type - (case' (#AppT [(#BoundT "Type") (#BoundT "_")]) - Type - (case' (#AppT [List (#TupleT (#Cons [Text (#Cons [Type #Nil])]))]) - TypeEnv - (#AppT [(#AllT [#None "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])))) -(export' 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)))) -(def' Bindings - (#AllT [#None "Bindings" "k" +(_lux_def Bindings + (#AllT [(#Some #Nil) "lux;Bindings" "k" (#AllT [#None "" "v" (#RecordT (#Cons [["lux;counter" Int] (#Cons [["lux;mappings" (#AppT [List @@ -97,14 +99,15 @@ (#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))) -(def' Env - (#AllT [#None "Env" "k" +(_lux_def Env + (#AllT [(#Some #Nil) "lux;Env" "k" (#AllT [#None "" "v" (#RecordT (#Cons [["lux;name" Text] (#Cons [["lux;inner-closures" Int] @@ -113,82 +116,84 @@ (#Cons [["lux;closure" (#AppT [(#AppT [Bindings (#BoundT "k")]) (#BoundT "v")])] #Nil])])])]))])])) +(_lux_export Env) ## (deftype Cursor ## (, Text Int Int)) -(def' Cursor +(_lux_def Cursor (#TupleT (#Cons [Text (#Cons [Int (#Cons [Int #Nil])])]))) +(_lux_export Cursor) ## (deftype (Meta m v) ## (| (#Meta (, m v)))) -(def' Meta - (#AllT [#None "Meta" "m" +(_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]))])])) -(export' Meta) +(_lux_export Meta) ## (deftype (Syntax' w) -## (| (#Bool Bool) -## (#Int Int) -## (#Real Real) -## (#Char Char) -## (#Text Text) -## (#Symbol (, Text Text)) -## (#Tag (, Text Text)) -## (#Form (List (w (Syntax' w)))) -## (#Tuple (List (w (Syntax' w)))) -## (#Record (List (, (w (Syntax' w)) (w (Syntax' w))))))) -(def' Syntax' - (case' (#AppT [(#BoundT "w") - (#AppT [(#BoundT "Syntax'") - (#BoundT "w")])]) - Syntax - (case' (#AppT [List Syntax]) - SyntaxList - (#AllT [#None "Syntax'" "w" - (#VariantT (#Cons [["lux;Bool" Bool] - (#Cons [["lux;Int" Int] - (#Cons [["lux;Real" Real] - (#Cons [["lux;Char" Char] - (#Cons [["lux;Text" Text] - (#Cons [["lux;Symbol" Ident] - (#Cons [["lux;Tag" Ident] - (#Cons [["lux;Form" SyntaxList] - (#Cons [["lux;Tuple" SyntaxList] - (#Cons [["lux;Record" (#AppT [List (#TupleT (#Cons [Syntax (#Cons [Syntax #Nil])]))])] - #Nil]) - ])])])])])])])])]) - )])))) -(export' Syntax') +## (| (#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)))) -(def' Syntax - (case' (#AppT [Meta Cursor]) - w - (#AppT [w (#AppT [Syntax' w])]))) -(export' Syntax) +(_lux_def Syntax + (_lux_case (#AppT [Meta Cursor]) + w + (#AppT [w (#AppT [Syntax' w])]))) +(_lux_export Syntax) -(def' SyntaxList (#AppT [List Syntax])) +(_lux_def SyntaxList (#AppT [List Syntax])) ## (deftype (Either l r) ## (| (#Left l) ## (#Right r))) -(def' Either - (#AllT [#None "_" "l" +(_lux_def Either + (#AllT [(#Some #Nil) "lux;Either" "l" (#AllT [#None "" "r" (#VariantT (#Cons [["lux;Left" (#BoundT "l")] (#Cons [["lux;Right" (#BoundT "r")] #Nil])]))])])) -(export' Either) +(_lux_export Either) ## (deftype (StateE s a) ## (-> s (Either Text (, s a)))) -(def' StateE - (#AllT [#None "StateE" "s" +(_lux_def StateE + (#AllT [(#Some #Nil) "lux;StateE" "s" (#AllT [#None "" "a" (#LambdaT [(#BoundT "s") (#AppT [(#AppT [Either Text]) @@ -196,22 +201,22 @@ (#Cons [(#BoundT "a") #Nil])]))])])])])) -## (def' Reader +## (deftype Reader ## (List (Meta Cursor Text))) -(def' Reader +(_lux_def Reader (#AppT [List (#AppT [(#AppT [Meta Cursor]) Text])])) -(export' Reader) +(_lux_export Reader) ## (deftype HostState ## (& #writer (^ org.objectweb.asm.ClassWriter) ## #loader (^ java.net.URLClassLoader) -## #eval-ctor Int)) -(def' HostState +## #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;eval-ctor" Int] + (#Cons [["lux;classes" (#DataT "clojure.lang.Atom")] #Nil])])]))) ## (deftype (DefData' m) @@ -219,719 +224,713 @@ ## (#ValueD Type) ## (#MacroD m) ## (#AliasD Ident))) -(def' DefData' - (#AllT [#None "DefData'" "" +(_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))) -(def' LuxVar +(_lux_def LuxVar (#VariantT (#Cons [["lux;Local" Int] (#Cons [["lux;Global" Ident] #Nil])]))) -(export' LuxVar) +(_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 CompilerState -## (& #source (Maybe Reader) -## #modules (List (, Text (List (, Text (, Bool (DefData' (-> (List Syntax) (StateE CompilerState (List Syntax))))))))) -## #module-aliases (List Void) -## #envs (List (Env Text (, LuxVar Type))) -## #types (Bindings Int Type) -## #host HostState)) -(def' CompilerState - (#AppT [(#AllT [#None "CompilerState" "" - (#RecordT (#Cons [["lux;source" (#AppT [Maybe Reader])] +## (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 [List (#TupleT (#Cons [Text - (#Cons [(#TupleT (#Cons [Bool (#Cons [(#AppT [DefData' (#LambdaT [SyntaxList - (#AppT [(#AppT [StateE (#AppT [(#BoundT "CompilerState") - (#BoundT "")])]) - SyntaxList])])]) - #Nil])])) - #Nil])]))]) + (#Cons [(#AppT [Module (#AppT [(#BoundT "lux;Compiler") (#BoundT "")])]) #Nil])]))])] - (#Cons [["lux;module-aliases" (#AppT [List Void])] - (#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;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])) -(export' CompilerState) +(_lux_export Compiler) ## (deftype Macro -## (-> (List Syntax) (StateE CompilerState (List Syntax)))) -(def' Macro +## (-> (List Syntax) (StateE Compiler (List Syntax)))) +(_lux_def Macro (#LambdaT [SyntaxList - (#AppT [(#AppT [StateE CompilerState]) + (#AppT [(#AppT [StateE Compiler]) SyntaxList])])) -(export' Macro) +(_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])) -(def' _meta - (:' (#LambdaT [(#AppT [Syntax' - (#AppT [Meta Cursor])]) - Syntax]) - (lambda' _ data - (#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 CompilerState -## (Either Text (, CompilerState a)))) +## (-> a Compiler +## (Either Text (, Compiler a)))) ## ...) -(def' return - (:' (#AllT [#None "" "a" - (#LambdaT [(#BoundT "a") - (#LambdaT [CompilerState - (#AppT [(#AppT [Either Text]) - (#TupleT (#Cons [CompilerState - (#Cons [(#BoundT "a") - #Nil])]))])])])]) - (lambda' _ val - (lambda' _ state - (#Right [state val]))))) +(_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 CompilerState -## (Either Text (, CompilerState a)))) +## (-> Text Compiler +## (Either Text (, Compiler a)))) ## ...) -(def' fail - (:' (#AllT [#None "" "a" - (#LambdaT [Text - (#LambdaT [CompilerState - (#AppT [(#AppT [Either Text]) - (#TupleT (#Cons [CompilerState - (#Cons [(#BoundT "a") - #Nil])]))])])])]) - (lambda' _ msg - (lambda' _ state - (#Left msg))))) +(_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))))) -(def' $text - (:' (#LambdaT [Text Syntax]) - (lambda' _ text - (_meta (#Text text))))) +(_lux_def text$ + (_lux_: (#LambdaT [Text Syntax]) + (_lux_lambda _ text + (_meta (#TextS text))))) -(def' $symbol - (:' (#LambdaT [Ident Syntax]) - (lambda' _ ident - (_meta (#Symbol ident))))) +(_lux_def symbol$ + (_lux_: (#LambdaT [Ident Syntax]) + (_lux_lambda _ ident + (_meta (#SymbolS ident))))) -(def' $tag - (:' (#LambdaT [Ident Syntax]) - (lambda' _ ident - (_meta (#Tag ident))))) +(_lux_def tag$ + (_lux_: (#LambdaT [Ident Syntax]) + (_lux_lambda _ ident + (_meta (#TagS ident))))) -(def' $form - (:' (#LambdaT [(#AppT [List Syntax]) Syntax]) - (lambda' _ tokens - (_meta (#Form tokens))))) +(_lux_def form$ + (_lux_: (#LambdaT [(#AppT [List Syntax]) Syntax]) + (_lux_lambda _ tokens + (_meta (#FormS tokens))))) -(def' $tuple - (:' (#LambdaT [(#AppT [List Syntax]) Syntax]) - (lambda' _ tokens - (_meta (#Tuple tokens))))) +(_lux_def tuple$ + (_lux_: (#LambdaT [(#AppT [List Syntax]) Syntax]) + (_lux_lambda _ tokens + (_meta (#TupleS tokens))))) -(def' $record - (:' (#LambdaT [(#AppT [List (#TupleT (#Cons [Syntax (#Cons [Syntax #Nil])]))]) Syntax]) - (lambda' _ tokens - (_meta (#Record tokens))))) +(_lux_def record$ + (_lux_: (#LambdaT [(#AppT [List (#TupleT (#Cons [Syntax (#Cons [Syntax #Nil])]))]) Syntax]) + (_lux_lambda _ tokens + (_meta (#RecordS tokens))))) -(def' let' - (:' Macro - (lambda' _ tokens - (case' tokens - (#Cons [lhs (#Cons [rhs (#Cons [body #Nil])])]) - (return (:' SyntaxList - (#Cons [($form (#Cons [($symbol ["" "case'"]) - (#Cons [rhs (#Cons [lhs (#Cons [body #Nil])])])])) - #Nil]))) +(_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'"))))) -(declare-macro' let') + _ + (fail "Wrong syntax for let'"))))) +(_lux_declare-macro let') -(def' lambda_ - (:' Macro - (lambda' _ tokens - (case' tokens - (#Cons [(#Meta [_ (#Tuple (#Cons [arg args']))]) (#Cons [body #Nil])]) - (return (:' SyntaxList - (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["" "lambda'"])) - (#Cons [(_meta (#Symbol ["" ""])) - (#Cons [arg - (#Cons [(case' args' - #Nil - body +(_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 (#Form (#Cons [(_meta (#Symbol ["lux" "lambda_"])) - (#Cons [(_meta (#Tuple args')) - (#Cons [body #Nil])])])))) - #Nil])])])]))) - #Nil]))) + _ + (_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "lambda'"])) + (#Cons [(_meta (#TupleS args')) + (#Cons [body #Nil])])])))) + #Nil])])])]))) + #Nil])) - (#Cons [(#Meta [_ (#Symbol self)]) (#Cons [(#Meta [_ (#Tuple (#Cons [arg args']))]) (#Cons [body #Nil])])]) - (return (:' SyntaxList - (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["" "lambda'"])) - (#Cons [(_meta (#Symbol self)) - (#Cons [arg - (#Cons [(case' args' - #Nil - body + (#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 (#Form (#Cons [(_meta (#Symbol ["lux" "lambda_"])) - (#Cons [(_meta (#Tuple args')) - (#Cons [body #Nil])])])))) - #Nil])])])]))) - #Nil]))) - - _ - (fail "Wrong syntax for lambda"))))) -(declare-macro' lambda_) + _ + (_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') -(def' def_ - (:' Macro - (lambda_ [tokens] - (case' tokens - (#Cons [(#Meta [_ (#Tag ["" "export"])]) - (#Cons [(#Meta [_ (#Form (#Cons [name args]))]) - (#Cons [type (#Cons [body #Nil])])])]) - (return (:' SyntaxList - (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["" "def'"])) - (#Cons [name - (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["" ":'"])) - (#Cons [type - (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["lux" "lambda_"])) - (#Cons [name - (#Cons [(_meta (#Tuple args)) - (#Cons [body #Nil])])])]))) - #Nil])])]))) - #Nil])])]))) - (#Cons [(_meta (#Form (#Cons [($symbol ["" "export'"]) (#Cons [name #Nil])]))) - #Nil])]))) +(_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 [_ (#Tag ["" "export"])]) (#Cons [name (#Cons [type (#Cons [body #Nil])])])]) - (return (:' SyntaxList - (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["" "def'"])) - (#Cons [name - (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["" ":'"])) - (#Cons [type - (#Cons [body - #Nil])])]))) - #Nil])])]))) - (#Cons [(_meta (#Form (#Cons [($symbol ["" "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 [_ (#Form (#Cons [name args]))]) - (#Cons [type (#Cons [body #Nil])])]) - (return (:' SyntaxList - (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["" "def'"])) - (#Cons [name - (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["" ":'"])) - (#Cons [type - (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["lux" "lambda_"])) - (#Cons [name - (#Cons [(_meta (#Tuple args)) - (#Cons [body #Nil])])])]))) - #Nil])])]))) - #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 (:' SyntaxList - (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["" "def'"])) - (#Cons [name - (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["" ":'"])) - (#Cons [type - (#Cons [body - #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") - )))) -(declare-macro' def_) + _ + (fail "Wrong syntax for def") + )))) +(_lux_declare-macro def') -(def_ #export (defmacro tokens) +(def' (defmacro tokens) Macro - (case' tokens - (#Cons [(#Meta [_ (#Form (#Cons [name args]))]) (#Cons [body #Nil])]) - (return (:' SyntaxList - (#Cons [($form (#Cons [($symbol ["lux" "def_"]) - (#Cons [($form (#Cons [name args])) - (#Cons [($symbol ["lux" "Macro"]) - (#Cons [body - #Nil])]) - ])])) - (#Cons [($form (#Cons [($symbol ["" "declare-macro'"]) (#Cons [name #Nil])])) - #Nil])]))) + (_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 [_ (#Tag ["" "export"])]) (#Cons [(#Meta [_ (#Form (#Cons [name args]))]) (#Cons [body #Nil])])]) - (return (:' SyntaxList - (#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 ["" "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"))) -(declare-macro' defmacro) + _ + (fail "Wrong syntax for defmacro"))) +(_lux_declare-macro defmacro) (defmacro #export (comment tokens) - (return (:' SyntaxList #Nil))) + (return #Nil)) (defmacro (->' tokens) - (case' tokens - (#Cons [input (#Cons [output #Nil])]) - (return (:' SyntaxList - (#Cons [(_meta (#Form (#Cons [(_meta (#Tag ["lux" "LambdaT"])) - (#Cons [(_meta (#Tuple (#Cons [input (#Cons [output #Nil])]))) - #Nil])]))) - #Nil]))) + (_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 (:' SyntaxList - (#Cons [(_meta (#Form (#Cons [(_meta (#Tag ["lux" "LambdaT"])) - (#Cons [(_meta (#Tuple (#Cons [input - (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["lux" "->'"])) - (#Cons [output others])]))) - #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 ->'"))) + _ + (fail "Wrong syntax for ->'"))) (defmacro (All' tokens) - (case' tokens - (#Cons [(#Meta [_ (#Tuple #Nil)]) - (#Cons [body #Nil])]) - (return (:' SyntaxList - (#Cons [body - #Nil]))) + (_lux_case tokens + (#Cons [(#Meta [_ (#TupleS #Nil)]) + (#Cons [body #Nil])]) + (return (#Cons [body + #Nil])) - (#Cons [(#Meta [_ (#Tuple (#Cons [(#Meta [_ (#Symbol ["" arg-name])]) other-args]))]) - (#Cons [body #Nil])]) - (return (:' SyntaxList - (#Cons [(_meta (#Form (#Cons [(_meta (#Tag ["lux" "AllT"])) - (#Cons [(_meta (#Tuple (#Cons [(_meta (#Tag ["lux" "None"])) - (#Cons [(_meta (#Text "")) - (#Cons [(_meta (#Text arg-name)) - (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["lux" "All'"])) - (#Cons [(_meta (#Tuple other-args)) - (#Cons [body - #Nil])])]))) - #Nil])])])]))) - #Nil])]))) - #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'"))) + _ + (fail "Wrong syntax for All'"))) (defmacro (B' tokens) - (case' tokens - (#Cons [(#Meta [_ (#Symbol ["" bound-name])]) - #Nil]) - (return (:' SyntaxList - (#Cons [(_meta (#Form (#Cons [(_meta (#Tag ["lux" "BoundT"])) - (#Cons [(_meta (#Text bound-name)) - #Nil])]))) - #Nil]))) + (_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'"))) + _ + (fail "Wrong syntax for B'"))) (defmacro ($' tokens) - (case' tokens - (#Cons [x #Nil]) - (return tokens) + (_lux_case tokens + (#Cons [x #Nil]) + (return tokens) - (#Cons [x (#Cons [y xs])]) - (return (:' SyntaxList - (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["lux" "$'"])) - (#Cons [(_meta (#Form (#Cons [(_meta (#Tag ["lux" "AppT"])) - (#Cons [(_meta (#Tuple (#Cons [x (#Cons [y #Nil])]))) - #Nil])]))) - xs])]))) - #Nil]))) + (#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 $'"))) + _ + (fail "Wrong syntax for $'"))) -(def_ #export (fold f init xs) +(def' (foldL f init xs) (All' [a b] (->' (->' (B' a) (B' b) (B' a)) (B' a) ($' List (B' b)) (B' a))) - (case' xs - #Nil - init + (_lux_case xs + #Nil + init - (#Cons [x xs']) - (fold f (f init x) xs'))) + (#Cons [x xs']) + (foldL f (f init x) xs'))) -(def_ #export (reverse list) +(def' (reverse list) (All' [a] (->' ($' List (B' a)) ($' List (B' a)))) - (fold (:' (All' [a] - (->' ($' List (B' a)) (B' a) ($' List (B' a)))) - (lambda_ [tail head] - (#Cons [head tail]))) - #Nil - list)) + (foldL (lambda' [tail head] (#Cons [head tail])) + #Nil + list)) -(defmacro #export (list xs) - (return (:' SyntaxList - (#Cons [(fold (:' (->' Syntax Syntax Syntax) - (lambda_ [tail head] - (_meta (#Form (#Cons [(_meta (#Tag ["lux" "Cons"])) - (#Cons [(_meta (#Tuple (#Cons [head (#Cons [tail #Nil])]))) - #Nil])]))))) - (_meta (#Tag ["lux" "Nil"])) - (reverse xs)) - #Nil])))) +(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 #export (list& xs) - (case' (reverse xs) - (#Cons [last init]) - (return (:' SyntaxList - (list (fold (:' (->' Syntax Syntax Syntax) - (lambda_ [tail head] - (_meta (#Form (list (_meta (#Tag ["lux" "Cons"])) - (_meta (#Tuple (list head tail)))))))) - last - init)))) +(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&"))) + _ + (fail "Wrong syntax for list&"))) (defmacro #export (lambda tokens) - (let' [name tokens'] (:' (#TupleT (list Ident ($' List Syntax))) - (case' tokens - (#Cons [(#Meta [_ (#Symbol name)]) tokens']) - [name tokens'] + (let' [name tokens'] (_lux_: (#TupleT (list Ident ($' List Syntax))) + (_lux_case tokens + (#Cons [(#Meta [_ (#SymbolS name)]) tokens']) + [name tokens'] - _ - [["" ""] tokens])) - (case' tokens' - (#Cons [(#Meta [_ (#Tuple args)]) (#Cons [body #Nil])]) - (case' args - #Nil - (fail "lambda requires a non-empty arguments tuple.") - - (#Cons [harg targs]) - (let' body' (fold (:' (->' Syntax Syntax Syntax) - (lambda_ [body' arg] - ($form (list ($symbol ["" "lambda'"]) - ($symbol ["" ""]) - arg - body')))) - body - (reverse targs)) - (return (:' SyntaxList - (list ($form (list ($symbol ["" "lambda'"]) - ($symbol name) - harg - body'))))))) + _ + [["" ""] 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")))) + _ + (fail "Wrong syntax for lambda")))) -(defmacro (def__ tokens) - (case' tokens - (#Cons [(#Meta [_ (#Tag ["" "export"])]) - (#Cons [(#Meta [_ (#Form (#Cons [name args]))]) - (#Cons [type (#Cons [body #Nil])])])]) - (return (:' SyntaxList - (list ($form (list ($symbol ["" "def'"]) - name - ($form (list ($symbol ["" ":'"]) - type - ($form (list ($symbol ["lux" "lambda"]) - name - ($tuple args) - body)))))) - ($form (list ($symbol ["" "export'"]) name))))) +(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 [_ (#Tag ["" "export"])]) (#Cons [name (#Cons [type (#Cons [body #Nil])])])]) - (return (:' SyntaxList - (list ($form (list ($symbol ["" "def'"]) - name - ($form (list ($symbol ["" ":'"]) - type - body)))) - ($form (list ($symbol ["" "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 [_ (#Form (#Cons [name args]))]) - (#Cons [type (#Cons [body #Nil])])]) - (return (:' SyntaxList - (list ($form (list ($symbol ["" "def'"]) - name - ($form (list ($symbol ["" ":'"]) - type - ($form (list ($symbol ["lux" "lambda"]) - name - ($tuple args) - body))))))))) + (#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 (:' SyntaxList - (list ($form (list ($symbol ["" "def'"]) - name - ($form (list ($symbol ["" ":'"]) type 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") - )) + _ + (fail "Wrong syntax for def") + )) -(def__ (as-pairs xs) +(def'' (as-pairs xs) (All' [a] (->' ($' List (B' a)) ($' List (#TupleT (list (B' a) (B' a)))))) - (case' xs - (#Cons [x (#Cons [y xs'])]) - (#Cons [[x y] (as-pairs xs')]) + (_lux_case xs + (#Cons [x (#Cons [y xs'])]) + (#Cons [[x y] (as-pairs xs')]) - _ - #Nil)) + _ + #Nil)) (defmacro #export (let tokens) - (case' tokens - (#Cons [(#Meta [_ (#Tuple bindings)]) (#Cons [body #Nil])]) - (return (:' SyntaxList - (list (fold (:' (->' Syntax (#TupleT (list Syntax Syntax)) - Syntax) - (lambda [body binding] - (case' binding - [label value] - (_meta (#Form (list (_meta (#Symbol ["lux" "let'"])) label value body)))))) - body - (fold (:' (->' ($' List (#TupleT (list Syntax Syntax))) (#TupleT (list Syntax Syntax)) - ($' List (#TupleT (list Syntax Syntax)))) - (lambda [tail head] - (#Cons [head tail]))) - #Nil - (as-pairs bindings)))))) + (_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"))) + _ + (fail "Wrong syntax for let"))) -(def__ #export (map f xs) +(def'' (map f xs) (All' [a b] (->' (->' (B' a) (B' b)) ($' List (B' a)) ($' List (B' b)))) - (case' xs - #Nil - #Nil + (_lux_case xs + #Nil + #Nil - (#Cons [x xs']) - (#Cons [(f x) (map f xs')]))) + (#Cons [x xs']) + (#Cons [(f x) (map f xs')]))) -(def__ #export (any? p xs) +(def'' (any? p xs) (All' [a] (->' (->' (B' a) Bool) ($' List (B' a)) Bool)) - (case' xs - #Nil - false + (_lux_case xs + #Nil + false - (#Cons [x xs']) - (case' (p x) - true true - false (any? p xs')))) + (#Cons [x xs']) + (_lux_case (p x) + true true + false (any? p xs')))) -(def__ (spliced? token) +(def'' (spliced? token) (->' Syntax Bool) - (case' token - (#Meta [_ (#Form (#Cons [(#Meta [_ (#Symbol ["" "~@"])]) (#Cons [_ #Nil])]))]) - true + (_lux_case token + (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS ["" "~@"])]) (#Cons [_ #Nil])]))]) + true - _ - false)) + _ + false)) -(def__ (wrap-meta content) +(def'' (wrap-meta content) (->' Syntax Syntax) - (_meta (#Form (list (_meta (#Tag ["lux" "Meta"])) - (_meta (#Tuple (list (_meta (#Tuple (list (_meta (#Text "")) (_meta (#Int -1)) (_meta (#Int -1))))) - content))))))) + (_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) +(def'' (untemplate-list tokens) (->' ($' List Syntax) Syntax) - (case' tokens - #Nil - (_meta (#Tag ["lux" "Nil"])) + (_lux_case tokens + #Nil + (_meta (#TagS ["lux" "Nil"])) - (#Cons [token tokens']) - (_meta (#Form (list (_meta (#Tag ["lux" "Cons"])) - (_meta (#Tuple (list token (untemplate-list tokens'))))))))) + (#Cons [token tokens']) + (_meta (#FormS (list (_meta (#TagS ["lux" "Cons"])) + (_meta (#TupleS (list token (untemplate-list tokens'))))))))) -(def__ (list:++ xs ys) +(def'' #export (list:++ xs ys) (All' [a] (->' ($' List (B' a)) ($' List (B' a)) ($' List (B' a)))) - (case' xs - (#Cons [x xs']) - (#Cons [x (list:++ xs' ys)]) + (_lux_case xs + (#Cons [x xs']) + (#Cons [x (list:++ xs' ys)]) - #Nil - ys)) + #Nil + ys)) (defmacro #export ($ tokens) - (case' tokens - (#Cons [op (#Cons [init args])]) - (return (:' SyntaxList - (list (fold (:' (->' Syntax Syntax Syntax) - (lambda [a1 a2] - ($form (list op a1 a2)))) - init - args)))) - - _ - (fail "Wrong syntax for $"))) + (_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 untemplate tag elems) - (->' (->' Syntax Syntax) Syntax ($' List Syntax) Syntax) - (case' (any? spliced? elems) - true - (let [elems' (map (:' (->' Syntax Syntax) - (lambda [elem] - (case' elem - (#Meta [_ (#Form (#Cons [(#Meta [_ (#Symbol ["" "~@"])]) (#Cons [spliced #Nil])]))]) - spliced +(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 ["" ":'"]) - ($symbol ["lux" "SyntaxList"]) - ($form (list ($symbol ["lux" "list"]) (untemplate elem)))))))) - elems)] - (wrap-meta ($form (list tag - ($form (list& ($symbol ["lux" "$"]) - ($symbol ["lux" "list:++"]) - elems')))))) + _ + (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)))))) + false + (wrap-meta (form$ (list tag (untemplate-list (map untemplate elems))))))) -(def__ (untemplate subst token) - (->' Text Syntax Syntax) - (case' token - (#Meta [_ (#Bool value)]) - (wrap-meta ($form (list ($tag ["lux" "Bool"]) (_meta (#Bool value))))) +(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 [_ (#Int value)]) - (wrap-meta ($form (list ($tag ["lux" "Int"]) (_meta (#Int value))))) + [_ (#Meta [_ (#IntS value)])] + (wrap-meta (form$ (list (tag$ ["lux" "IntS"]) (_meta (#IntS value))))) - (#Meta [_ (#Real value)]) - (wrap-meta ($form (list ($tag ["lux" "Real"]) (_meta (#Real value))))) + [_ (#Meta [_ (#RealS value)])] + (wrap-meta (form$ (list (tag$ ["lux" "RealS"]) (_meta (#RealS value))))) - (#Meta [_ (#Char value)]) - (wrap-meta ($form (list ($tag ["lux" "Char"]) (_meta (#Char value))))) + [_ (#Meta [_ (#CharS value)])] + (wrap-meta (form$ (list (tag$ ["lux" "CharS"]) (_meta (#CharS value))))) - (#Meta [_ (#Text value)]) - (wrap-meta ($form (list ($tag ["lux" "Text"]) (_meta (#Text value))))) + [_ (#Meta [_ (#TextS value)])] + (wrap-meta (form$ (list (tag$ ["lux" "TextS"]) (_meta (#TextS value))))) - (#Meta [_ (#Tag [module name])]) - (let [module' (case' module - "" - subst + [_ (#Meta [_ (#TagS [module name])])] + (let [module' (_lux_case module + "" + subst - _ - module)] - (wrap-meta ($form (list ($tag ["lux" "Tag"]) ($tuple (list ($text module') ($text name))))))) + _ + module)] + (wrap-meta (form$ (list (tag$ ["lux" "TagS"]) (tuple$ (list (text$ module') (text$ name))))))) - (#Meta [_ (#Symbol [module name])]) - (let [module' (case' module - "" - subst + [_ (#Meta [_ (#SymbolS [module name])])] + (let [module' (_lux_case module + "" + subst - _ - module)] - (wrap-meta ($form (list ($tag ["lux" "Symbol"]) ($tuple (list ($text module') ($text name))))))) + _ + module)] + (wrap-meta (form$ (list (tag$ ["lux" "SymbolS"]) (tuple$ (list (text$ module') (text$ name))))))) - (#Meta [_ (#Tuple elems)]) - (splice (untemplate subst) ($tag ["lux" "Tuple"]) elems) + [_ (#Meta [_ (#TupleS elems)])] + (splice replace? (untemplate replace? subst) (tag$ ["lux" "TupleS"]) elems) - (#Meta [_ (#Form (#Cons [(#Meta [_ (#Symbol ["" "~"])]) (#Cons [unquoted #Nil])]))]) - unquoted + [true (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS ["" "~"])]) (#Cons [unquoted #Nil])]))])] + unquoted - (#Meta [_ (#Form elems)]) - (splice (untemplate subst) ($tag ["lux" "Form"]) elems) + [_ (#Meta [meta (#FormS elems)])] + (let [(#Meta [_ form']) (splice replace? (untemplate replace? subst) (tag$ ["lux" "FormS"]) elems)] + (#Meta [meta form'])) - (#Meta [_ (#Record fields)]) - (wrap-meta ($form (list ($tag ["lux" "Record"]) - (untemplate-list (map (:' (->' (#TupleT (list Syntax Syntax)) Syntax) - (lambda [kv] - (let [[k v] kv] - ($tuple (list (untemplate subst k) (untemplate subst v)))))) - fields))))) - )) + [_ (#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) - (case' tokens - (#Cons [template #Nil]) - (return (:' SyntaxList - (list (untemplate "" template)))) + (_lux_case tokens + (#Cons [template #Nil]) + (return (list (untemplate true "" template))) - _ - (fail "Wrong syntax for `'"))) + _ + (fail "Wrong syntax for `'"))) + +(defmacro (' tokens) + (_lux_case tokens + (#Cons [template #Nil]) + (return (list (untemplate false "" template))) + + _ + (fail "Wrong syntax for '"))) (defmacro #export (|> tokens) - (case' tokens - (#Cons [init apps]) - (return (:' SyntaxList - (list (fold (:' (->' Syntax Syntax Syntax) - (lambda [acc app] - (case' app - (#Meta [_ (#Form parts)]) - ($form (list:++ parts (list acc))) + (_lux_case tokens + (#Cons [init apps]) + (return (list (foldL (lambda [acc app] + (_lux_case app + (#Meta [_ (#TupleS parts)]) + (tuple$ (list:++ parts (list acc))) - _ - (`' ((~ app) (~ acc)))))) - init - apps)))) + (#Meta [_ (#FormS parts)]) + (form$ (list:++ parts (list acc))) - _ - (fail "Wrong syntax for |>"))) + _ + (`' ((~ app) (~ acc))))) + init + apps))) + + _ + (fail "Wrong syntax for |>"))) (defmacro #export (if tokens) - (case' tokens - (#Cons [test (#Cons [then (#Cons [else #Nil])])]) - (return (:' SyntaxList - (list (`' (case' (~ test) - true (~ then) - false (~ else)))))) + (_lux_case tokens + (#Cons [test (#Cons [then (#Cons [else #Nil])])]) + (return (list (`' (_lux_case (~ test) + true (~ then) + false (~ else))))) - _ - (fail "Wrong syntax for if"))) + _ + (fail "Wrong syntax for if"))) ## (deftype (Lux a) -## (-> CompilerState (Either Text (, CompilerState a)))) -(def__ #export Lux +## (-> Compiler (Either Text (, Compiler a)))) +(def'' #export Lux Type (All' [a] - (->' CompilerState ($' Either Text (#TupleT (list CompilerState (B' 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 +(def'' Monad Type (All' [m] (#RecordT (list ["lux;return" (All' [a] (->' (B' a) ($' (B' m) (B' a))))] @@ -939,7 +938,7 @@ ($' (B' m) (B' a)) ($' (B' m) (B' b))))])))) -(def__ Maybe:Monad +(def'' Maybe/Monad ($' Monad Maybe) {#lux;return (lambda return [x] @@ -947,79 +946,73 @@ #lux;bind (lambda [f ma] - (case' ma - #None #None - (#Some a) (f a)))}) + (_lux_case ma + #None #None + (#Some a) (f a)))}) -(def__ Lux:Monad +(def'' Lux/Monad ($' Monad Lux) {#lux;return - (lambda return [x] - (lambda [state] - (#Right [state x]))) + (lambda [x] + (lambda [state] + (#Right [state x]))) #lux;bind (lambda [f ma] (lambda [state] - (case' (ma state) - (#Left msg) - (#Left msg) + (_lux_case (ma state) + (#Left msg) + (#Left msg) - (#Right [state' a]) - (f a state'))))}) + (#Right [state' a]) + (f a state'))))}) (defmacro #export (^ tokens) - (case' tokens - (#Cons [(#Meta [_ (#Symbol ["" class-name])]) #Nil]) - (return (:' SyntaxList - (list (`' (#;DataT (~ (_meta (#Text class-name)))))))) + (_lux_case tokens + (#Cons [(#Meta [_ (#SymbolS ["" class-name])]) #Nil]) + (return (list (`' (#;DataT (~ (_meta (#TextS class-name))))))) - _ - (fail "Wrong syntax for ^"))) + _ + (fail "Wrong syntax for ^"))) (defmacro #export (-> tokens) - (case' (reverse tokens) - (#Cons [output inputs]) - (return (:' SyntaxList - (list (fold (:' (->' Syntax Syntax Syntax) - (lambda [o i] - (`' (#;LambdaT [(~ i) (~ o)])))) - output - inputs)))) - - _ - (fail "Wrong syntax for ->"))) + (_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 (:' SyntaxList - (list (`' (#;TupleT (;list (~@ tokens)))))))) + (return (list (`' (#;TupleT (~ (untemplate-list tokens))))))) (defmacro (do tokens) - (case' tokens - (#Cons [monad (#Cons [(#Meta [_ (#Tuple bindings)]) (#Cons [body #Nil])])]) - (let [body' (fold (:' (-> Syntax (, Syntax Syntax) Syntax) + (_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] - (case' var - (#Meta [_ (#Tag ["" "let"])]) - (`' (;let (~ value) (~ body'))) + (_lux_case var + (#Meta [_ (#TagS ["" "let"])]) + (`' (;let (~ value) (~ body'))) - _ - (`' (;bind (lambda' (~ ($symbol ["" ""])) - (~ var) - (~ body')) - (~ value))))))) - body - (reverse (as-pairs bindings)))] - (return (:' SyntaxList - (list (`' (case' (~ monad) - {#;return ;return #;bind ;bind} - (~ 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"))) + _ + (fail "Wrong syntax for do"))) -(def__ (map% m f xs) +(def'' (map% m f xs) ## (All [m a b] ## (-> (Monad m) (-> a (m b)) (List a) (m (List b)))) (All' [m a b] @@ -1028,617 +1021,637 @@ ($' List (B' a)) ($' (B' m) ($' List (B' b))))) (let [{#;return ;return #;bind _} m] - (case' xs - #Nil - (;return (:' List #Nil)) - - (#Cons [x xs']) - (do m - [y (f x) - ys (map% m f xs')] - (;return (:' List (#Cons [y ys])))) - ))) + (_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) +(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) +(def'' (get-ident x) (-> Syntax ($' Maybe Text)) - (case' x - (#Meta [_ (#Symbol ["" sname])]) - (#Some sname) + (_lux_case x + (#Meta [_ (#SymbolS ["" sname])]) + (#Some sname) - _ - #None)) + _ + #None)) -(def__ (tuple->list tuple) +(def'' (tuple->list tuple) (-> Syntax ($' Maybe ($' List Syntax))) - (case' tuple - (#Meta [_ (#Tuple members)]) - (#Some members) + (_lux_case tuple + (#Meta [_ (#TupleS members)]) + (#Some members) - _ - #None)) + _ + #None)) -(def__ RepEnv +(def'' RepEnv Type ($' List (, Text Syntax))) -(def__ (make-env xs ys) +(def'' (make-env xs ys) (-> ($' List Text) ($' List Syntax) RepEnv) - (case' (:' (, ($' List Text) ($' List Syntax)) - [xs ys]) - [(#Cons [x xs']) (#Cons [y ys'])] - (#Cons [[x y] (make-env xs' ys')]) + (_lux_case (_lux_: (, ($' List Text) ($' List Syntax)) + [xs ys]) + [(#Cons [x xs']) (#Cons [y ys'])] + (#Cons [[x y] (make-env xs' ys')]) - _ - #Nil)) + _ + #Nil)) -(def__ (text:= x y) +(def'' (text:= x y) (-> Text Text Bool) - (jvm-invokevirtual java.lang.Object equals [java.lang.Object] - x [y])) + (_jvm_invokevirtual "java.lang.Object" "equals" ["java.lang.Object"] + x [y])) -(def__ (get-rep key env) +(def'' (get-rep key env) (-> Text RepEnv ($' Maybe Syntax)) - (case' env - #Nil - #None + (_lux_case env + #Nil + #None - (#Cons [[k v] env']) - (if (text:= k key) - (#Some v) - (get-rep key env')))) + (#Cons [[k v] env']) + (if (text:= k key) + (#Some v) + (get-rep key env')))) -(def__ (apply-template env template) +(def'' (apply-template env template) (-> RepEnv Syntax Syntax) - (case' template - (#Meta [_ (#Symbol ["" sname])]) - (case' (get-rep sname env) - (#Some subst) - subst + (_lux_case template + (#Meta [_ (#SymbolS ["" sname])]) + (_lux_case (get-rep sname env) + (#Some subst) + subst - _ - template) + _ + template) - (#Meta [_ (#Tuple elems)]) - ($tuple (map (apply-template env) elems)) + (#Meta [_ (#TupleS elems)]) + (tuple$ (map (apply-template env) elems)) - (#Meta [_ (#Form elems)]) - ($form (map (apply-template env) elems)) + (#Meta [_ (#FormS elems)]) + (form$ (map (apply-template env) elems)) - (#Meta [_ (#Record members)]) - ($record (map (:' (-> (, Syntax Syntax) (, Syntax Syntax)) - (lambda [kv] - (let [[slot value] kv] - [(apply-template env slot) (apply-template env value)]))) - members)) + (#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)) + _ + template)) -(def__ (join-map f xs) +(def'' (join-map f xs) (All' [a b] (-> (-> (B' a) ($' List (B' b))) ($' List (B' a)) ($' List (B' b)))) - (case' xs - #Nil - #Nil + (_lux_case xs + #Nil + #Nil - (#Cons [x xs']) - (list:++ (f x) (join-map f xs')))) + (#Cons [x xs']) + (list:++ (f x) (join-map f xs')))) -(defmacro (do-template tokens) - (case' tokens - (#Cons [(#Meta [_ (#Tuple bindings)]) (#Cons [(#Meta [_ (#Tuple templates)]) data])]) - (case' (:' (, ($' 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 (:' (-> RepEnv ($' List Syntax)) - (lambda [env] (map (apply-template env) templates)))] - (|> data' - (join-map (. apply (make-env bindings'))) - return)) +(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 "All the do-template bindigns must be symbols.")) + _ + (fail "Wrong syntax for do-template")) - _ - (fail "Wrong syntax for do-template"))) + _ + (fail "Wrong syntax for do-template"))) (do-template [<name> <cmp> <type>] - [(def__ #export (<name> x y) + [(def'' #export (<name> x y) (-> <type> <type> Bool) (<cmp> x y))] - [int:= jvm-leq Int] - [int:> jvm-lgt Int] - [int:< jvm-llt Int] - [real:= jvm-deq Real] - [real:> jvm-dgt Real] - [real:< jvm-dlt Real] + [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 [<name> <cmp> <eq> <type>] + [(def'' #export (<name> x y) + (-> <type> <type> Bool) + (if (<cmp> x y) + true + (<eq> x y)))] + + [i>= i> i= Int] + [i<= i< i= Int] + [r>= r> r= Real] + [r<= r< r= Real] ) (do-template [<name> <cmp> <type>] - [(def__ #export (<name> x y) + [(def'' #export (<name> x y) (-> <type> <type> <type>) (<cmp> x y))] - [int:+ jvm-ladd Int] - [int:- jvm-lsub Int] - [int:* jvm-lmul Int] - [int:/ jvm-ldiv Int] - [int:% jvm-lrem Int] - [real:+ jvm-dadd Real] - [real:- jvm-dsub Real] - [real:* jvm-dmul Real] - [real:/ jvm-ddiv Real] - [real:% jvm-drem Real] + [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) +(def'' (multiple? div n) (-> Int Int Bool) - (int:= 0 (int:% n div))) + (i= 0 (i% n div))) -(def__ #export (length list) +(def'' (length list) (-> List Int) - (fold (lambda [acc _] (int:+ 1 acc)) 0 list)) + (foldL (lambda [acc _] (i+ 1 acc)) 0 list)) -(def__ #export (not x) +(def'' #export (not x) (-> Bool Bool) (if x false true)) -(def__ #export (text:++ x y) +(def'' (text:++ x y) (-> Text Text Text) - (jvm-invokevirtual java.lang.String concat [java.lang.String] - x [y])) + (_jvm_invokevirtual "java.lang.String" "concat" ["java.lang.String"] + x [y])) -(def__ (ident->text ident) +(def'' (ident->text ident) (-> Ident Text) (let [[module name] ident] ($ text:++ module ";" name))) -(def__ (replace-syntax reps syntax) +(def'' (replace-syntax reps syntax) (-> RepEnv Syntax Syntax) - (case' syntax - (#Meta [_ (#Symbol ["" name])]) - (case' (get-rep name reps) - (#Some replacement) - replacement + (_lux_case syntax + (#Meta [_ (#SymbolS ["" name])]) + (_lux_case (get-rep name reps) + (#Some replacement) + replacement - #None - syntax) + #None + syntax) - (#Meta [_ (#Form parts)]) - (#Meta [_ (#Form (map (replace-syntax reps) parts))]) + (#Meta [_ (#FormS parts)]) + (#Meta [_ (#FormS (map (replace-syntax reps) parts))]) - (#Meta [_ (#Tuple members)]) - (#Meta [_ (#Tuple (map (replace-syntax reps) members))]) + (#Meta [_ (#TupleS members)]) + (#Meta [_ (#TupleS (map (replace-syntax reps) members))]) - (#Meta [_ (#Record slots)]) - (#Meta [_ (#Record (map (:' (-> (, Syntax Syntax) (, Syntax Syntax)) + (#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) + slots))]) + + _ + syntax) ) (defmacro #export (All tokens) - (let [[self-ident tokens'] (:' (, Text SyntaxList) - (case' tokens - (#Cons [(#Meta [_ (#Symbol ["" self-ident])]) tokens']) - [self-ident tokens'] + (let [[self-ident tokens'] (_lux_: (, Text SyntaxList) + (_lux_case tokens + (#Cons [(#Meta [_ (#SymbolS ["" self-ident])]) tokens']) + [self-ident tokens'] - _ - ["" tokens]))] - (case' tokens' - (#Cons [(#Meta [_ (#Tuple args)]) (#Cons [body #Nil])]) - (case' (map% Maybe:Monad get-ident args) - (#Some idents) - (case' idents - #Nil - (return (:' SyntaxList (list body))) - - (#Cons [harg targs]) - (let [replacements (map (:' (-> Text (, Text Syntax)) - (lambda [ident] [ident (`' (#;BoundT (~ ($text ident))))])) - (list& self-ident idents)) - body' (fold (:' (-> Syntax Text Syntax) - (lambda [body' arg'] - (`' (#;AllT [#;None "" (~ ($text arg')) (~ body')])))) - (replace-syntax replacements body) - (reverse targs))] - (return (:' SyntaxList - (list (`' (#;AllT [#;None (~ ($text self-ident)) (~ ($text harg)) (~ body')]))))))) - - #None - (fail "'All' arguments must be symbols.")) - - _ - (fail "Wrong syntax for All")) + _ + ["" 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) +(def'' (get k plist) (All [a] (-> Text ($' List (, Text a)) ($' Maybe a))) - (case' plist - (#Cons [[k' v] plist']) - (if (text:= k k') - (#Some v) - (get k plist')) + (_lux_case plist + (#Cons [[k' v] plist']) + (if (text:= k k') + (#Some v) + (get k plist')) - #Nil - #None)) + #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__ #export (get-module-name state) +(def'' (get-module-name state) ($' Lux Text) - (case' state - {#source source #modules modules #module-aliases module-aliases - #envs envs #types types #host host - #seed seed} - (case' (reverse envs) - #Nil - (#Left "Can't get the module name without a module!") + (_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])))) + (#Cons [{#name module-name #inner-closures _ #locals _ #closure _} _]) + (#Right [state module-name])))) -(def__ (find-macro' modules current-module module name) - (-> ($' List (, Text ($' List (, Text (, Bool ($' DefData' (-> ($' List Syntax) ($' StateE CompilerState ($' List Syntax))))))))) +(def'' (find-macro' modules current-module module name) + (-> ($' List (, Text ($' Module Compiler))) Text Text Text ($' Maybe Macro)) - (do Maybe:Monad - [bindings (get module modules) - gdef (get name bindings)] - (case' (:' (, Bool ($' DefData' Macro)) gdef) - [exported? (#MacroD macro')] - (if exported? - (#Some macro') - (if (text:= module current-module) - (#Some macro') - #None)) + (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))) + [_ (#AliasD [r-module r-name])] + (find-macro' modules current-module r-module r-name) + + _ + #None))) -(def__ #export (find-macro ident) +(def'' (find-macro ident) (-> Ident ($' Lux ($' Maybe Macro))) - (do Lux:Monad + (do Lux/Monad [current-module get-module-name] (let [[module name] ident] - (:' ($' Lux ($' Maybe Macro)) - (lambda [state] - (case' state - {#source source #modules modules #module-aliases module-aliases - #envs envs #types types #host host - #seed seed} - (#Right [state (find-macro' modules current-module module name)]))))))) + (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) +(def'' (list:join xs) (All [a] (-> ($' List ($' List a)) ($' List a))) - (fold list:++ #Nil xs)) + (foldL list:++ #Nil xs)) -(def__ #export (normalize ident state) +(def'' (normalize ident) (-> Ident ($' Lux Ident)) - (case' ident - ["" name] - (case' state - {#source source #modules modules #module-aliases module-aliases - #envs envs #types types #host host - #seed seed} - (case' (reverse envs) - #Nil - (#Left "Can't normalize Ident without a global environment.") + (_lux_case ident + ["" name] + (do Lux/Monad + [module-name get-module-name] + (;return (_lux_: Ident [module-name name]))) - (#Cons [{#name prefix #inner-closures _ #locals _ #closure _} _]) - (#Right [state [prefix name]]))) - - _ - (#Right [state ident]))) + _ + (return ident))) (defmacro #export (| tokens) - (do Lux:Monad - [pairs (map% Lux:Monad - (:' (-> Syntax ($' Lux Syntax)) - (lambda [token] - (case' token - (#Meta [_ (#Tag ident)]) - (do Lux:Monad - [ident (normalize ident)] - (;return (:' Syntax (`' [(~ ($text (ident->text ident))) (;,)])))) + (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 [_ (#Form (#Cons [(#Meta [_ (#Tag ident)]) (#Cons [value #Nil])]))]) - (do Lux:Monad - [ident (normalize ident)] - (;return (:' Syntax (`' [(~ ($text (ident->text ident))) (~ value)])))) - - _ - (fail "Wrong syntax for |")))) + (#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 (:' SyntaxList (list (`' (#;VariantT (;list (~@ pairs))))))))) + (;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 - (:' (-> (, Syntax Syntax) ($' Lux Syntax)) - (lambda [pair] - (case' pair - [(#Meta [_ (#Tag ident)]) value] - (do Lux:Monad - [ident (normalize ident)] - (;return (:' Syntax (`' [(~ ($text (ident->text ident))) (~ value)])))) - - _ - (fail "Wrong syntax for &")))) + (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 (:' SyntaxList (list (`' (#;RecordT (;list (~@ pairs)))))))))) + (;return (list (`' (#;RecordT (~ (untemplate-list pairs))))))))) -(def__ #export (->text x) +(def'' #export (->text x) (-> (^ java.lang.Object) Text) - (jvm-invokevirtual java.lang.Object toString [] x [])) + (_jvm_invokevirtual "java.lang.Object" "toString" [] x [])) -(def__ #export (interpose sep xs) +(def'' (interpose sep xs) (All [a] (-> a ($' List a) ($' List a))) - (case' xs - #Nil - xs - - (#Cons [x #Nil]) - xs - - (#Cons [x xs']) - (list& x sep (interpose sep xs')))) - -(def__ #export (syntax:show syntax) - (-> Syntax Text) - (case' syntax - (#Meta [_ (#Bool value)]) - (->text value) - - (#Meta [_ (#Int value)]) - (->text value) - - (#Meta [_ (#Real value)]) - (->text value) - - (#Meta [_ (#Char value)]) - ($ text:++ "#\"" (->text value) "\"") - - (#Meta [_ (#Text value)]) - value - - (#Meta [_ (#Symbol ident)]) - (ident->text ident) - - (#Meta [_ (#Tag ident)]) - (text:++ "#" (ident->text ident)) - - (#Meta [_ (#Tuple members)]) - ($ text:++ "[" (|> members (map syntax:show) (interpose " ") (fold text:++ "")) "]") + (_lux_case xs + #Nil + xs - (#Meta [_ (#Form members)]) - ($ text:++ "(" (|> members (map syntax:show) (interpose " ") (fold text:++ "")) ")") + (#Cons [x #Nil]) + xs - (#Meta [_ (#Record slots)]) - ($ text:++ "{" (|> slots - (map (:' (-> (, Syntax Syntax) Text) - (lambda [slot] - (let [[k v] slot] - ($ text:++ (syntax:show k) " " (syntax:show v)))))) - (interpose " ") (fold text:++ "")) "}") - )) + (#Cons [x xs']) + (list& x sep (interpose sep xs')))) -(def__ #export (macro-expand syntax) +(def'' (macro-expand syntax) (-> Syntax ($' Lux ($' List Syntax))) - (case' syntax - (#Meta [_ (#Form (#Cons [(#Meta [_ (#Symbol macro-name)]) args]))]) - (do Lux:Monad - [macro-name' (normalize macro-name) - ?macro (find-macro macro-name')] - (case' (:' ($' Maybe Macro) ?macro) - (#Some macro) - (do Lux:Monad - [expansion (macro args) - expansion' (map% Lux:Monad macro-expand expansion)] - (;return (:' SyntaxList (list:join expansion')))) - - #None - (do Lux:Monad - [parts' (map% Lux:Monad macro-expand (list& ($symbol macro-name) args))] - (;return (:' SyntaxList (list ($form (list:join parts')))))))) + (_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 [_ (#Form (#Cons [harg targs]))]) - (do Lux:Monad - [harg+ (macro-expand harg) - targs+ (map% Lux:Monad macro-expand targs)] - (;return (:' SyntaxList (list ($form (list:++ harg+ (list:join (:' ($' List ($' List Syntax)) targs+)))))))) + (#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 [_ (#Tuple members)]) - (do Lux:Monad - [members' (map% Lux:Monad macro-expand members)] - (;return (:' SyntaxList (list ($tuple (list:join members')))))) + (#Meta [_ (#TupleS members)]) + (do Lux/Monad + [members' (map% Lux/Monad macro-expand members)] + (;return (list (tuple$ (list:join members'))))) - _ - (return (:' SyntaxList (list syntax))))) + _ + (return (list syntax)))) -(def__ (walk-type type) +(def'' (walk-type type) (-> Syntax Syntax) - (case' type - (#Meta [_ (#Form (#Cons [(#Meta [_ (#Tag tag)]) parts]))]) - ($form (#Cons [($tag tag) (map walk-type parts)])) + (_lux_case type + (#Meta [_ (#FormS (#Cons [(#Meta [_ (#TagS tag)]) parts]))]) + (form$ (#Cons [(tag$ tag) (map walk-type parts)])) - (#Meta [_ (#Tuple members)]) - ($tuple (map walk-type members)) + (#Meta [_ (#TupleS members)]) + (tuple$ (map walk-type members)) - (#Meta [_ (#Form (#Cons [type-fn args]))]) - (fold (:' (-> Syntax Syntax Syntax) - (lambda [type-fn arg] - (`' (#;AppT [(~ type-fn) (~ arg)])))) - (walk-type type-fn) - (map walk-type args)) - - _ - type)) + (#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) - (case' tokens - (#Cons [type #Nil]) - (do Lux:Monad - [type+ (macro-expand type)] - (case' (:' SyntaxList type+) - (#Cons [type' #Nil]) - (;return (:' SyntaxList (list (walk-type type')))) - - _ - (fail "type`: The expansion of the type-syntax had to yield a single element."))) +(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`"))) + _ + (fail "Wrong syntax for type"))) (defmacro #export (: tokens) - (case' tokens - (#Cons [type (#Cons [value #Nil])]) - (return (:' SyntaxList (list (`' (:' (;type` (~ type)) (~ value)))))) + (_lux_case tokens + (#Cons [type (#Cons [value #Nil])]) + (return (list (`' (_lux_: (;type (~ type)) (~ value))))) - _ - (fail "Wrong syntax for :"))) + _ + (fail "Wrong syntax for :"))) (defmacro #export (:! tokens) - (case' tokens - (#Cons [type (#Cons [value #Nil])]) - (return (:' SyntaxList (list (`' (:!' (;type` (~ type)) (~ value)))))) + (_lux_case tokens + (#Cons [type (#Cons [value #Nil])]) + (return (list (`' (_lux_:! (;type (~ type)) (~ value))))) - _ - (fail "Wrong syntax for :!"))) + _ + (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)) - (case' tokens - (#Cons [(#Meta [_ (#Tag ["" "export"])]) tokens']) - [true tokens'] + (_lux_case tokens + (#Cons [(#Meta [_ (#TagS ["" "export"])]) tokens']) + [true tokens'] - _ - [false tokens])) - parts (: (Maybe (, Syntax (List Syntax) Syntax)) - (case' tokens' - (#Cons [(#Meta [_ (#Symbol name)]) (#Cons [type #Nil])]) - (#Some [($symbol name) #Nil type]) + _ + [false tokens])) + [rec? tokens'] (: (, Bool (List Syntax)) + (_lux_case tokens' + (#Cons [(#Meta [_ (#TagS ["" "rec"])]) tokens']) + [true tokens'] - (#Cons [(#Meta [_ (#Form (#Cons [(#Meta [_ (#Symbol name)]) args]))]) (#Cons [type #Nil])]) - (#Some [($symbol name) args type]) + _ + [false tokens'])) + parts (: (Maybe (, Text (List Syntax) Syntax)) + (_lux_case tokens' + (#Cons [(#Meta [_ (#SymbolS ["" name])]) (#Cons [type #Nil])]) + (#Some [name #Nil type]) - _ - #None)) - ] - ## (return (: (List Syntax) #Nil)) - (case' parts - (#Some [name args type]) - (let [with-export (: (List Syntax) - (if export? - (list (`' (export' (~ name)))) - #Nil)) - type' (: Syntax - (case' args - #Nil - type + (#Cons [(#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS ["" name])]) args]))]) (#Cons [type #Nil])]) + (#Some [name args type]) - _ - (`' (;All (~ name) [(~@ args)] (~ type)))))] - (return (: (List Syntax) - (list& (`' (def' (~ name) (;type` (~ type')))) - with-export)))) + _ + #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")) + #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]) -(deftype #export (IO a) - (-> (,) a)) +## _ +## #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 -(defmacro #export (io tokens) - (case' tokens - (#Cons [value #Nil]) - (let [blank ($symbol ["" ""])] - (return (: (List Syntax) - (list (`' (lambda' (~ blank) (~ blank) (~ value))))))) +## _ +## (`' (;All (~ name) [(~@ args)] (~ type)))))] +## (return (list& (`' (_lux_def (~ name) (;type (~ type')))) +## with-export))) - _ - (fail "Wrong syntax for io"))) +## #None +## (fail "Wrong syntax for deftype")) +## )) (defmacro #export (exec tokens) - (case' (reverse tokens) - (#Cons [value actions]) - (let [dummy ($symbol ["" ""])] - (return (:' SyntaxList - (list (fold (:' (-> Syntax Syntax Syntax) - (lambda [post pre] - (`' (case' (~ pre) (~ dummy) (~ post))))) - value - actions))))) + (_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"))) + _ + (fail "Wrong syntax for exec"))) (defmacro #export (def tokens) (let [[export? tokens'] (: (, Bool (List Syntax)) - (case' tokens - (#Cons [(#Meta [_ (#Tag ["" "export"])]) tokens']) - [true tokens'] + (_lux_case tokens + (#Cons [(#Meta [_ (#TagS ["" "export"])]) tokens']) + [true tokens'] - _ - [false tokens])) + _ + [false tokens])) parts (: (Maybe (, Syntax (List Syntax) (Maybe Syntax) Syntax)) - (case' tokens' - (#Cons [(#Meta [_ (#Form (#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 [_ (#Form (#Cons [name args]))]) (#Cons [body #Nil])]) - (#Some [name args #None body]) - - (#Cons [name (#Cons [body #Nil])]) - (#Some [name #Nil #None body]) + (_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))] - (case' parts - (#Some [name args ?type body]) - (let [body' (: Syntax - (case' args - #Nil - body + _ + #None))] + (_lux_case parts + (#Some [name args ?type body]) + (let [body' (: Syntax + (_lux_case args + #Nil + body - _ - (`' (;lambda (~ name) [(~@ args)] (~ body))))) - body'' (: Syntax - (case' ?type - (#Some type) - (`' (: (~ type) (~ body'))) - - #None - body'))] - (return (: (List Syntax) (list& (`' (def' (~ name) (~ body''))) - (if export? - (list (`' (export' (~ name)))) - #Nil))))) - - #None - (fail "Wrong syntax for def")))) + _ + (`' (;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)) @@ -1646,39 +1659,37 @@ (list left right))) (defmacro #export (case tokens) - (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] - (case' pattern - (#Meta [_ (#Form (#Cons [(#Meta [_ (#Symbol 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 (: (List Syntax) expansion)))] - (;return (list:join (: (List (List (, Syntax Syntax))) expansions)))) + (_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 (, Syntax Syntax)) (list branch))))))) - (as-pairs branches))] - (;return (: (List Syntax) - (list (`' (case' (~ value) - (~@ (|> (: (List (List (, Syntax Syntax))) expansions) list:join (map rejoin-pair) list:join)) - )))))) + _ + (;return (list branch)))))) + (as-pairs branches))] + (;return (list (`' (_lux_case (~ value) + (~@ (|> expansions list:join (map rejoin-pair) list:join))))))) - _ - (fail "Wrong syntax for case"))) + _ + (fail "Wrong syntax for case"))) (defmacro #export (\ tokens) (case tokens (#Cons [body (#Cons [pattern #Nil])]) - (do Lux:Monad + (do Lux/Monad [pattern+ (macro-expand pattern)] - (case (: (List Syntax) pattern+) + (case pattern+ (#Cons [pattern' #Nil]) - (;return (: (List Syntax) (list pattern' body))) + (;return (list pattern' body)) _ (fail "\\ can only expand to 1 pattern."))) @@ -1694,54 +1705,46 @@ (fail "\\or can't have 0 patterns") _ - (do Lux:Monad - [patterns' (map% Lux:Monad macro-expand patterns)] - (;return (: (List Syntax) (list:join (map (: (-> Syntax (List Syntax)) - (lambda [pattern] - (list pattern body))) - (list:join (: (List (List Syntax)) 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 [<name> <offset>] - [(def #export <name> (int:+ <offset>))] + [(def #export <name> (i+ <offset>))] [inc 1] [dec -1]) -(def (int:show int) - (-> Int Text) - (jvm-invokevirtual java.lang.Object toString [] - int [])) - (defmacro #export (` tokens) - (do Lux:Monad + (do Lux/Monad [module-name get-module-name] (case tokens (\ (list template)) - (;return (: (List Syntax) - (list (untemplate (: Text module-name) template)))) + (;return (list (untemplate true module-name template))) _ (fail "Wrong syntax for `")))) -(def #export (gensym prefix state) +(def (gensym prefix state) (-> Text (Lux Syntax)) (case state - {#source source #modules modules #module-aliases module-aliases + {#source source #modules modules #envs envs #types types #host host - #seed seed} - (#Right [{#source source #modules modules #module-aliases module-aliases + #seed seed #eval? eval?} + (#Right [{#source source #modules modules #envs envs #types types #host host - #seed (inc seed)} - ($symbol ["__gensym__" (int:show seed)])]))) + #seed (inc seed) #eval? eval?} + (symbol$ ["__gensym__" (->text seed)])]))) -(def #export (macro-expand-1 token) +(def (macro-expand-1 token) (-> Syntax (Lux Syntax)) - (do Lux:Monad + (do Lux/Monad [token+ (macro-expand token)] - (case (: (List Syntax) token+) + (case token+ (\ (list token')) (;return token') @@ -1749,39 +1752,38 @@ (fail "Macro expanded to more than 1 element.")))) (defmacro #export (sig tokens) - (do Lux:Monad - [tokens' (map% Lux:Monad macro-expand-1 tokens) - members (map% Lux:Monad + (do Lux/Monad + [tokens' (map% Lux/Monad macro-expand tokens) + members (map% Lux/Monad (: (-> Syntax (Lux (, Ident Syntax))) (lambda [token] (case token - (\ (#Meta [_ (#Form (list (#Meta [_ (#Symbol ["" ":'"])]) type (#Meta [_ (#Symbol name)])))])) - (do Lux:Monad + (\ (#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 Syntax) tokens'))] - (;return (: (List Syntax) - (list (`' (#;RecordT (list (~@ (map (: (-> (, Ident Syntax) Syntax) - (lambda [pair] - (let [[name type] pair] - (`' [(~ (|> name ident->text $text)) - (~ type)])))) - (: (List (, Ident Syntax)) 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 [_ (#Tag ["" "export"])]) tokens')) + (\ (list& (#Meta [_ (#TagS ["" "export"])]) tokens')) [true tokens'] _ [false tokens])) ?parts (: (Maybe (, Syntax (List Syntax) (List Syntax))) (case tokens' - (\ (list& (#Meta [_ (#Form (list& name args))]) sigs)) + (\ (list& (#Meta [_ (#FormS (list& name args))]) sigs)) (#Some [name args sigs]) (\ (list& name sigs)) @@ -1791,50 +1793,49 @@ #None))] (case ?parts (#Some [name args sigs]) - (let [sigs' (: Syntax (case args - #Nil - (`' (;sig (~@ sigs))) + (let [sigs' (: Syntax + (case args + #Nil + (`' (;sig (~@ sigs))) - _ - (`' (;All (~ name) [(~@ args)] (;sig (~@ sigs))))))] - (return (: (List Syntax) - (list& (`' (def' (~ name) (~ sigs'))) - (if export? - (list (`' (export' (~ name)))) - #Nil))))) + _ + (`' (;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-1 tokens) - members (map% Lux:Monad + (do Lux/Monad + [tokens' (map% Lux/Monad macro-expand tokens) + members (map% Lux/Monad (: (-> Syntax (Lux (, Syntax Syntax))) (lambda [token] (case token - (\ (#Meta [_ (#Form (list (#Meta [_ (#Symbol ["" "def'"])]) (#Meta [_ (#Symbol name)]) value))])) - (do Lux:Monad + (\ (#Meta [_ (#FormS (list (#Meta [_ (#SymbolS ["" "_lux_def"])]) (#Meta [_ (#SymbolS name)]) value))])) + (do Lux/Monad [name' (normalize name)] - (;return (: (, Syntax Syntax) [($tag name') value]))) + (;return (: (, Syntax Syntax) [(tag$ name') value]))) _ (fail "Structures require defined members!")))) - (: (List Syntax) tokens'))] - (;return (: (List Syntax) - (list ($record members)))))) + (list:join tokens'))] + (;return (list (record$ members))))) (defmacro #export (defstruct tokens) (let [[export? tokens'] (: (, Bool (List Syntax)) (case tokens - (\ (list& (#Meta [_ (#Tag ["" "export"])]) tokens')) + (\ (list& (#Meta [_ (#TagS ["" "export"])]) tokens')) [true tokens'] _ [false tokens])) ?parts (: (Maybe (, Syntax (List Syntax) Syntax (List Syntax))) (case tokens' - (\ (list& (#Meta [_ (#Form (list& name args))]) type defs)) + (\ (list& (#Meta [_ (#FormS (list& name args))]) type defs)) (#Some [name args type defs]) (\ (list& name type defs)) @@ -1844,128 +1845,387 @@ #None))] (case ?parts (#Some [name args type defs]) - (let [defs' (: Syntax (case args - #Nil - (`' (;struct (~@ defs))) + (let [defs' (: Syntax + (case args + #Nil + (`' (;struct (~@ defs))) - _ - (`' (;lambda (~ name) [(~@ args)] (;struct (~@ defs))))))] - (return (: (List Syntax) - (list& (`' (def (~ name) (~ type) (~ defs'))) - (if export? - (list (`' (export' (~ name)))) - #Nil))))) + _ + (`' (;lambda (~ name) [(~@ args)] (;struct (~@ defs))))))] + (return (list& (`' (def (~ name) (~ type) (~ defs'))) + (if export? + (list (`' (_lux_export (~ name)))) + #Nil)))) #None - (fail "Wrong syntax for defsig")))) - -(defsig #export (Eq a) - (: (-> a a Bool) - =)) - -(do-template [<name> <type> <test>] - [(defstruct #export <name> (Eq <type>) - (def (= x y) - (<test> x y)))] - - [Int:Eq Int jvm-leq] - [Real:Eq Real jvm-deq]) + (fail "Wrong syntax for defstruct")))) (def #export (id x) (All [a] (-> a a)) x) -(defsig #export (Show a) - (: (-> a Text) - show)) - -(do-template [<name> <type> <body>] - [(defstruct #export <name> (Show <type>) - (def (show x) - <body>))] - - [Bool:Show Bool (->text x)] - [Int:Show Int (->text x)] - [Real:Show Real (->text x)] - [Char:Show Char ($ text:++ "#\"" (->text x) "\"")]) - -(defsig #export (Ord a) - (: (-> a a Bool) - <) - (: (-> a a Bool) - <=) - (: (-> a a Bool) - >) - (: (-> a a Bool) - >=)) - (do-template [<name> <form> <message>] [(defmacro #export (<name> tokens) (case (reverse tokens) (\ (list& last init)) - (return (: (List Syntax) - (list (fold (: (-> Syntax Syntax Syntax) - (lambda [post pre] (` <form>))) - last - init)))) + (return (list (foldL (lambda [post pre] (` <form>)) + last + init))) _ (fail <message>)))] - [and (if (~ pre) true (~ post)) "and requires >=1 clauses."] - [or (if (~ pre) (~ post) false) "or requires >=1 clauses."]) + [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 Openings + (, Text (List Ident))) + +(deftype Import + (, Text (Maybe Text) Referrals (Maybe Openings))) + +(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'])) -(do-template [<name> <type> <lt> <gt> <eq>] - [(defstruct #export <name> (Ord <type>) - (def (< x y) - (<lt> x y)) - (def (<= x y) - (or (<lt> x y) - (<eq> x y))) - (def (> x y) - (<gt> x y)) - (def (>= x y) - (or (<gt> x y) - (<eq> x y))))] + (\ (#Meta [_ (#FormS (list& (#Meta [_ (#TagS ["" "only"])]) defs))])) + (do Lux/Monad + [defs' (extract-defs defs)] + (return (: (, Referrals (List Syntax)) [(#Only defs') tokens']))) - [Int:Ord Int jvm-llt jvm-lgt jvm-leq] - [Real:Ord Real jvm-dlt jvm-dgt jvm-deq]) + (\ (#Meta [_ (#FormS (list& (#Meta [_ (#TagS ["" "exclude"])]) defs))])) + (do Lux/Monad + [defs' (extract-defs defs)] + (return (: (, Referrals (List Syntax)) [(#Exclude defs') tokens']))) -(defmacro #export (alias-lux tokens state) + _ + (fail "Incorrect syntax for referral.")) + + _ + (return (: (, Referrals (List Syntax)) [#Nothing tokens])))) + +(def (extract-symbol syntax) + (-> Syntax (Lux Ident)) + (case syntax + (#Meta [_ (#SymbolS ident)]) + (return ident) + + _ + (fail "Not a symbol."))) + +(def (parse-openings tokens) + (-> (List Syntax) (Lux (, (Maybe Openings) (List Syntax)))) + (case tokens + (\ (list& (#Meta [_ (#TagS ["" "open"])]) (#Meta [_ (#FormS (list& (#Meta [_ (#TextS prefix)]) structs))]) tokens')) + (do Lux/Monad + [structs' (map% Lux/Monad extract-symbol structs)] + (return (: (, (Maybe Openings) (List Syntax)) [(#Some [prefix structs']) tokens']))) + + _ + (return (: (, (Maybe Openings) (List Syntax)) [#None 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 + [imports' (map% Lux/Monad + (: (-> Syntax (Lux (List Import))) + (lambda [token] + (case token + (#Meta [_ (#SymbolS ["" m-name])]) + (;return (list [m-name #None #All #None])) + + (\ (#Meta [_ (#FormS (list& (#Meta [_ (#SymbolS ["" m-name])]) extra))])) + (do Lux/Monad + [alias+extra (parse-alias extra) + #let [[alias extra] alias+extra] + referral+extra (parse-referrals extra) + #let [[referral extra] referral+extra] + openings+extra (parse-openings extra) + #let [[openings extra] openings+extra] + extra (decorate-imports m-name extra) + sub-imports (parse-imports extra)] + (;return (case (: (, Referrals (Maybe Text) (Maybe Openings)) [referral alias openings]) + [#Nothing #None #None] sub-imports + _ (list& [m-name alias referral openings] sub-imports)))) + + _ + (fail "Wrong syntax for import")))) + imports)] + (;return (list:join imports')))) + +(def (module-exists? module state) + (-> Text (Lux Bool)) (case state - {#source source #modules modules #module-aliases module-aliases - #envs envs #types types #host host - #seed seed} - (case (get "lux" modules) - (#Some lux) - (let [to-alias (map (: (-> (, Text (, Bool (DefData' (-> (List Syntax) (StateE CompilerState (List Syntax)))))) + {#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))))) - lux)] - (#Right [state (map (: (-> Text Syntax) - (lambda [name] - (` ((~ ($symbol ["" "def'"])) (~ ($symbol ["" name])) - (~ ($symbol ["lux" name])))))) - (list:join to-alias))])) + (let [{#module-aliases _ #defs defs #imports _} =module] + defs))] + (#Right [state (list:join to-alias)])) #None - (#Left "Uh, oh... The universe is not working properly...")) + (#Left ($ text:++ "Unknown module: " module))) )) -(def #export (print x) - (-> Text (,)) - (jvm-invokevirtual java.io.PrintStream print [java.lang.Object] - (jvm-getstatic java.lang.System out) [x])) +(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 #export (println x) - (-> Text (,)) - (print (text:++ x "\n"))) +(def (@ idx xs) + (All [a] + (-> Int (List a) (Maybe a))) + (case xs + #Nil + #None -(def #export (some f xs) + (#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 m-openings] + (do Lux/Monad + [m-name (clean-module m-name)] + (;return (: Import [m-name m-alias m-referrals m-openings])))))) + 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 m-openings] + (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))) + #let [openings (: (List Syntax) + (case m-openings + #None + (list) + + (#Some [prefix structs]) + (map (: (-> Ident Syntax) + (lambda [struct] + (let [[_ name] struct] + (` (open (~ (symbol$ [m-name name])) (~ (text$ prefix))))))) + structs)))]] + (;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) + openings)))))) + 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 @@ -1980,22 +2240,6 @@ (#Some y) (#Some y)))) - -(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-slot slot) (-> Text (, Text Text)) (let [idx (index-of ";" slot) @@ -2003,6 +2247,154 @@ 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 @@ -2010,7 +2402,7 @@ (#Some type) (#AppT [fun arg]) - (resolve-struct-type fun) + (apply-type fun arg) (#AllT [_ _ _ body]) (resolve-struct-type body) @@ -2018,106 +2410,415 @@ _ #None)) -(defmacro #export (using tokens state) +(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 [_ (#Symbol vname)]) - (let [vname' (ident->text vname)] - (case state - {#source source #modules modules #module-aliases module-aliases - #envs envs #types types #host host - #seed seed} - (let [?struct-type (some (: (-> (Env Text (, LuxVar Type)) (Maybe Type)) - (lambda [env] - (case env - {#name _ #inner-closures _ #locals {#counter _ #mappings mappings} #closure _} - (some (: (-> (, Text (, LuxVar Type)) (Maybe Type)) - (lambda [binding] - (let [[bname [_ type]] binding] - (if (text:= vname' bname) - (#Some type) - #None)))) - mappings)))) - envs)] - (case ?struct-type - #None - (#Left ($ text:++ "Unknown structure: " vname')) + (#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 + [module name] (split-slot sname)] + [(tag$ [module name]) (symbol$ ["" 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)))) - (#Some struct-type) - (case (resolve-struct-type struct-type) - (#Some (#RecordT slots)) - (let [pattern ($record (map (: (-> (, Text Type) (, Syntax Syntax)) - (lambda [slot] - (let [[sname stype] slot - [module name] (split-slot sname)] - [($tag [module name]) ($symbol ["" name])]))) - slots)) - _ (println (text:++ "Using pattern: " (syntax:show pattern)))] - (#Right [state (list (` (case' (~ struct) (~ pattern) (~ body))))])) +(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")))) - _ - (#Left "Can only \"use\" records.")))))) +(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."))) + _ - (let [dummy ($symbol ["" ""])] - (#Right [state (list (` (case' (~ struct) - (~ dummy) - (using (~ dummy) (~ body)))))]))) + (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)]) tokens')) + (do Lux/Monad + [#let [prefix (case tokens' + (\ (list (#Meta [_ (#TextS prefix)]))) + prefix + + _ + "")] + 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$ ["" (text:++ prefix name)])) + (get@ (~ (tag$ [module name])) (~ (symbol$ struct-name)))))))) + slots)) + + _ + (fail "Can only \"open\" records."))) _ - (#Left "Wrong syntax for defsig"))) + (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 (loop tokens) -## (case' tokens -## (#Cons [bindings (#Cons [body #Nil])]) -## (let [pairs (as-pairs bindings)] -## (return (list (#Form (#Cons [(` (lambda (~ (#Symbol ["" "recur"])) (~ (#Tuple (map first pairs))) -## (~ body))) -## (map second pairs)]))))))) +(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)))) -## (defmacro (get@ tokens) -## (let [output (case' tokens -## (#Cons [tag (#Cons [record #Nil])]) -## (` (get@' (~ tag) (~ record))) + (\ (#Meta [_ (#FormS (list& (#Meta [_ (#SymbolS slot)]) args))])) + (return (` ((get@ (~ (tag$ slot)) (~ so-far)) + (~@ args)))) -## (#Cons [tag #Nil]) -## (` (lambda [record] (get@' (~ tag) record))))] -## (return (list output)))) + _ + (fail "Wrong syntax for ::")))) + start parts)] + (return (list output))) -## (defmacro (set@ tokens) -## (let [output (case' tokens -## (#Cons [tag (#Cons [value (#Cons [record #Nil])])]) -## (` (set@' (~ tag) (~ value) (~ record))) + _ + (fail "Wrong syntax for ::"))) -## (#Cons [tag (#Cons [value #Nil])]) -## (` (lambda [record] (set@' (~ tag) (~ value) record))) +(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@"))) -## (#Cons [tag #Nil]) -## (` (lambda [value record] (set@' (~ tag) value record))))] -## (return (list output)))) +(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))))))) -## (defmacro (update@ tokens) -## (let [output (case' tokens -## (#Cons [tag (#Cons [func (#Cons [record #Nil])])]) -## (` (let [_record_ (~ record)] -## (set@' (~ tag) ((~ func) (get@' (~ tag) _record_)) _record_))) + _ + (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@"))) -## (#Cons [tag (#Cons [func #Nil])]) -## (` (lambda [record] -## (` (set@' (~ tag) ((~ func) (get@' (~ tag) record)) record)))) +(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"))) -## (#Cons [tag #Nil]) -## (` (lambda [func record] -## (set@' (~ tag) (func (get@' (~ tag) record)) record))))] -## (return (list output)))) +(def #export complement + (All [a] (-> (-> a Bool) (-> a Bool))) + (. not)) -## (do-template [<name> <member> <type>] -## (def (<name> pair) -## (All [a b] (-> (, a b) <type>)) -## (case pair -## [f s] -## <member>)) +## (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))))))))) -## [first f a] -## [second s b]) +## _ +## (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 [<name> <return> <part>] + [(def #export (<name> s) + (All [a] (-> (Stream a) <return>)) + (let [[h t] (! s)] + <part>))] + + [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 [<taker> <dropper> <splitter> <det-type> <det-test> <det-step>] + [(def #export (<taker> det xs) + (All [a] + (-> <det-type> (Stream a) (List a))) + (let [[x xs'] (! xs)] + (if <det-test> + (list& x (<taker> <det-step> xs')) + (list)))) + + (def #export (<dropper> det xs) + (All [a] + (-> <det-type> (Stream a) (Stream a))) + (let [[x xs'] (! xs)] + (if <det-test> + (<dropper> <det-step> xs') + xs))) + + (def #export (<splitter> det xs) + (All [a] + (-> <det-type> (Stream a) (, (List a) (Stream a)))) + (let [[x xs'] (! xs)] + (if <det-test> + (let [[tail next] (<splitter> <det-step> 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..ce9a7e7de --- /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 + (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..a03c1499a --- /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 [<name> <unit> <op>] + [(defstruct #export <name> (m;Monoid Bool) + (def m;unit <unit>) + (def (m;++ x y) + (<op> 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..5a811c006 --- /dev/null +++ b/source/lux/data/char.lux @@ -0,0 +1,21 @@ +## 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) + (text #as T #open ("text:" Text/Monoid)))) + +## [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 [<name> <side> <tag>] + [(def #export (<name> es) + (All [a b] (-> (List (Either a b)) (List <side>))) + (case es + #;Nil #;Nil + (#;Cons [(<tag> x) es']) (#;Cons [x (<name> es')]) + (#;Cons [_ es']) (<name> 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..a194fc854 --- /dev/null +++ b/source/lux/data/io.lux @@ -0,0 +1,52 @@ +## 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)) + (.. list + (text #as T #open ("text:" Text/Monoid)))) + +## 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..8fd5c2951 --- /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 [<name> <then> <else>] + [(def #export (<name> n xs) + (All [a] + (-> Int (List a) (List a))) + (if (i> n 0) + (case xs + #;Nil + #;Nil + + (#;Cons [x xs']) + <then>) + <else>))] + + [take (#;Cons [x (take (dec n) xs')]) #;Nil] + [drop (drop (dec n) xs') xs] + ) + +(do-template [<name> <then> <else>] + [(def #export (<name> p xs) + (All [a] + (-> (-> a Bool) (List a) (List a))) + (case xs + #;Nil + #;Nil + + (#;Cons [x xs']) + (if (p x) + <then> + <else>)))] + + [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 [<name> <init> <op>] + [(def #export (<name> p xs) + (All [a] + (-> (-> a Bool) (List a) Bool)) + (foldL (lambda [_1 _2] (<op> _1 (p _2))) <init> 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 ++ 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..8771ef06e --- /dev/null +++ b/source/lux/data/number.lux @@ -0,0 +1,113 @@ +## 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) + (ord #as O) + (bounded #as B) + (show #as S))) + +## Signatures +(defsig #export (Number n) + (do-template [<name>] + [(: (-> n n n) <name>)] + [+] [-] [*] [/] [%]) + + (: (-> Int n) + from-int) + + (do-template [<name>] + [(: (-> n n) <name>)] + [negate] [signum] [abs]) + ) + +## [Structures] +## Number +(do-template [<name> <type> <+> <-> <*> </> <%> <=> <<> <from> <0> <1> <-1>] + [(defstruct #export <name> (Number <type>) + (def + <+>) + (def - <->) + (def * <*>) + (def / </>) + (def % <%>) + (def (from-int x) + (<from> 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 +(do-template [<name> <type> <eq> <lt> <gt>] + [(defstruct #export <name> (O;Ord <type>) + (def O;_eq <eq>) + (def O;< <lt>) + (def (O;<= x y) + (or (<lt> x y) + (:: <eq> (E;= x y)))) + (def O;> <gt>) + (def (O;>= x y) + (or (<gt> x y) + (:: <eq> (E;= x y)))))] + + [ Int/Ord Int Int/Eq i< i>] + [Real/Ord Real Real/Eq r< r>]) + +## Bounded +(do-template [<name> <type> <top> <bottom>] + [(defstruct #export <name> (B;Bounded <type>) + (def B;top <top>) + (def B;bottom <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 [<name> <type> <unit> <++>] + [(defstruct #export <name> (m;Monoid <type>) + (def m;unit <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 [<name> <type> <body>] + [(defstruct #export <name> (S;Show <type>) + (def (S;show x) + <body>))] + + [ 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 [<name>] + [(: (-> a a Bool) <name>)] + + [<] [<=] [>] [>=])) + +## [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 [<name> <op>] + [(def #export (<name> ord x y) + (All [a] + (-> (Ord a) a a a)) + (if (:: ord (<op> 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..6ad9cfd63 --- /dev/null +++ b/source/lux/data/text.lux @@ -0,0 +1,141 @@ +## 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 [<name> <method>] + [(def #export (<name> x) + (-> Text Text) + (_jvm_invokevirtual "java.lang.String" <method> [] + 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))) + (#;Some (_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 [<common> <general> <method>] + [(def #export (<general> 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" <method> ["java.lang.String" "int"] + x [pattern (_jvm_l2i from)])) + -1 #;None + idx (#;Some idx)) + #;None)) + + (def #export (<common> pattern x) + (-> Text Text (Maybe Int)) + (case (_jvm_i2l (_jvm_invokevirtual "java.lang.String" <method> ["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) + + (do-template [<name> <op>] + [(def (<name> x y) + (<op> (_jvm_i2l (_jvm_invokevirtual "java.lang.String" "compareTo" ["java.lang.String"] + x [y])) + 0))] + + [O;< i<] + [O;<= i<=] + [O;> i>] + [O;>= i>=])) + +(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/jvm.lux b/source/lux/host/jvm.lux new file mode 100644 index 000000000..7af043969 --- /dev/null +++ b/source/lux/host/jvm.lux @@ -0,0 +1,238 @@ +## 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 #as l #refer #all #open ("" List/Functor)) + (text #as text)) + (meta lux + macro + syntax))) + +## [Utils] +## Parsers +(def finally^ + (Parser Syntax) + (form^ (do Parser/Monad + [_ (symbol?^ ["" "finally"]) + expr id^] + (M;wrap expr)))) + +(def catch^ + (Parser (, Text Ident Syntax)) + (form^ (do Parser/Monad + [_ (symbol?^ ["" "catch"]) + ex-class local-symbol^ + ex symbol^ + expr id^] + (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^] + (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^] + (M;wrap [modifiers name class])))) + +(def arg-decl^ + (Parser (, Text Text)) + (form^ (do Parser/Monad + [arg-name local-symbol^ + arg-class local-symbol^] + (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^] + (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^)) + _ (: (Parser (,)) + (if (i= (size arity-classes) + (size arity-args)) + (M;wrap []) + (lambda [_] #;None)))] + (M;wrap [method arity-classes arity-args]) + ))) + +## [Syntax] +(defsyntax #export (throw ex) + (emit (list (` (_jvm_throw (~ ex)))))) + +(defsyntax #export (try body [catches (*^ catch^)] [finally (?^ finally^)]) + (emit (list (` (_jvm_try (~ body) + (~@ (:: List/Monoid (m;++ (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^)]) + (let [members' (map (: (-> (, (List Text) Text (List Text) Text) Syntax) + (lambda [member] + (let [[modifiers name inputs output] member] + (` ((~ (text$ name)) [(~@ (map text$ inputs))] (~ (text$ output)) [(~@ (map text$ modifiers))]))))) + members)] + (emit (list (` (_jvm_interface (~ (text$ name)) [(~@ (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 [fields' (map (: (-> (, (List Text) Text Text) Syntax) + (lambda [field] + (let [[modifiers name class] field] + (` ((~ (text$ name)) + (~ (text$ class)) + [(~@ (map text$ modifiers))]))))) + fields) + methods' (map (: (-> (, (List Text) Text (List (, Text Text)) Text Syntax) Syntax) + (lambda [methods] + (let [[modifiers name inputs output body] methods] + (` ((~ (text$ name)) + [(~@ (map (: (-> (, Text Text) Syntax) + (lambda [in] + (let [[left right] in] + (form$ (list (symbol$ ["" left]) + (text$ right)))))) + inputs))] + (~ (text$ output)) + [(~@ (map text$ modifiers))] + (~ body)))))) + methods)]] + (emit (list (` (_jvm_class (~ (text$ name)) (~ (text$ super)) + [(~@ (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)) + [(~@ (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_monitorenter (~ g!lock)) + (~ g!body) (~ body) + _ (_jvm_monitorexit (~ 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) + (emit (list (` (_jvm_getfield (~ (text$ class)) (~ (text$ field)))))) + + _ + (fail "Can only get field from object."))) + + _ + (do Lux/Monad + [g!obj (gensym "")] + (emit (list (` (;let [(~ g!obj) (~ obj)] + (.? (~ (text$ 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) + (emit (list (` (_jvm_putfield (~ (text$ class)) (~ (text$ field)) (~ value))))) + + _ + (fail "Can only set field of object."))) + + _ + (do Lux/Monad + [g!obj (gensym "")] + (emit (list (` (;let [(~ g!obj) (~ obj)] + (.= (~ (text$ field)) (~ value) (~ g!obj))))))))) + +(defsyntax #export (.! [call method-call^] obj) + (let [[m-name ?m-classes m-args] call] + (case obj + (#;Meta [_ (#;SymbolS obj-name)]) + (do Lux/Monad + [obj-type (find-var-type obj-name)] + (case obj-type + (#;DataT class) + (emit (list (` (_jvm_invokevirtual (~ (text$ class)) (~ (text$ m-name)) [(~@ (map text$ ?m-classes))] + (~ obj) [(~@ m-args)])))) + + _ + (fail "Can only call method on object."))) + + _ + (do Lux/Monad + [g!obj (gensym "")] + (emit (list (` (;let [(~ g!obj) (~ obj)] + (.! ((~ (symbol$ ["" m-name])) + [(~@ (map (lambda [c] (symbol$ ["" c])) ?m-classes))] + [(~@ m-args)]) + (~ g!obj)))))))))) + +(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^]) + (let [[m-name m-classes m-args] call] + (emit (list (` (_jvm_invokestatic (~ (text$ class)) (~ (text$ m-name)) + [(~@ (map text$ m-classes))] + [(~@ m-args)])))))) diff --git a/source/lux/math.lux b/source/lux/math.lux new file mode 100644 index 000000000..a495d130c --- /dev/null +++ b/source/lux/math.lux @@ -0,0 +1,63 @@ +## 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 [<name> <value>] + [(def #export <name> + Real + (_jvm_getstatic "java.lang.Math" <value>))] + + [e "E"] + [pi "PI"] + ) + +## [Functions] +(do-template [<name> <method>] + [(def #export (<name> n) + (-> Real Real) + (_jvm_invokestatic "java.lang.Math" <method> ["double"] [n]))] + + [cos "cos"] + [sin "sin"] + [tan "tan"] + + [acos "acos"] + [asin "asin"] + [atan "atan"] + + [cosh "cosh"] + [sinh "sinh"] + [tanh "tanh"] + + [ceil "ceil"] + [floor "floor"] + + [exp "exp"] + [log "log"] + + [cbrt "cbrt"] + [sqrt "sqrt"] + + [->degrees "toDegrees"] + [->radians "toRadians"] + ) + +(def #export (round n) + (-> Real Int) + (_jvm_invokestatic "java.lang.Math" "round" ["double"] [n])) + +(do-template [<name> <method>] + [(def #export (<name> x y) + (-> Real Real Real) + (_jvm_invokestatic "java.lang.Math" <method> ["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..19b7dd9df --- /dev/null +++ b/source/lux/meta/lux.lux @@ -0,0 +1,288 @@ +## 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) + (text #as T #open ("text:" Text/Monoid Text/Eq)))) + +## [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 (join (:: _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:++ text:unit)))))) + (:: List/Functor) + (interpose "\n") + (foldL text:++ text:unit))) + +(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 [<name> <type> <tag>] + [(def #export (<name> x) + (-> <type> Syntax) + (#;Meta [["" -1 -1] (<tag> 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..63ab81475 --- /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 #open ("text:" Text/Monoid Text/Eq)) + 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 [<name> <type> <tag>] + [(def #export (<name> tokens) + (Parser <type>) + (case tokens + (#;Cons [(#;Meta [_ (<tag> 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 [<name> <tag>] + [(def #export (<name> tokens) + (Parser Text) + (case tokens + (#;Cons [(#;Meta [_ (<tag> ["" 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 [<name> <type> <tag> <eq>] + [(def #export (<name> v tokens) + (-> <type> (Parser (,))) + (case tokens + (#;Cons [(#;Meta [_ (<tag> x)]) tokens']) + (if (<eq> 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 [<name> <tag>] + [(def #export (<name> p tokens) + (All [a] + (-> (Parser a) (Parser a))) + (case tokens + (#;Cons [(#;Meta [_ (<tag> 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 + (: (List (, Syntax Syntax)) (list& [(symbol$ ["" ""]) (` end^)] (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 index 22bbad2d5..086506725 100644 --- a/source/program.lux +++ b/source/program.lux @@ -1,18 +1,48 @@ -(;alias-lux) +## 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. -(def (filter p xs) - (All [a] (-> (-> a Bool) (List a) (List a))) - (case xs - #;Nil - (list) +(;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 #open ("text:" Text/Monoid)) + writer) + (host jvm) + (meta lux + macro + syntax) + (math #as m) + )) - (#;Cons [x xs']) - (if (p x) - (list& x (filter p xs')) - (filter p xs')))) +(program args + (case args + (\ (list name)) + (println ($ text:++ "Hello, " name "!")) -(jvm-program _ - (exec (println "Hello, world!") - (println ($ text:++ "2 + 2 = " (->text (int:+ 2 2)))) - (println (->text (using Int:Ord - (< 5 10)))))) + _ + (println "Hello, world!"))) diff --git a/src/lux.clj b/src/lux.clj index de302b260..7e3627cd7 100644 --- a/src/lux.clj +++ b/src/lux.clj @@ -1,25 +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. + (ns lux (:gen-class) (:require [lux.base :as &] [lux.compiler :as &compiler] :reload-all)) -(defn -main [& _] - (time (&compiler/compile-all (&/|list "program"))) - (System/exit 0)) +(defn -main [& [program-module & _]] + (if program-module + (time (&compiler/compile-program program-module)) + (println "Please provide a module name to compile.")) + (System/exit 0) + ) (comment - ;; TODO: Finish total-locals - - (time (&compiler/compile-all (&/|list "program"))) - - (time (&compiler/compile-all (&/|list "lux"))) - (System/gc) - (time (&compiler/compile-all (&/|list "lux" "test2"))) - - ;; jar cvf test2.jar *.class test2 && java -cp "test2.jar" test2 - ;; jar cvf program.jar output/*.class output/program && java -cp "program.jar" program - ;; cd output && jar cvf test2.jar * && java -cp "test2.jar" test2 && cd .. - - ;; cd output && jar cvf program.jar * && java -cp "program.jar" program && cd .. + (-main "program") ) diff --git a/src/lux/analyser.clj b/src/lux/analyser.clj index e2cdb83ce..de7fc8497 100644 --- a/src/lux/analyser.clj +++ b/src/lux/analyser.clj @@ -1,8 +1,16 @@ +;; 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.analyser (:require (clojure [template :refer [do-template]]) [clojure.core.match :as M :refer [matchv]] clojure.core.match.array - (lux [base :as & :refer [|do return fail return* fail* |list]] + (lux [base :as & :refer [|let |do return fail return* fail*]] [reader :as &reader] [parser :as &parser] [type :as &type] @@ -14,515 +22,533 @@ ;; [Utils] (defn ^:private parse-handler [[catch+ finally+] token] (matchv ::M/objects [token] - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-catch"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ ?ex-class]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ ?ex-arg]]]] - ["lux;Cons" [?catch-body - ["lux;Nil" _]]]]]]]]]]]]] - (&/T (&/|++ catch+ (|list (&/T ?ex-class ?ex-arg ?catch-body))) finally+) - - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-finally"]]]] - ["lux;Cons" [?finally-body - ["lux;Nil" _]]]]]]]]] - (&/T catch+ ?finally-body))) + [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_catch"]]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?ex-class]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ ?ex-arg]]]] + ["lux;Cons" [?catch-body + ["lux;Nil" _]]]]]]]]]]]]] + (&/T (&/|++ catch+ (&/|list (&/T ?ex-class ?ex-arg ?catch-body))) finally+) -(defn ^:private _meta [token] - (&/V "lux;Meta" (&/T (&/T "" -1 -1) token))) + [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_finally"]]]] + ["lux;Cons" [?finally-body + ["lux;Nil" _]]]]]]]]] + (&/T catch+ (&/V "lux;Some" ?finally-body)))) -(defn ^:private aba1 [analyse eval! exo-type token] +(defn ^:private aba7 [analyse eval! compile-module exo-type token] (matchv ::M/objects [token] - ;; Standard special forms - [["lux;Meta" [meta ["lux;Bool" ?value]]]] - (|do [_ (&type/check exo-type &type/Bool)] - (return (&/|list (&/T (&/V "bool" ?value) exo-type)))) - - [["lux;Meta" [meta ["lux;Int" ?value]]]] - (|do [_ (&type/check exo-type &type/Int)] - (return (&/|list (&/T (&/V "int" ?value) exo-type)))) - - [["lux;Meta" [meta ["lux;Real" ?value]]]] - (|do [_ (&type/check exo-type &type/Real)] - (return (&/|list (&/T (&/V "real" ?value) exo-type)))) + ;; Arrays + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_new-array"]]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ ?class]]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;IntS" ?length]]] + ["lux;Nil" _]]]]]]]]] + (&&host/analyse-jvm-new-array analyse ?class ?length) - [["lux;Meta" [meta ["lux;Char" ?value]]]] - (|do [_ (&type/check exo-type &type/Char)] - (return (&/|list (&/T (&/V "char" ?value) exo-type)))) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_aastore"]]]] + ["lux;Cons" [?array + ["lux;Cons" [["lux;Meta" [_ ["lux;IntS" ?idx]]] + ["lux;Cons" [?elem + ["lux;Nil" _]]]]]]]]]]] + (&&host/analyse-jvm-aastore analyse ?array ?idx ?elem) - [["lux;Meta" [meta ["lux;Text" ?value]]]] - (|do [_ (&type/check exo-type &type/Text)] - (return (&/|list (&/T (&/V "text" ?value) exo-type)))) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_aaload"]]]] + ["lux;Cons" [?array + ["lux;Cons" [["lux;Meta" [_ ["lux;IntS" ?idx]]] + ["lux;Nil" _]]]]]]]]] + (&&host/analyse-jvm-aaload analyse ?array ?idx) - [["lux;Meta" [meta ["lux;Tuple" ?elems]]]] - (&&lux/analyse-tuple analyse exo-type ?elems) + ;; Classes & interfaces + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_class"]]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?name]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?super-class]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?interfaces]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?fields]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?methods]]] + ["lux;Nil" _]]]]]]]]]]]]]]] + (&&host/analyse-jvm-class analyse ?name ?super-class ?interfaces ?fields ?methods) - [["lux;Meta" [meta ["lux;Record" ?elems]]]] - (&&lux/analyse-record analyse exo-type ?elems) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_interface"]]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?name]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?supers]]] + ?methods]]]]]]]] + (&&host/analyse-jvm-interface analyse ?name ?supers ?methods) - [["lux;Meta" [meta ["lux;Tag" ?ident]]]] - (&&lux/analyse-variant analyse exo-type ?ident (_meta (&/V "lux;Tuple" (|list)))) + ;; Programs + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_program"]]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ?args]]] + ["lux;Cons" [?body + ["lux;Nil" _]]]]]]]]] + (&&host/analyse-jvm-program analyse ?args ?body) - [["lux;Meta" [meta ["lux;Symbol" [_ "jvm-null"]]]]] - (return (&/|list (&/T (&/V "jvm-null" nil) (&/V "lux;DataT" "null")))) - [_] - (fail "") - )) + (fail ""))) -(defn ^:private aba2 [analyse eval! exo-type token] +(defn ^:private aba6 [analyse eval! compile-module exo-type token] (matchv ::M/objects [token] - [["lux;Meta" [meta ["lux;Symbol" ?ident]]]] - (&&lux/analyse-symbol analyse exo-type ?ident) + ;; Primitive conversions + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_d2f"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] + (&&host/analyse-jvm-d2f analyse exo-type ?value) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "case'"]]]] - ["lux;Cons" [?value ?branches]]]]]]]] - (&&lux/analyse-case analyse exo-type ?value ?branches) - - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "lambda'"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" ?self]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" ?arg]]] - ["lux;Cons" [?body - ["lux;Nil" _]]]]]]]]]]]]] - (&&lux/analyse-lambda analyse exo-type ?self ?arg ?body) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_d2i"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] + (&&host/analyse-jvm-d2i analyse exo-type ?value) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "def'"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" ["" ?name]]]] - ["lux;Cons" [?value - ["lux;Nil" _]]]]]]]]]]] - (do ;; (when (= "if" ?name) - ;; (prn "if" (&/show-ast ?value))) - (&&lux/analyse-def analyse ?name ?value)) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_d2l"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] + (&&host/analyse-jvm-d2l analyse exo-type ?value) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "declare-macro'"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" ["" ?name]]]] - ["lux;Nil" _]]]]]]]]] - (&&lux/analyse-declare-macro analyse ?name) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_f2d"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] + (&&host/analyse-jvm-f2d analyse exo-type ?value) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "import'"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;Text" ?path]]] - ["lux;Nil" _]]]]]]]]] - (&&lux/analyse-import analyse ?path) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_f2i"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] + (&&host/analyse-jvm-f2i analyse exo-type ?value) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ ":'"]]]] - ["lux;Cons" [?type - ["lux;Cons" [?value - ["lux;Nil" _]]]]]]]]]]] - (&&lux/analyse-check analyse eval! exo-type ?type ?value) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_f2l"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] + (&&host/analyse-jvm-f2l analyse exo-type ?value) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ ":!'"]]]] - ["lux;Cons" [?type - ["lux;Cons" [?value - ["lux;Nil" _]]]]]]]]]]] - (&&lux/analyse-coerce analyse eval! ?type ?value) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_i2b"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] + (&&host/analyse-jvm-i2b analyse exo-type ?value) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "export'"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" ["" ?ident]]]] - ["lux;Nil" _]]]]]]]]] - (&&lux/analyse-export analyse ?ident) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_i2c"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] + (&&host/analyse-jvm-i2c analyse exo-type ?value) - [_] - (fail ""))) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_i2d"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] + (&&host/analyse-jvm-i2d analyse exo-type ?value) -(defn ^:private aba3 [analyse eval! exo-type token] - (matchv ::M/objects [token] - ;; Host special forms - ;; Integer arithmetic - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-iadd"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] - (&&host/analyse-jvm-iadd analyse ?x ?y) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_i2f"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] + (&&host/analyse-jvm-i2f analyse exo-type ?value) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-isub"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] - (&&host/analyse-jvm-isub analyse ?x ?y) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_i2l"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] + (&&host/analyse-jvm-i2l analyse exo-type ?value) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-imul"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] - (&&host/analyse-jvm-imul analyse ?x ?y) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_i2s"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] + (&&host/analyse-jvm-i2s analyse exo-type ?value) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-idiv"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] - (&&host/analyse-jvm-idiv analyse ?x ?y) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_l2d"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] + (&&host/analyse-jvm-l2d analyse exo-type ?value) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-irem"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] - (&&host/analyse-jvm-irem analyse ?x ?y) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_l2f"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] + (&&host/analyse-jvm-l2f analyse exo-type ?value) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-ieq"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] - (&&host/analyse-jvm-ieq analyse ?x ?y) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_l2i"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] + (&&host/analyse-jvm-l2i analyse exo-type ?value) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-ilt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] - (&&host/analyse-jvm-ilt analyse ?x ?y) - - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-igt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] - (&&host/analyse-jvm-igt analyse ?x ?y) - - ;; Long arithmetic - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-ladd"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] - (&&host/analyse-jvm-ladd analyse ?x ?y) + ;; Bitwise operators + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_iand"]]]] ["lux;Cons" [?x ["lux;Cons" [?y ["lux;Nil" _]]]]]]]]] + (&&host/analyse-jvm-iand analyse exo-type ?x ?y) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-lsub"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] - (&&host/analyse-jvm-lsub analyse ?x ?y) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_ior"]]]] ["lux;Cons" [?x ["lux;Cons" [?y ["lux;Nil" _]]]]]]]]] + (&&host/analyse-jvm-ior analyse exo-type ?x ?y) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-lmul"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] - (&&host/analyse-jvm-lmul analyse ?x ?y) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_land"]]]] ["lux;Cons" [?x ["lux;Cons" [?y ["lux;Nil" _]]]]]]]]] + (&&host/analyse-jvm-land analyse exo-type ?x ?y) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-ldiv"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] - (&&host/analyse-jvm-ldiv analyse ?x ?y) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_lor"]]]] ["lux;Cons" [?x ["lux;Cons" [?y ["lux;Nil" _]]]]]]]]] + (&&host/analyse-jvm-lor analyse exo-type ?x ?y) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-lrem"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] - (&&host/analyse-jvm-lrem analyse ?x ?y) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_lxor"]]]] ["lux;Cons" [?x ["lux;Cons" [?y ["lux;Nil" _]]]]]]]]] + (&&host/analyse-jvm-lxor analyse exo-type ?x ?y) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-leq"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] - (&&host/analyse-jvm-leq analyse ?x ?y) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_lshl"]]]] ["lux;Cons" [?x ["lux;Cons" [?y ["lux;Nil" _]]]]]]]]] + (&&host/analyse-jvm-lshl analyse exo-type ?x ?y) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-llt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] - (&&host/analyse-jvm-llt analyse ?x ?y) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_lshr"]]]] ["lux;Cons" [?x ["lux;Cons" [?y ["lux;Nil" _]]]]]]]]] + (&&host/analyse-jvm-lshr analyse exo-type ?x ?y) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-lgt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] - (&&host/analyse-jvm-lgt analyse ?x ?y) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_lushr"]]]] ["lux;Cons" [?x ["lux;Cons" [?y ["lux;Nil" _]]]]]]]]] + (&&host/analyse-jvm-lushr analyse exo-type ?x ?y) [_] - (fail ""))) + (aba7 analyse eval! compile-module exo-type token))) -(defn ^:private aba4 [analyse eval! exo-type token] +(defn ^:private aba5 [analyse eval! compile-module exo-type token] (matchv ::M/objects [token] - ;; Float arithmetic - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-fadd"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] - (&&host/analyse-jvm-fadd analyse ?x ?y) - - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-fsub"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] - (&&host/analyse-jvm-fsub analyse ?x ?y) - - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-fmul"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] - (&&host/analyse-jvm-fmul analyse ?x ?y) + ;; Objects + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_null?"]]]] + ["lux;Cons" [?object + ["lux;Nil" _]]]]]]] + (&&host/analyse-jvm-null? analyse exo-type ?object) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-fdiv"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] - (&&host/analyse-jvm-fdiv analyse ?x ?y) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_instanceof"]]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?class]]] + ["lux;Cons" [?object + ["lux;Nil" _]]]]]]]]] + (&&host/analyse-jvm-instanceof analyse exo-type ?class ?object) + + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_new"]]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?class]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?classes]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?args]]] + ["lux;Nil" _]]]]]]]]]]] + (&&host/analyse-jvm-new analyse exo-type ?class ?classes ?args) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-frem"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] - (&&host/analyse-jvm-frem analyse ?x ?y) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_getstatic"]]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?class]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?field]]] + ["lux;Nil" _]]]]]]]]] + (&&host/analyse-jvm-getstatic analyse exo-type ?class ?field) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-feq"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] - (&&host/analyse-jvm-feq analyse ?x ?y) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_getfield"]]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?class]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?field]]] + ["lux;Cons" [?object + ["lux;Nil" _]]]]]]]]]]] + (&&host/analyse-jvm-getfield analyse exo-type ?class ?field ?object) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-flt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] - (&&host/analyse-jvm-flt analyse ?x ?y) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_putstatic"]]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?class]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?field]]] + ["lux;Cons" [?value + ["lux;Nil" _]]]]]]]]]]] + (&&host/analyse-jvm-putstatic analyse exo-type ?class ?field ?value) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-fgt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] - (&&host/analyse-jvm-fgt analyse ?x ?y) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_putfield"]]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?class]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?field]]] + ["lux;Cons" [?object + ["lux;Cons" [?value + ["lux;Nil" _]]]]]]]]]]]]] + (&&host/analyse-jvm-putfield analyse exo-type ?class ?field ?object ?value) - ;; Double arithmetic - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-dadd"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] - (&&host/analyse-jvm-dadd analyse ?x ?y) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_invokestatic"]]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?class]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?method]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?classes]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?args]]] + ["lux;Nil" _]]]]]]]]]]]]] + (&&host/analyse-jvm-invokestatic analyse exo-type ?class ?method ?classes ?args) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-dsub"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] - (&&host/analyse-jvm-dsub analyse ?x ?y) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_invokevirtual"]]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?class]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?method]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?classes]]] + ["lux;Cons" [?object + ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?args]]] + ["lux;Nil" _]]]]]]]]]]]]]]] + (&&host/analyse-jvm-invokevirtual analyse exo-type ?class ?method ?classes ?object ?args) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-dmul"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] - (&&host/analyse-jvm-dmul analyse ?x ?y) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_invokeinterface"]]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?class]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?method]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?classes]]] + ["lux;Cons" [?object + ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?args]]] + ["lux;Nil" _]]]]]]]]]]]]]]] + (&&host/analyse-jvm-invokeinterface analyse exo-type ?class ?method ?classes ?object ?args) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-ddiv"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] - (&&host/analyse-jvm-ddiv analyse ?x ?y) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_invokespecial"]]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?class]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?method]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?classes]]] + ["lux;Cons" [?object + ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?args]]] + ["lux;Nil" _]]]]]]]]]]]]]]] + (&&host/analyse-jvm-invokespecial analyse exo-type ?class ?method ?classes ?object ?args) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-drem"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] - (&&host/analyse-jvm-drem analyse ?x ?y) + ;; Exceptions + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_try"]]]] + ["lux;Cons" [?body + ?handlers]]]]]] + (&&host/analyse-jvm-try analyse exo-type ?body (&/fold parse-handler (&/T (&/|list) (&/V "lux;None" nil)) ?handlers)) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-deq"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] - (&&host/analyse-jvm-deq analyse ?x ?y) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_throw"]]]] + ["lux;Cons" [?ex + ["lux;Nil" _]]]]]]] + (&&host/analyse-jvm-throw analyse exo-type ?ex) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-dlt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] - (&&host/analyse-jvm-dlt analyse ?x ?y) + ;; Syncronization/monitos + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_monitorenter"]]]] + ["lux;Cons" [?monitor + ["lux;Nil" _]]]]]]] + (&&host/analyse-jvm-monitorenter analyse exo-type ?monitor) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-dgt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] - (&&host/analyse-jvm-dgt analyse ?x ?y) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_monitorexit"]]]] + ["lux;Cons" [?monitor + ["lux;Nil" _]]]]]]] + (&&host/analyse-jvm-monitorexit analyse exo-type ?monitor) [_] - (fail ""))) + (aba6 analyse eval! compile-module exo-type token))) -(defn ^:private aba5 [analyse eval! exo-type token] +(defn ^:private aba4 [analyse eval! compile-module exo-type token] (matchv ::M/objects [token] - ;; Objects - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-null?"]]]] - ["lux;Cons" [?object - ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-null? analyse ?object) - - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-new"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ ?class]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;Tuple" ?classes]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;Tuple" ?args]]] - ["lux;Nil" _]]]]]]]]]]]]] - (&&host/analyse-jvm-new analyse ?class ?classes ?args) - - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-getstatic"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" ["" ?class]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" ["" ?field]]]] - ["lux;Nil" _]]]]]]]]]]] - (&&host/analyse-jvm-getstatic analyse ?class ?field) + ;; Float arithmetic + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_fadd"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + (&&host/analyse-jvm-fadd analyse exo-type ?x ?y) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-getfield"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" ["" ?class]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" ["" ?field]]]] - ["lux;Cons" [?object - ["lux;Nil" _]]]]]]]]]]]]] - (&&host/analyse-jvm-getfield analyse ?class ?field ?object) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_fsub"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + (&&host/analyse-jvm-fsub analyse exo-type ?x ?y) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-putstatic"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" ["" ?class]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" ["" ?field]]]] - ["lux;Cons" [?value - ["lux;Nil" _]]]]]]]]]]]]] - (&&host/analyse-jvm-putstatic analyse ?class ?field ?value) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_fmul"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + (&&host/analyse-jvm-fmul analyse exo-type ?x ?y) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-putfield"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" ["" ?class]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" ["" ?field]]]] - ["lux;Cons" [?object - ["lux;Cons" [?value - ["lux;Nil" _]]]]]]]]]]]]]]] - (&&host/analyse-jvm-putfield analyse ?class ?field ?object ?value) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_fdiv"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + (&&host/analyse-jvm-fdiv analyse exo-type ?x ?y) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-invokestatic"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" ["" ?class]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" ["" ?method]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;Tuple" ?classes]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;Tuple" ?args]]] - ["lux;Nil" _]]]]]]]]]]]]]]] - (&&host/analyse-jvm-invokestatic analyse ?class ?method ?classes ?args) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_frem"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + (&&host/analyse-jvm-frem analyse exo-type ?x ?y) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-invokevirtual"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" ["" ?class]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" ["" ?method]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;Tuple" ?classes]]] - ["lux;Cons" [?object - ["lux;Cons" [["lux;Meta" [_ ["lux;Tuple" ?args]]] - ["lux;Nil" _]]]]]]]]]]]]]]]]] - (&&host/analyse-jvm-invokevirtual analyse ?class ?method ?classes ?object ?args) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_feq"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + (&&host/analyse-jvm-feq analyse exo-type ?x ?y) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-invokeinterface"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" ["" ?class]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" ["" ?method]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;Tuple" ?classes]]] - ["lux;Cons" [?object - ["lux;Cons" [["lux;Meta" [_ ["lux;Tuple" ?args]]] - ["lux;Nil" _]]]]]]]]]]]]]]]]] - (&&host/analyse-jvm-invokeinterface analyse ?class ?method ?classes ?object ?args) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_flt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + (&&host/analyse-jvm-flt analyse exo-type ?x ?y) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-invokespecial"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" ["" ?class]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" ["" ?method]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;Tuple" ?classes]]] - ["lux;Cons" [?object - ["lux;Cons" [["lux;Meta" [_ ["lux;Tuple" ?args]]] - ["lux;Nil" _]]]]]]]]]]]]]]]]] - (&&host/analyse-jvm-invokespecial analyse ?class ?method ?classes ?object ?args) - - ;; Exceptions - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-try"]]]] - ["lux;Cons" [?body - ?handlers]]]]]]]] - (&&host/analyse-jvm-try analyse ?body (&/fold parse-handler [(list) nil] ?handlers)) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_fgt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + (&&host/analyse-jvm-fgt analyse exo-type ?x ?y) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-throw"]]]] - ["lux;Cons" [?ex - ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-throw analyse ?ex) + ;; Double arithmetic + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_dadd"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + (&&host/analyse-jvm-dadd analyse exo-type ?x ?y) - ;; Syncronization/monitos - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-monitorenter"]]]] - ["lux;Cons" [?monitor - ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-monitorenter analyse ?monitor) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_dsub"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + (&&host/analyse-jvm-dsub analyse exo-type ?x ?y) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-monitorexit"]]]] - ["lux;Cons" [?monitor - ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-monitorexit analyse ?monitor) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_dmul"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + (&&host/analyse-jvm-dmul analyse exo-type ?x ?y) - [_] - (fail ""))) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_ddiv"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + (&&host/analyse-jvm-ddiv analyse exo-type ?x ?y) -(defn ^:private aba6 [analyse eval! exo-type token] - (matchv ::M/objects [token] - ;; Primitive conversions - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-d2f"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-d2f analyse ?value) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_drem"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + (&&host/analyse-jvm-drem analyse exo-type ?x ?y) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-d2i"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-d2i analyse ?value) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_deq"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + (&&host/analyse-jvm-deq analyse exo-type ?x ?y) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-d2l"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-d2l analyse ?value) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_dlt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + (&&host/analyse-jvm-dlt analyse exo-type ?x ?y) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-f2d"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-f2d analyse ?value) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_dgt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + (&&host/analyse-jvm-dgt analyse exo-type ?x ?y) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-f2i"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-f2i analyse ?value) + [_] + (aba5 analyse eval! compile-module exo-type token))) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-f2l"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-f2l analyse ?value) +(defn ^:private aba3 [analyse eval! compile-module exo-type token] + (matchv ::M/objects [token] + ;; Host special forms + ;; Characters + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_ceq"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + (&&host/analyse-jvm-ceq analyse exo-type ?x ?y) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-i2b"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-i2b analyse ?value) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_clt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + (&&host/analyse-jvm-clt analyse exo-type ?x ?y) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-i2c"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-i2c analyse ?value) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_cgt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + (&&host/analyse-jvm-cgt analyse exo-type ?x ?y) + + ;; Integer arithmetic + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_iadd"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + (&&host/analyse-jvm-iadd analyse exo-type ?x ?y) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-i2d"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-i2d analyse ?value) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_isub"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + (&&host/analyse-jvm-isub analyse exo-type ?x ?y) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-i2f"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-i2f analyse ?value) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_imul"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + (&&host/analyse-jvm-imul analyse exo-type ?x ?y) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-i2l"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-i2l analyse ?value) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_idiv"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + (&&host/analyse-jvm-idiv analyse exo-type ?x ?y) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-i2s"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-i2s analyse ?value) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_irem"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + (&&host/analyse-jvm-irem analyse exo-type ?x ?y) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-l2d"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-l2d analyse ?value) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_ieq"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + (&&host/analyse-jvm-ieq analyse exo-type ?x ?y) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-l2f"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-l2f analyse ?value) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_ilt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + (&&host/analyse-jvm-ilt analyse exo-type ?x ?y) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-l2i"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-l2i analyse ?value) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_igt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + (&&host/analyse-jvm-igt analyse exo-type ?x ?y) - ;; Bitwise operators - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-iand"]]]] ["lux;Cons" [?x ["lux;Cons" [?y ["lux;Nil" _]]]]]]]]]]] - (&&host/analyse-jvm-iand analyse ?x ?y) + ;; Long arithmetic + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_ladd"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + (&&host/analyse-jvm-ladd analyse exo-type ?x ?y) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-ior"]]]] ["lux;Cons" [?x ["lux;Cons" [?y ["lux;Nil" _]]]]]]]]]]] - (&&host/analyse-jvm-ior analyse ?x ?y) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_lsub"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + (&&host/analyse-jvm-lsub analyse exo-type ?x ?y) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-land"]]]] ["lux;Cons" [?x ["lux;Cons" [?y ["lux;Nil" _]]]]]]]]]]] - (&&host/analyse-jvm-land analyse ?x ?y) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_lmul"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + (&&host/analyse-jvm-lmul analyse exo-type ?x ?y) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-lor"]]]] ["lux;Cons" [?x ["lux;Cons" [?y ["lux;Nil" _]]]]]]]]]]] - (&&host/analyse-jvm-lor analyse ?x ?y) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_ldiv"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + (&&host/analyse-jvm-ldiv analyse exo-type ?x ?y) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-lxor"]]]] ["lux;Cons" [?x ["lux;Cons" [?y ["lux;Nil" _]]]]]]]]]]] - (&&host/analyse-jvm-lxor analyse ?x ?y) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_lrem"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + (&&host/analyse-jvm-lrem analyse exo-type ?x ?y) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-lshl"]]]] ["lux;Cons" [?x ["lux;Cons" [?y ["lux;Nil" _]]]]]]]]]]] - (&&host/analyse-jvm-lshl analyse ?x ?y) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_leq"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + (&&host/analyse-jvm-leq analyse exo-type ?x ?y) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-lshr"]]]] ["lux;Cons" [?x ["lux;Cons" [?y ["lux;Nil" _]]]]]]]]]]] - (&&host/analyse-jvm-lshr analyse ?x ?y) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_llt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + (&&host/analyse-jvm-llt analyse exo-type ?x ?y) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-lushr"]]]] ["lux;Cons" [?x ["lux;Cons" [?y ["lux;Nil" _]]]]]]]]]]] - (&&host/analyse-jvm-lushr analyse ?x ?y) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_lgt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + (&&host/analyse-jvm-lgt analyse exo-type ?x ?y) [_] - (fail ""))) + (aba4 analyse eval! compile-module exo-type token))) -(defn ^:private aba7 [analyse eval! exo-type token] +(defn ^:private aba2 [analyse eval! compile-module exo-type token] (matchv ::M/objects [token] - ;; Arrays - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-new-array"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ ?class]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;Int" ?length]]] - ["lux;Nil" _]]]]]]]]]]] - (&&host/analyse-jvm-new-array analyse ?class ?length) + [["lux;SymbolS" ?ident]] + (&&lux/analyse-symbol analyse exo-type ?ident) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-aastore"]]]] - ["lux;Cons" [?array - ["lux;Cons" [["lux;Meta" [_ ["lux;Int" ?idx]]] - ["lux;Cons" [?elem - ["lux;Nil" _]]]]]]]]]]]]] - (&&host/analyse-jvm-aastore analyse ?array ?idx ?elem) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_lux_case"]]]] + ["lux;Cons" [?value ?branches]]]]]] + (&&lux/analyse-case analyse exo-type ?value ?branches) + + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_lux_lambda"]]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ?self]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ?arg]]] + ["lux;Cons" [?body + ["lux;Nil" _]]]]]]]]]]] + (&&lux/analyse-lambda analyse exo-type ?self ?arg ?body) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-aaload"]]]] - ["lux;Cons" [?array - ["lux;Cons" [["lux;Meta" [_ ["lux;Int" ?idx]]] - ["lux;Nil" _]]]]]]]]]]] - (&&host/analyse-jvm-aaload analyse ?array ?idx) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_lux_def"]]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ["" ?name]]]] + ["lux;Cons" [?value + ["lux;Nil" _]]]]]]]]] + (&&lux/analyse-def analyse ?name ?value) + + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_lux_declare-macro"]]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ["" ?name]]]] + ["lux;Nil" _]]]]]]] + (&&lux/analyse-declare-macro analyse ?name) - ;; Classes & interfaces - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-class"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ ?name]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ ?super-class]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;Tuple" ?fields]]] - ["lux;Nil" _]]]]]]]]]]]]] - (&&host/analyse-jvm-class analyse ?name ?super-class ?fields) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_lux_import"]]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?path]]] + ["lux;Nil" _]]]]]]] + (&&lux/analyse-import analyse compile-module ?path) + + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_lux_:"]]]] + ["lux;Cons" [?type + ["lux;Cons" [?value + ["lux;Nil" _]]]]]]]]] + (&&lux/analyse-check analyse eval! exo-type ?type ?value) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-interface"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ ?name]]]] - ?members]]]]]]]] - (&&host/analyse-jvm-interface analyse ?name ?members) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_lux_:!"]]]] + ["lux;Cons" [?type + ["lux;Cons" [?value + ["lux;Nil" _]]]]]]]]] + (&&lux/analyse-coerce analyse eval! exo-type ?type ?value) - ;; Programs - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-program"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ ?args]]]] - ["lux;Cons" [?body - ["lux;Nil" _]]]]]]]]]]] - (&&host/analyse-jvm-program analyse ?args ?body) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_lux_export"]]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ["" ?ident]]]] + ["lux;Nil" _]]]]]]] + (&&lux/analyse-export analyse ?ident) + + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_lux_alias"]]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?alias]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?module]]] + ["lux;Nil" _]]]]]]]]] + (&&lux/analyse-alias analyse ?alias ?module) [_] - (fail ""))) + (aba3 analyse eval! compile-module exo-type token))) + +(let [unit (&/V "lux;Meta" (&/T (&/T "" -1 -1) (&/V "lux;TupleS" (&/|list))))] + (defn ^:private aba1 [analyse eval! compile-module exo-type token] + (matchv ::M/objects [token] + ;; Standard special forms + [["lux;BoolS" ?value]] + (|do [_ (&type/check exo-type &type/Bool)] + (return (&/|list (&/T (&/V "bool" ?value) exo-type)))) + + [["lux;IntS" ?value]] + (|do [_ (&type/check exo-type &type/Int)] + (return (&/|list (&/T (&/V "int" ?value) exo-type)))) + + [["lux;RealS" ?value]] + (|do [_ (&type/check exo-type &type/Real)] + (return (&/|list (&/T (&/V "real" ?value) exo-type)))) -(defn ^:private analyse-basic-ast [analyse eval! exo-type token] - ;; (prn 'analyse-basic-ast (aget token 0)) - ;; (when (= "lux;Tag" (aget token 0)) - ;; (prn 'analyse-basic-ast/tag (aget token 1))) - ;; (prn 'analyse-basic-ast token (&/show-ast token)) - (fn [state] - (matchv ::M/objects [((aba1 analyse eval! exo-type token) state)] - [["lux;Right" [state* output]]] - (return* state* output) + [["lux;CharS" ?value]] + (|do [_ (&type/check exo-type &type/Char)] + (return (&/|list (&/T (&/V "char" ?value) exo-type)))) + + [["lux;TextS" ?value]] + (|do [_ (&type/check exo-type &type/Text)] + (return (&/|list (&/T (&/V "text" ?value) exo-type)))) + + [["lux;TupleS" ?elems]] + (&&lux/analyse-tuple analyse exo-type ?elems) + + [["lux;RecordS" ?elems]] + (&&lux/analyse-record analyse exo-type ?elems) + + [["lux;TagS" ?ident]] + (&&lux/analyse-variant analyse exo-type ?ident unit) + + [["lux;SymbolS" [_ "_jvm_null"]]] + (&&host/analyse-jvm-null analyse exo-type) [_] - (matchv ::M/objects [((aba2 analyse eval! exo-type token) state)] + (aba2 analyse eval! compile-module exo-type token) + ))) + +(defn ^:private add-loc [meta ^String msg] + (if (.startsWith msg "@") + msg + (|let [[file line col] meta] + (str "@ " file "," line "," col "\n" msg)))) + +(defn ^:private analyse-basic-ast [analyse eval! compile-module exo-type token] + ;; (prn 'analyse-basic-ast (&/show-ast token)) + (matchv ::M/objects [token] + [["lux;Meta" [meta ?token]]] + (fn [state] + (matchv ::M/objects [((aba1 analyse eval! compile-module exo-type ?token) state)] [["lux;Right" [state* output]]] (return* state* output) - [_] - (matchv ::M/objects [((aba3 analyse eval! exo-type token) state)] - [["lux;Right" [state* output]]] - (return* state* output) + [["lux;Left" ""]] + (fail* (add-loc meta (str "[Analyser Error] Unrecognized token: " (&/show-ast token)))) - [_] - (matchv ::M/objects [((aba4 analyse eval! exo-type token) state)] - [["lux;Right" [state* output]]] - (return* state* output) + [["lux;Left" msg]] + (fail* (add-loc meta msg)) + )) - [_] - (matchv ::M/objects [((aba5 analyse eval! exo-type token) state)] - [["lux;Right" [state* output]]] - (return* state* output) - - [_] - (matchv ::M/objects [((aba6 analyse eval! exo-type token) state)] - [["lux;Right" [state* output]]] - (return* state* output) + ;; [_] + ;; (assert false (aget token 0)) + )) - [_] - (matchv ::M/objects [((aba7 analyse eval! exo-type token) state)] - [["lux;Right" [state* output]]] - (return* state* output) +(defn ^:private just-analyse [analyse-ast eval! compile-module syntax] + (&type/with-var + (fn [?var] + (|do [[?output-term ?output-type] (&&/analyse-1 (partial analyse-ast eval! compile-module) ?var syntax)] + (matchv ::M/objects [?var ?output-type] + [["lux;VarT" ?e-id] ["lux;VarT" ?a-id]] + (if (= ?e-id ?a-id) + (|do [?output-type* (&type/deref ?e-id)] + (return (&/T ?output-term ?output-type*))) + (return (&/T ?output-term ?output-type))) - [_] - (fail* (str "[Analyser Error] Unmatched token: " (&/show-ast token)))))))))))) + [_ _] + (return (&/T ?output-term ?output-type))) + )))) -(defn ^:private analyse-ast [eval! exo-type token] - ;; (prn 'analyse-ast (aget token 0)) +(defn ^:private analyse-ast [eval! compile-module exo-type token] (matchv ::M/objects [token] - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Tag" ?ident]]] ?values]]]]]] - (do (assert (= 1 (&/|length ?values)) "[Analyser Error] Can only tag 1 value.") - (&&lux/analyse-variant (partial analyse-ast eval!) exo-type ?ident (&/|head ?values))) + [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;TagS" ?ident]]] ?values]]]]]] + (do (assert (.equals ^Object (&/|length ?values) 1) "[Analyser Error] Can only tag 1 value.") + (&&lux/analyse-variant (partial analyse-ast eval! compile-module) exo-type ?ident (&/|head ?values))) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [?fn ?args]]]]]] + [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [?fn ?args]]]]]] (fn [state] - ;; (prn 'analyse-ast '(&/show-ast ?fn) (&/show-ast ?fn)) - (matchv ::M/objects [((&type/with-var #(&&/analyse-1 (partial analyse-ast eval!) % ?fn)) state)] + (matchv ::M/objects [((just-analyse analyse-ast eval! compile-module ?fn) state) + ;; ((&type/with-var #(&&/analyse-1 (partial analyse-ast eval! compile-module) % ?fn)) state) + ] [["lux;Right" [state* =fn]]] - ((&&lux/analyse-apply (partial analyse-ast eval!) exo-type =fn ?args) state*) + (do ;; (prn 'GOT_FUN (&/show-ast ?fn) (&/show-ast token) (aget =fn 0 0) (aget =fn 1 0)) + ((&&lux/analyse-apply (partial analyse-ast eval! compile-module) exo-type meta =fn ?args) state*)) [_] - (do ;; (prn 'analyse-ast/token (aget token 0) (&/show-state state)) - ;; (prn 'NOT_A_FUNCTION (&/show-ast ?fn)) - ((analyse-basic-ast (partial analyse-ast eval!) eval! exo-type token) state)))) + ((analyse-basic-ast (partial analyse-ast eval! compile-module) eval! compile-module exo-type token) state))) [_] - (analyse-basic-ast (partial analyse-ast eval!) eval! exo-type token))) + (analyse-basic-ast (partial analyse-ast eval! compile-module) eval! compile-module exo-type token))) ;; [Resources] -(defn analyse [eval!] +(defn analyse [eval! compile-module] (|do [asts &parser/parse] - (&/flat-map% (partial analyse-ast eval! &type/$Void) asts))) + (&/flat-map% (partial analyse-ast eval! compile-module &type/$Void) asts))) diff --git a/src/lux/analyser/base.clj b/src/lux/analyser/base.clj index 9913da4ae..9fc3f1030 100644 --- a/src/lux/analyser/base.clj +++ b/src/lux/analyser/base.clj @@ -1,3 +1,11 @@ +;; 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.analyser.base (:require [clojure.core.match :as M :refer [match matchv]] clojure.core.match.array @@ -6,32 +14,22 @@ ;; [Exports] (defn expr-type [syntax+] - ;; (prn 'expr-type syntax+) - ;; (prn 'expr-type (aget syntax+ 0)) (matchv ::M/objects [syntax+] [[_ type]] (return type))) (defn analyse-1 [analyse exo-type elem] (|do [output (analyse exo-type elem)] - (do ;; (prn 'analyse-1 (aget output 0)) - (matchv ::M/objects [output] - [["lux;Cons" [x ["lux;Nil" _]]]] - (return x) + (matchv ::M/objects [output] + [["lux;Cons" [x ["lux;Nil" _]]]] + (return x) - [_] - (fail "[Analyser Error] Can't expand to other than 1 element."))))) + [_] + (fail "[Analyser Error] Can't expand to other than 1 element.")))) (defn resolved-ident [ident] (|let [[?module ?name] ident] - (|do [module* (if (= "" ?module) + (|do [module* (if (.equals "" ?module) &/get-module-name (return ?module))] (return (&/ident->text (&/T module* ?name)))))) - -(defn resolved-ident* [ident] - (|let [[?module ?name] ident] - (|do [module* (if (= "" ?module) - &/get-module-name - (return ?module))] - (return (&/T module* ?name))))) diff --git a/src/lux/analyser/case.clj b/src/lux/analyser/case.clj index ea767d11c..ebbb6911a 100644 --- a/src/lux/analyser/case.clj +++ b/src/lux/analyser/case.clj @@ -1,3 +1,11 @@ +;; 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.analyser.case (:require [clojure.core.match :as M :refer [match matchv]] clojure.core.match.array @@ -15,109 +23,196 @@ (fail "##9##")))] (resolve-type type*)) + [["lux;AllT" [_aenv _aname _aarg _abody]]] + ;; (&type/actual-type _abody) + (|do [$var &type/existential + =type (&type/apply-type type $var)] + (&type/actual-type =type)) + ;; (&type/with-var + ;; (fn [$var] + ;; (|do [=type (&type/apply-type type $var)] + ;; (&type/actual-type =type)))) + [_] (&type/actual-type type))) +(defn adjust-type* [up type] + "(-> (List (, (Maybe (Env Text Type)) Text Text Type)) Type (Lux Type))" + (matchv ::M/objects [type] + [["lux;AllT" [_aenv _aname _aarg _abody]]] + (&type/with-var + (fn [$var] + (|do [=type (&type/apply-type type $var)] + (adjust-type* (&/|cons (&/T _aenv _aname _aarg $var) up) =type)))) + + [["lux;TupleT" ?members]] + (|do [["lux;TupleT" ?members*] (&/fold% (fn [_abody ena] + (|let [[_aenv _aname _aarg ["lux;VarT" _avar]] ena] + (|do [_ (&type/set-var _avar (&/V "lux;BoundT" _aarg))] + (&type/clean* _avar _abody)))) + type + up)] + (return (&/V "lux;TupleT" (&/|map (fn [v] + (&/fold (fn [_abody ena] + (|let [[_aenv _aname _aarg _avar] ena] + (&/V "lux;AllT" (&/T _aenv _aname _aarg _abody)))) + v + up)) + ?members*)))) + + [["lux;RecordT" ?fields]] + (|do [["lux;RecordT" ?fields*] (&/fold% (fn [_abody ena] + (|let [[_aenv _aname _aarg ["lux;VarT" _avar]] ena] + (|do [_ (&type/set-var _avar (&/V "lux;BoundT" _aarg))] + (&type/clean* _avar _abody)))) + type + up)] + (return (&/V "lux;RecordT" (&/|map (fn [kv] + (|let [[k v] kv] + (&/T k (&/fold (fn [_abody ena] + (|let [[_aenv _aname _aarg _avar] ena] + (&/V "lux;AllT" (&/T _aenv _aname _aarg _abody)))) + v + up)))) + ?fields*)))) + + [["lux;VariantT" ?cases]] + (|do [["lux;VariantT" ?cases*] (&/fold% (fn [_abody ena] + (|let [[_aenv _aname _aarg ["lux;VarT" _avar]] ena] + (|do [_ (&type/set-var _avar (&/V "lux;BoundT" _aarg))] + (&type/clean* _avar _abody)))) + type + up)] + (return (&/V "lux;VariantT" (&/|map (fn [kv] + (|let [[k v] kv] + (&/T k (&/fold (fn [_abody ena] + (|let [[_aenv _aname _aarg _avar] ena] + (&/V "lux;AllT" (&/T _aenv _aname _aarg _abody)))) + v + up)))) + ?cases*)))) + + [["lux;AppT" [?tfun ?targ]]] + (|do [=type (&type/apply-type ?tfun ?targ)] + (adjust-type* up =type)) + + [["lux;VarT" ?id]] + (|do [type* (&/try-all% (&/|list (&type/deref ?id) + (fail "##9##")))] + (adjust-type* up type*)) + + ;; [_] + ;; (assert false (aget type 0)) + )) + +(defn adjust-type [type] + "(-> Type (Lux Type))" + (adjust-type* (&/|list) type)) + (defn ^:private analyse-pattern [value-type pattern kont] - ;; (prn 'analyse-pattern/pattern (aget pattern 0) (aget pattern 1) (alength (aget pattern 1))) (matchv ::M/objects [pattern] [["lux;Meta" [_ pattern*]]] - ;; (assert false) - (do ;; (prn 'analyse-pattern/pattern* (aget pattern* 0)) - (matchv ::M/objects [pattern*] - [["lux;Symbol" ?ident]] - (|do [=kont (&env/with-local (&/ident->text ?ident) value-type - kont) - idx &env/next-local-idx] - (return (&/T (&/V "StoreTestAC" idx) =kont))) + (matchv ::M/objects [pattern*] + [["lux;SymbolS" ?ident]] + (|do [=kont (&env/with-local (&/ident->text ?ident) value-type + kont) + idx &env/next-local-idx] + (return (&/T (&/V "StoreTestAC" idx) =kont))) - [["lux;Bool" ?value]] - (|do [_ (&type/check value-type &type/Bool) - =kont kont] - (return (&/T (&/V "BoolTestAC" ?value) =kont))) + [["lux;BoolS" ?value]] + (|do [_ (&type/check value-type &type/Bool) + =kont kont] + (return (&/T (&/V "BoolTestAC" ?value) =kont))) - [["lux;Int" ?value]] - (|do [_ (&type/check value-type &type/Int) - =kont kont] - (return (&/T (&/V "IntTestAC" ?value) =kont))) + [["lux;IntS" ?value]] + (|do [_ (&type/check value-type &type/Int) + =kont kont] + (return (&/T (&/V "IntTestAC" ?value) =kont))) - [["lux;Real" ?value]] - (|do [_ (&type/check value-type &type/Real) - =kont kont] - (return (&/T (&/V "RealTestAC" ?value) =kont))) + [["lux;RealS" ?value]] + (|do [_ (&type/check value-type &type/Real) + =kont kont] + (return (&/T (&/V "RealTestAC" ?value) =kont))) - [["lux;Char" ?value]] - (|do [_ (&type/check value-type &type/Char) - =kont kont] - (return (&/T (&/V "CharTestAC" ?value) =kont))) + [["lux;CharS" ?value]] + (|do [_ (&type/check value-type &type/Char) + =kont kont] + (return (&/T (&/V "CharTestAC" ?value) =kont))) - [["lux;Text" ?value]] - (|do [_ (&type/check value-type &type/Text) - =kont kont] - (return (&/T (&/V "TextTestAC" ?value) =kont))) + [["lux;TextS" ?value]] + (|do [_ (&type/check value-type &type/Text) + =kont kont] + (return (&/T (&/V "TextTestAC" ?value) =kont))) - [["lux;Tuple" ?members]] - (matchv ::M/objects [value-type] - [["lux;TupleT" ?member-types]] - (if (not (= (&/|length ?member-types) (&/|length ?members))) - (fail (str "[Analyser error] Pattern-matching mismatch. Require tuple[" (&/|length ?member-types) "]. Given tuple [" (&/|length ?members) "]")) - (|do [[=tests =kont] (&/fold (fn [kont* vm] - (|let [[v m] vm] - (|do [[=test [=tests =kont]] (analyse-pattern v m kont*)] - (return (&/T (&/|cons =test =tests) =kont))))) - (|do [=kont kont] - (return (&/T (&/|list) =kont))) - (&/|reverse (&/zip2 ?member-types ?members)))] - (return (&/T (&/V "TupleTestAC" =tests) =kont)))) + [["lux;TupleS" ?members]] + (|do [value-type* (adjust-type value-type)] + (do ;; (prn 'PM/TUPLE-1 (&type/show-type value-type*)) + (matchv ::M/objects [value-type*] + [["lux;TupleT" ?member-types]] + (do ;; (prn 'PM/TUPLE-2 (&/|length ?member-types) (&/|length ?members)) + (if (not (.equals ^Object (&/|length ?member-types) (&/|length ?members))) + (fail (str "[Pattern-matching Error] Pattern-matching mismatch. Require tuple[" (&/|length ?member-types) "]. Given tuple [" (&/|length ?members) "]")) + (|do [[=tests =kont] (&/fold (fn [kont* vm] + (|let [[v m] vm] + (|do [[=test [=tests =kont]] (analyse-pattern v m kont*)] + (return (&/T (&/|cons =test =tests) =kont))))) + (|do [=kont kont] + (return (&/T (&/|list) =kont))) + (&/|reverse (&/zip2 ?member-types ?members)))] + (return (&/T (&/V "TupleTestAC" =tests) =kont))))) - [_] - (fail "[Analyser Error] Tuple requires tuple-type.")) + [_] + (fail (str "[Pattern-matching Error] Tuples require tuple-types: " (&type/show-type value-type*)))))) - [["lux;Record" ?slots]] - (|do [value-type* (resolve-type value-type)] - (matchv ::M/objects [value-type*] - [["lux;RecordT" ?slot-types]] - (if (not (= (&/|length ?slot-types) (&/|length ?slots))) - (fail (str "[Analyser error] Pattern-matching mismatch. Require record[" (&/|length ?slot-types) "]. Given record[" (&/|length ?slots) "]")) - (|do [[=tests =kont] (&/fold (fn [kont* slot] - (|let [[sn sv] slot] - (matchv ::M/objects [sn] - [["lux;Meta" [_ ["lux;Tag" ?ident]]]] - (|do [=tag (&&/resolved-ident ?ident)] - (if-let [=slot-type (&/|get =tag ?slot-types)] - (|do [[=test [=tests =kont]] (analyse-pattern =slot-type sv kont*)] - (return (&/T (&/|put =tag =test =tests) =kont))) - (fail (str "[Pattern-Matching Error] Record-type lacks slot: " =tag)))) + [["lux;RecordS" ?slots]] + (|do [;; :let [_ (prn 'PRE (&type/show-type value-type))] + value-type* (adjust-type value-type) + ;; :let [_ (prn 'POST (&type/show-type value-type*))] + ;; value-type* (resolve-type value-type) + ] + (matchv ::M/objects [value-type*] + [["lux;RecordT" ?slot-types]] + (if (not (.equals ^Object (&/|length ?slot-types) (&/|length ?slots))) + (fail (str "[Analyser Error] Pattern-matching mismatch. Require record[" (&/|length ?slot-types) "]. Given record[" (&/|length ?slots) "]")) + (|do [[=tests =kont] (&/fold (fn [kont* slot] + (|let [[sn sv] slot] + (matchv ::M/objects [sn] + [["lux;Meta" [_ ["lux;TagS" ?ident]]]] + (|do [=tag (&&/resolved-ident ?ident)] + (if-let [=slot-type (&/|get =tag ?slot-types)] + (|do [[=test [=tests =kont]] (analyse-pattern =slot-type sv kont*)] + (return (&/T (&/|put =tag =test =tests) =kont))) + (fail (str "[Pattern-matching Error] Record-type lacks slot: " =tag)))) - [_] - (fail (str "[Pattern-Matching Error] Record must use tags as slot-names: " (&/show-ast sn)))))) - (|do [=kont kont] - (return (&/T (&/|table) =kont))) - (&/|reverse ?slots))] - (return (&/T (&/V "RecordTestAC" =tests) =kont)))) + [_] + (fail (str "[Pattern-matching Error] Record must use tags as slot-names: " (&/show-ast sn)))))) + (|do [=kont kont] + (return (&/T (&/|table) =kont))) + (&/|reverse ?slots))] + (return (&/T (&/V "RecordTestAC" =tests) =kont)))) - [_] - (fail "[Analyser Error] Record requires record-type."))) + [_] + (fail "[Pattern-matching Error] Record requires record-type."))) - [["lux;Tag" ?ident]] - (|do [=tag (&&/resolved-ident ?ident) - value-type* (resolve-type value-type) - case-type (&type/variant-case =tag value-type*) - [=test =kont] (analyse-pattern case-type (&/V "lux;Meta" (&/T (&/T "" -1 -1) - (&/V "lux;Tuple" (&/|list)))) - kont)] - (return (&/T (&/V "VariantTestAC" (&/T =tag =test)) =kont))) + [["lux;TagS" ?ident]] + (|do [=tag (&&/resolved-ident ?ident) + value-type* (adjust-type value-type) + case-type (&type/variant-case =tag value-type*) + [=test =kont] (analyse-pattern case-type (&/V "lux;Meta" (&/T (&/T "" -1 -1) + (&/V "lux;TupleS" (&/|list)))) + kont)] + (return (&/T (&/V "VariantTestAC" (&/T =tag =test)) =kont))) - [["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Tag" ?ident]]] - ["lux;Cons" [?value - ["lux;Nil" _]]]]]]] - (|do [=tag (&&/resolved-ident ?ident) - value-type* (resolve-type value-type) - case-type (&type/variant-case =tag value-type*) - [=test =kont] (analyse-pattern case-type ?value - kont)] - (return (&/T (&/V "VariantTestAC" (&/T =tag =test)) =kont))) - )))) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;TagS" ?ident]]] + ["lux;Cons" [?value + ["lux;Nil" _]]]]]]] + (|do [=tag (&&/resolved-ident ?ident) + value-type* (adjust-type value-type) + case-type (&type/variant-case =tag value-type*) + [=test =kont] (analyse-pattern case-type ?value + kont)] + (return (&/T (&/V "VariantTestAC" (&/T =tag =test)) =kont))) + ))) (defn ^:private analyse-branch [analyse exo-type value-type pattern body patterns] (|do [pattern+body (analyse-pattern value-type pattern @@ -171,13 +266,12 @@ (return (&/V "TupleTotal" (&/T total? structs)))) [["TupleTotal" [total? ?values]] ["TupleTestAC" ?tests]] - (if (= (&/|length ?values) (&/|length ?tests)) - (|do [structs (&/map% (fn [vt] - (|let [[v t] vt] - (merge-total v (&/T t ?body)))) - (&/zip2 ?values ?tests))] + (if (.equals ^Object (&/|length ?values) (&/|length ?tests)) + (|do [structs (&/map2% (fn [v t] + (merge-total v (&/T t ?body))) + ?values ?tests)] (return (&/V "TupleTotal" (&/T total? structs)))) - (fail "[Pattern-matching error] Inconsistent tuple-size.")) + (fail "[Pattern-matching Error] Inconsistent tuple-size.")) [["DefaultTotal" total?] ["RecordTestAC" ?tests]] (|do [structs (&/map% (fn [t] @@ -191,20 +285,21 @@ (return (&/V "RecordTotal" (&/T total? structs)))) [["RecordTotal" [total? ?values]] ["RecordTestAC" ?tests]] - (if (= (&/|length ?values) (&/|length ?tests)) - (|do [structs (&/map% (fn [lr] - (|let [[[lslot sub-struct] [rslot value]] lr] - (if (= lslot rslot) - (|do [sub-struct* (merge-total sub-struct (&/T value ?body))] - (return (&/T lslot sub-struct*))) - (fail "[Pattern-matching error] Record slots mismatch.")))) - (&/zip2 ?values - (->> ?tests - &/->seq - (sort compare-kv) - &/->list)))] + (if (.equals ^Object (&/|length ?values) (&/|length ?tests)) + (|do [structs (&/map2% (fn [left right] + (|let [[lslot sub-struct] left + [rslot value]right] + (if (.equals ^Object lslot rslot) + (|do [sub-struct* (merge-total sub-struct (&/T value ?body))] + (return (&/T lslot sub-struct*))) + (fail "[Pattern-matching Error] Record slots mismatch.")))) + ?values + (->> ?tests + &/->seq + (sort compare-kv) + &/->list))] (return (&/V "RecordTotal" (&/T total? structs)))) - (fail "[Pattern-matching error] Inconsistent record-size.")) + (fail "[Pattern-matching Error] Inconsistent record-size.")) [["DefaultTotal" total?] ["VariantTestAC" [?tag ?test]]] (|do [sub-struct (merge-total (&/V "DefaultTotal" total?) @@ -219,7 +314,6 @@ )))) (defn ^:private check-totality [value-type struct] - ;; (prn 'check-totality (aget value-type 0) (aget struct 0) (&type/show-type value-type)) (matchv ::M/objects [struct] [["BoolTotal" [?total ?values]]] (return (or ?total @@ -240,16 +334,16 @@ [["TupleTotal" [?total ?structs]]] (if ?total (return true) - (matchv ::M/objects [value-type] - [["lux;TupleT" ?members]] - (|do [totals (&/map% (fn [sv] - (|let [[sub-struct ?member] sv] - (check-totality ?member sub-struct))) - (&/zip2 ?structs ?members))] - (return (&/fold #(and %1 %2) true totals))) + (|do [value-type* (resolve-type value-type)] + (matchv ::M/objects [value-type*] + [["lux;TupleT" ?members]] + (|do [totals (&/map2% (fn [sub-struct ?member] + (check-totality ?member sub-struct)) + ?structs ?members)] + (return (&/fold #(and %1 %2) true totals))) - [_] - (fail ""))) + [_] + (fail "[Pattern-maching Error] Tuple is not total.")))) [["RecordTotal" [?total ?structs]]] (if ?total @@ -266,7 +360,7 @@ (return (&/fold #(and %1 %2) true totals))) [_] - (fail "")))) + (fail "[Pattern-maching Error] Record is not total.")))) [["VariantTotal" [?total ?structs]]] (if ?total @@ -283,7 +377,7 @@ (return (&/fold #(and %1 %2) true totals))) [_] - (fail "")))) + (fail "[Pattern-maching Error] Variant is not total.")))) [["DefaultTotal" ?total]] (return ?total) @@ -296,10 +390,8 @@ (analyse-branch analyse exo-type value-type pattern body patterns))) (&/|list) branches) - ;; :let [_ (prn 'PRE_MERGE_TOTALS)] struct (&/fold% merge-total (&/V "DefaultTotal" false) patterns) ? (check-totality value-type struct)] (if ? - ;; (return (&/|reverse patterns)) (return patterns) - (fail "[Pattern-maching error] Pattern-matching is non-total.")))) + (fail "[Pattern-maching Error] Pattern-matching is non-total.")))) diff --git a/src/lux/analyser/env.clj b/src/lux/analyser/env.clj index 77fba3ca0..cac0f8cd4 100644 --- a/src/lux/analyser/env.clj +++ b/src/lux/analyser/env.clj @@ -1,3 +1,11 @@ +;; 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.analyser.env (:require [clojure.core.match :as M :refer [matchv]] clojure.core.match.array @@ -16,30 +24,26 @@ =return (body (&/update$ &/$ENVS (fn [stack] (let [bound-unit (&/V "lux;Local" (->> (&/|head stack) (&/get$ &/$LOCALS) (&/get$ &/$COUNTER)))] - (&/|cons (->> (&/|head stack) - (&/update$ &/$LOCALS #(&/update$ &/$COUNTER inc %)) - (&/update$ &/$LOCALS #(&/update$ &/$MAPPINGS (fn [m] (&/|put name (&/T bound-unit type) m)) %))) + (&/|cons (&/update$ &/$LOCALS #(->> % + (&/update$ &/$COUNTER inc) + (&/update$ &/$MAPPINGS (fn [m] (&/|put name (&/T bound-unit type) m)))) + (&/|head stack)) (&/|tail stack)))) state))] (matchv ::M/objects [=return] [["lux;Right" [?state ?value]]] (return* (&/update$ &/$ENVS (fn [stack*] - (&/|cons (->> (&/|head stack*) - (&/update$ &/$LOCALS #(&/update$ &/$COUNTER dec %)) - (&/update$ &/$LOCALS #(&/set$ &/$MAPPINGS old-mappings %))) - (&/|tail stack*))) + (&/|cons (&/update$ &/$LOCALS #(->> % + (&/update$ &/$COUNTER dec) + (&/set$ &/$MAPPINGS old-mappings)) + (&/|head stack*)) + (&/|tail stack*))) ?state) ?value) [_] =return)))) -(defn with-locals [locals monad] - (reduce (fn [inner [label elem]] - (with-local label elem inner)) - monad - (reverse locals))) - (def captured-vars (fn [state] (return* state (->> state (&/get$ &/$ENVS) &/|head (&/get$ &/$CLOSURE) (&/get$ &/$MAPPINGS))))) diff --git a/src/lux/analyser/host.clj b/src/lux/analyser/host.clj index 3c9e3ce3f..5033f4f2c 100644 --- a/src/lux/analyser/host.clj +++ b/src/lux/analyser/host.clj @@ -1,3 +1,11 @@ +;; 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.analyser.host (:require (clojure [template :refer [do-template]]) [clojure.core.match :as M :refer [match matchv]] @@ -10,18 +18,17 @@ [env :as &&env]))) ;; [Utils] -(defn ^:private extract-ident [ident] - (matchv ::M/objects [ident] - [["lux;Meta" [_ ["lux;Symbol" [_ ?ident]]]]] - (return ?ident) +(defn ^:private extract-text [text] + (matchv ::M/objects [text] + [["lux;Meta" [_ ["lux;TextS" ?text]]]] + (return ?text) [_] - (fail "[Analyser Error] Can't extract Symbol."))) + (fail "[Analyser Error] Can't extract Text."))) (defn ^:private analyse-1+ [analyse ?token] (&type/with-var (fn [$var] - ;; (prn 'analyse-1+ (aget $var 1) (&/show-ast ?token)) (|do [=expr (&&/analyse-1 analyse $var ?token)] (matchv ::M/objects [=expr] [[?item ?type]] @@ -29,13 +36,32 @@ (return (&/T ?item =type))) ))))) +(defn ^:private ensure-object [token] + "(-> Analysis (Lux (,)))" + (matchv ::M/objects [token] + [[_ ["lux;DataT" _]]] + (return nil) + + [_] + (fail "[Analyser Error] Expecting object"))) + +(defn ^:private as-object [type] + "(-> Type Type)" + (matchv ::M/objects [type] + [["lux;DataT" class]] + (&/V "lux;DataT" (&type/as-obj class)) + + [_] + type)) + ;; [Resources] (do-template [<name> <output-tag> <input-class> <output-class>] (let [input-type (&/V "lux;DataT" <input-class>) output-type (&/V "lux;DataT" <output-class>)] - (defn <name> [analyse ?x ?y] + (defn <name> [analyse exo-type ?x ?y] (|do [=x (&&/analyse-1 analyse input-type ?x) - =y (&&/analyse-1 analyse input-type ?y)] + =y (&&/analyse-1 analyse input-type ?y) + _ (&type/check exo-type output-type)] (return (&/|list (&/T (&/V <output-tag> (&/T =x =y)) output-type)))))) analyse-jvm-iadd "jvm-iadd" "java.lang.Integer" "java.lang.Integer" @@ -47,6 +73,10 @@ analyse-jvm-ilt "jvm-ilt" "java.lang.Integer" "java.lang.Boolean" analyse-jvm-igt "jvm-igt" "java.lang.Integer" "java.lang.Boolean" + analyse-jvm-ceq "jvm-ceq" "java.lang.Character" "java.lang.Boolean" + analyse-jvm-clt "jvm-clt" "java.lang.Character" "java.lang.Boolean" + analyse-jvm-cgt "jvm-cgt" "java.lang.Character" "java.lang.Boolean" + analyse-jvm-ladd "jvm-ladd" "java.lang.Long" "java.lang.Long" analyse-jvm-lsub "jvm-lsub" "java.lang.Long" "java.lang.Long" analyse-jvm-lmul "jvm-lmul" "java.lang.Long" "java.lang.Long" @@ -75,162 +105,292 @@ analyse-jvm-dgt "jvm-dgt" "java.lang.Double" "java.lang.Boolean" ) -(defn analyse-jvm-getstatic [analyse ?class ?field] - (|do [=class (&host/full-class-name ?class) - ;; :let [_ (prn 'analyse-jvm-getstatic/=class =class)] - =type (&host/lookup-static-field =class ?field) - ;; :let [_ (prn 'analyse-jvm-getstatic/=type =type)] - ] - (return (&/|list (&/T (&/V "jvm-getstatic" (&/T =class ?field)) =type))))) +(defn analyse-jvm-getstatic [analyse exo-type ?class ?field] + (|do [class-loader &/loader + =type (&host/lookup-static-field class-loader ?class ?field) + :let [output-type =type] + _ (&type/check exo-type output-type)] + (return (&/|list (&/T (&/V "jvm-getstatic" (&/T ?class ?field)) output-type))))) -(defn analyse-jvm-getfield [analyse ?class ?field ?object] - (|do [=class (&host/full-class-name ?class) - =type (&host/lookup-static-field =class ?field) - =object (&&/analyse-1 analyse ?object)] - (return (&/|list (&/T (&/V "jvm-getfield" (&/T =class ?field =object)) =type))))) +(defn analyse-jvm-getfield [analyse exo-type ?class ?field ?object] + (|do [class-loader &/loader + =type (&host/lookup-static-field class-loader ?class ?field) + =object (&&/analyse-1 analyse ?object) + :let [output-type =type] + _ (&type/check exo-type output-type)] + (return (&/|list (&/T (&/V "jvm-getfield" (&/T ?class ?field =object)) output-type))))) -(defn analyse-jvm-putstatic [analyse ?class ?field ?value] - (|do [=class (&host/full-class-name ?class) - ;; :let [_ (prn 'analyse-jvm-getstatic/=class =class)] - =type (&host/lookup-static-field =class ?field) - ;; :let [_ (prn 'analyse-jvm-getstatic/=type =type)] - =value (&&/analyse-1 analyse ?value)] - (return (&/|list (&/T (&/V "jvm-putstatic" (&/T =class ?field =value)) =type))))) +(defn analyse-jvm-putstatic [analyse exo-type ?class ?field ?value] + (|do [class-loader &/loader + =type (&host/lookup-static-field class-loader ?class ?field) + =value (&&/analyse-1 analyse =type ?value) + :let [output-type &type/Unit] + _ (&type/check exo-type output-type)] + (return (&/|list (&/T (&/V "jvm-putstatic" (&/T ?class ?field =value)) output-type))))) -(defn analyse-jvm-putfield [analyse ?class ?field ?object ?value] - (|do [=class (&host/full-class-name ?class) - =type (&host/lookup-static-field =class ?field) +(defn analyse-jvm-putfield [analyse exo-type ?class ?field ?object ?value] + (|do [class-loader &/loader + =type (&host/lookup-static-field class-loader ?class ?field) =object (&&/analyse-1 analyse ?object) - =value (&&/analyse-1 analyse ?value)] - (return (&/|list (&/T (&/V "jvm-putfield" (&/T =class ?field =object =value)) =type))))) + =value (&&/analyse-1 analyse =type ?value) + :let [output-type &type/Unit] + _ (&type/check exo-type output-type)] + (return (&/|list (&/T (&/V "jvm-putfield" (&/T ?class ?field =object =value)) output-type))))) + +(defn analyse-jvm-invokestatic [analyse exo-type ?class ?method ?classes ?args] + (|do [class-loader &/loader + =classes (&/map% extract-text ?classes) + =return (&host/lookup-static-method class-loader ?class ?method =classes) + ;; :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 + ?args) + :let [output-type =return] + _ (&type/check exo-type output-type)] + (return (&/|list (&/T (&/V "jvm-invokestatic" (&/T ?class ?method =classes =args)) output-type))))) -(defn analyse-jvm-invokestatic [analyse ?class ?method ?classes ?args] - (|do [=class (&host/full-class-name ?class) - =classes (&/map% &host/extract-jvm-param ?classes) - =return (&host/lookup-static-method =class ?method =classes) - =args (&/flat-map% analyse ?args)] - (return (&/|list (&/T (&/V "jvm-invokestatic" (&/T =class ?method =classes =args)) =return))))) +(defn analyse-jvm-instanceof [analyse exo-type ?class ?object] + (|do [=object (analyse-1+ analyse ?object) + _ (ensure-object =object) + :let [output-type &type/Bool] + _ (&type/check exo-type output-type)] + (return (&/|list (&/T (&/V "jvm-instanceof" (&/T ?class =object)) output-type))))) (do-template [<name> <tag>] - (defn <name> [analyse ?class ?method ?classes ?object ?args] - ;; (prn '<name> ?class ?method) - (|do [=class (&host/full-class-name ?class) - ;; :let [_ (prn 'analyse-jvm-invokevirtual/=class =class)] - =classes (&/map% &host/extract-jvm-param ?classes) - ;; :let [_ (prn 'analyse-jvm-invokevirtual/=classes =classes)] - =return (&host/lookup-virtual-method =class ?method =classes) - ;; :let [_ (prn 'analyse-jvm-invokevirtual/=return =return)] + (defn <name> [analyse exo-type ?class ?method ?classes ?object ?args] + (|do [class-loader &/loader + =classes (&/map% extract-text ?classes) + =return (&host/lookup-virtual-method class-loader ?class ?method =classes) =object (&&/analyse-1 analyse (&/V "lux;DataT" ?class) ?object) - ;; :let [_ (prn 'analyse-jvm-invokevirtual/=object =object)] - =args (&/map% (fn [c+o] - (|let [[?c ?o] c+o] - (&&/analyse-1 analyse (&/V "lux;DataT" ?c) ?o))) - (&/zip2 =classes ?args)) - ;; :let [_ (prn 'analyse-jvm-invokevirtual/=args =args)] - ] - (return (&/|list (&/T (&/V <tag> (&/T =class ?method =classes =object =args)) =return))))) + =args (&/map2% (fn [?c ?o] (&&/analyse-1 analyse (&/V "lux;DataT" ?c) ?o)) + =classes ?args) + :let [output-type =return] + _ (&type/check exo-type output-type)] + (return (&/|list (&/T (&/V <tag> (&/T ?class ?method =classes =object =args)) output-type))))) analyse-jvm-invokevirtual "jvm-invokevirtual" analyse-jvm-invokeinterface "jvm-invokeinterface" - analyse-jvm-invokespecial "jvm-invokespecial" ) -(defn analyse-jvm-null? [analyse ?object] - (|do [=object (&&/analyse-1 analyse ?object)] - (return (&/|list (&/T (&/V "jvm-null?" =object) (&/V "lux;DataT" "java.lang.Boolean")))))) +(defn analyse-jvm-invokespecial [analyse exo-type ?class ?method ?classes ?object ?args] + (|do [class-loader &/loader + =classes (&/map% extract-text ?classes) + =return (if (= "<init>" ?method) + (return &type/Unit) + (&host/lookup-virtual-method class-loader ?class ?method =classes)) + =object (&&/analyse-1 analyse (&/V "lux;DataT" ?class) ?object) + =args (&/map2% (fn [?c ?o] + (&&/analyse-1 analyse (&/V "lux;DataT" ?c) ?o)) + =classes ?args) + :let [output-type =return] + _ (&type/check exo-type output-type)] + (return (&/|list (&/T (&/V "jvm-invokespecial" (&/T ?class ?method =classes =object =args)) output-type))))) + +(defn analyse-jvm-null? [analyse exo-type ?object] + (|do [=object (analyse-1+ analyse ?object) + _ (ensure-object =object) + :let [output-type &type/Bool] + _ (&type/check exo-type output-type)] + (return (&/|list (&/T (&/V "jvm-null?" =object) output-type))))) + +(defn analyse-jvm-null [analyse exo-type] + (|do [:let [output-type (&/V "lux;DataT" "null")] + _ (&type/check exo-type output-type)] + (return (&/|list (&/T (&/V "jvm-null" nil) output-type))))) -(defn analyse-jvm-new [analyse ?class ?classes ?args] - (|do [=class (&host/full-class-name ?class) - =classes (&/map% &host/extract-jvm-param ?classes) - =args (&/flat-map% analyse ?args)] - (return (&/|list (&/T (&/V "jvm-new" (&/T =class =classes =args)) (&/V "lux;DataT" =class)))))) +(defn analyse-jvm-new [analyse exo-type ?class ?classes ?args] + (|do [=classes (&/map% extract-text ?classes) + =args (&/map% (partial analyse-1+ analyse) ?args) + :let [output-type (&/V "lux;DataT" ?class)] + _ (&type/check exo-type output-type)] + (return (&/|list (&/T (&/V "jvm-new" (&/T ?class =classes =args)) output-type))))) (defn analyse-jvm-new-array [analyse ?class ?length] - (|do [=class (&host/full-class-name ?class)] - (return (&/|list (&/T (&/V "jvm-new-array" (&/T =class ?length)) (&/V "array" (&/T (&/V "lux;DataT" =class) - (&/V "lux;Nil" nil)))))))) + (return (&/|list (&/T (&/V "jvm-new-array" (&/T ?class ?length)) (&/V "array" (&/T (&/V "lux;DataT" ?class) + (&/V "lux;Nil" nil))))))) (defn analyse-jvm-aastore [analyse ?array ?idx ?elem] - (|do [=array (&&/analyse-1 analyse &type/$Void ?array) - =elem (&&/analyse-1 analyse &type/$Void ?elem) + (|do [=array (analyse-1+ analyse ?array) + =elem (analyse-1+ analyse ?elem) =array-type (&&/expr-type =array)] (return (&/|list (&/T (&/V "jvm-aastore" (&/T =array ?idx =elem)) =array-type))))) (defn analyse-jvm-aaload [analyse ?array ?idx] - (|do [=array (&&/analyse-1 analyse ?array) + (|do [=array (analyse-1+ analyse ?array) =array-type (&&/expr-type =array)] (return (&/|list (&/T (&/V "jvm-aaload" (&/T =array ?idx)) =array-type))))) -(defn analyse-jvm-class [analyse ?name ?super-class ?fields] - (|do [?fields (&/map% (fn [?field] +(defn ^:private analyse-modifiers [modifiers] + (&/fold% (fn [so-far modif] + (matchv ::M/objects [modif] + [["lux;Meta" [_ ["lux;TextS" "public"]]]] + (return (assoc so-far :visibility "public")) + + [["lux;Meta" [_ ["lux;TextS" "private"]]]] + (return (assoc so-far :visibility "private")) + + [["lux;Meta" [_ ["lux;TextS" "protected"]]]] + (return (assoc so-far :visibility "protected")) + + [["lux;Meta" [_ ["lux;TextS" "static"]]]] + (return (assoc so-far :static? true)) + + [["lux;Meta" [_ ["lux;TextS" "final"]]]] + (return (assoc so-far :final? true)) + + [["lux;Meta" [_ ["lux;TextS" "abstract"]]]] + (return (assoc so-far :abstract? true)) + + [["lux;Meta" [_ ["lux;TextS" "synchronized"]]]] + (return (assoc so-far :concurrency "synchronized")) + + [["lux;Meta" [_ ["lux;TextS" "volatile"]]]] + (return (assoc so-far :concurrency "volatile")) + + [_] + (fail (str "[Analyser Error] Unknown modifier: " (&/show-ast modif))))) + {:visibility "default" + :static? false + :final? false + :abstract? false + :concurrency nil} + modifiers)) + +(defn ^:private as-otype [tname] + (case tname + "boolean" "java.lang.Boolean" + "byte" "java.lang.Byte" + "short" "java.lang.Short" + "int" "java.lang.Integer" + "long" "java.lang.Long" + "float" "java.lang.Float" + "double" "java.lang.Double" + "char" "java.lang.Character" + ;; else + tname + )) + +(defn analyse-jvm-class [analyse ?name ?super-class ?interfaces ?fields ?methods] + (|do [=interfaces (&/map% extract-text ?interfaces) + =fields (&/map% (fn [?field] (matchv ::M/objects [?field] - [["lux;Meta" [_ ["lux;Tuple" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" ?class]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" ?field-name]]] - ["lux;Nil" _]]]]]]]]] - (return [?class ?field-name]) + [["lux;Meta" [_ ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?field-name]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?field-type]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?field-modifiers]]] + ["lux;Nil" _]]]]]]]]]]] + (|do [=field-modifiers (analyse-modifiers ?field-modifiers)] + (return {:name ?field-name + :modifiers =field-modifiers + :type ?field-type})) [_] - (fail "[Analyser Error] Fields must be Tuple2 of [Symbol, Symbol]"))) + (fail "[Analyser Error] Wrong syntax for field."))) ?fields) - :let [=fields (into {} (for [[class field] ?fields] - [field {:access :public - :type class}]))] - $module &/get-module-name] - (return (&/|list (&/V "jvm-class" (&/T $module ?name ?super-class =fields {})))))) + =methods (&/map% (fn [?method] + (matchv ::M/objects [?method] + [[?idx ["lux;Meta" [_ ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?method-name]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?method-inputs]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?method-output]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?method-modifiers]]] + ["lux;Cons" [?method-body + ["lux;Nil" _]]]]]]]]]]]]]]]] + (|do [=method-inputs (&/map% (fn [minput] + (matchv ::M/objects [minput] + [["lux;Meta" [_ ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ?input-name]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?input-type]]] + ["lux;Nil" _]]]]]]]]] + (return (&/T (&/ident->text ?input-name) ?input-type)) -(defn analyse-jvm-interface [analyse ?name ?members] - ;; (prn 'analyse-jvm-interface ?name ?members) - (|do [=members (&/map% (fn [member] - ;; (prn 'analyse-jvm-interface (&/show-ast member)) - (matchv ::M/objects [member] - [["lux;Meta" [_ ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" ["" ":'"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "->"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;Tuple" ?inputs]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ ?output]]]] - ["lux;Nil" _]]]]]]]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ ?member-name]]]] - ["lux;Nil" _]]]]]]]]]]] - (do ;; (prn 'analyse-jvm-interface ?member-name ?inputs ?output) - (|do [inputs* (&/map% extract-ident ?inputs)] - (return [?member-name [inputs* ?output]]))) + [_] + (fail "[Analyser Error] Wrong syntax for method input."))) + ?method-inputs) + =method-modifiers (analyse-modifiers ?method-modifiers) + =method-body (&/with-scope (str ?name "_" ?idx) + (&/fold (fn [body* input*] + (|let [[iname itype] input*] + (&&env/with-local iname (&/V "lux;DataT" (as-otype itype)) + body*))) + (if (= "void" ?method-output) + (analyse-1+ analyse ?method-body) + (&&/analyse-1 analyse (&/V "lux;DataT" (as-otype ?method-output)) ?method-body)) + (&/|reverse (if (:static? =method-modifiers) + =method-inputs + (&/|cons (&/T ";this" ?super-class) + =method-inputs)))))] + (return {:name ?method-name + :modifiers =method-modifiers + :inputs (&/|map &/|second =method-inputs) + :output ?method-output + :body =method-body})) [_] - (fail "[Analyser Error] Invalid method signature!"))) - ?members) - :let [;; _ (prn '=members =members) - =methods (into {} (for [[method [inputs output]] (&/->seq =members)] - [method {:access :public - :type [inputs output]}]))] - $module &/get-module-name] - (return (&/|list (&/V "jvm-interface" (&/T $module ?name =methods)))))) + (fail "[Analyser Error] Wrong syntax for method."))) + (&/enumerate ?methods))] + (return (&/|list (&/V "jvm-class" (&/T ?name ?super-class =interfaces =fields =methods)))))) -(defn analyse-jvm-try [analyse ?body [?catches ?finally]] - (|do [=body (&&/analyse-1 analyse ?body) +(defn analyse-jvm-interface [analyse ?name ?supers ?methods] + (|do [=supers (&/map% extract-text ?supers) + =methods (&/map% (fn [method] + (matchv ::M/objects [method] + [["lux;Meta" [_ ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?method-name]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?inputs]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?output]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?modifiers]]] + ["lux;Nil" _]]]]]]]]]]]]] + (|do [=inputs (&/map% extract-text ?inputs) + =modifiers (analyse-modifiers ?modifiers)] + (return {:name ?method-name + :modifiers =modifiers + :inputs =inputs + :output ?output})) + + [_] + (fail (str "[Analyser Error] Invalid method signature: " (&/show-ast method))))) + ?methods)] + (return (&/|list (&/V "jvm-interface" (&/T ?name =supers =methods)))))) + +(defn analyse-jvm-try [analyse exo-type ?body ?catches+?finally] + (|do [:let [[?catches ?finally] ?catches+?finally] + =body (&&/analyse-1 analyse exo-type ?body) =catches (&/map% (fn [[?ex-class ?ex-arg ?catch-body]] - (&&env/with-local ?ex-arg (&/V "lux;DataT" ?ex-class) - (|do [=catch-body (&&/analyse-1 analyse ?catch-body)] - (return [?ex-class ?ex-arg =catch-body])))) + (|do [=catch-body (&&env/with-local (str ";" ?ex-arg) (&/V "lux;DataT" ?ex-class) + (&&/analyse-1 analyse exo-type ?catch-body)) + idx &&env/next-local-idx] + (return (&/T ?ex-class idx =catch-body)))) ?catches) - =finally (&&/analyse-1 analyse ?finally) - =body-type (&&/expr-type =body)] - (return (&/|list (&/T (&/V "jvm-try" (&/T =body =catches =finally)) =body-type))))) + =finally (matchv ::M/objects [?finally] + [["lux;None" _]] (return (&/V "lux;None" nil)) + [["lux;Some" ?finally*]] (|do [=finally (analyse-1+ analyse ?finally*)] + (return (&/V "lux;Some" =finally))))] + (return (&/|list (&/T (&/V "jvm-try" (&/T =body =catches =finally)) exo-type))))) -(defn analyse-jvm-throw [analyse ?ex] - (|do [=ex (&&/analyse-1 analyse ?ex)] +(defn analyse-jvm-throw [analyse exo-type ?ex] + (|do [=ex (analyse-1+ analyse ?ex) + :let [[_obj _type] =ex] + _ (&type/check (&/V "lux;DataT" "java.lang.Throwable") _type)] (return (&/|list (&/T (&/V "jvm-throw" =ex) &type/$Void))))) -(defn analyse-jvm-monitorenter [analyse ?monitor] - (|do [=monitor (&&/analyse-1 analyse ?monitor)] - (return (&/|list (&/T (&/V "jvm-monitorenter" =monitor) (&/V "lux;TupleT" (&/V "lux;Nil" nil))))))) +(do-template [<name> <tag>] + (defn <name> [analyse exo-type ?monitor] + (|do [=monitor (analyse-1+ analyse ?monitor) + _ (ensure-object =monitor) + :let [output-type &type/Unit] + _ (&type/check exo-type output-type)] + (return (&/|list (&/T (&/V <tag> =monitor) output-type))))) -(defn analyse-jvm-monitorexit [analyse ?monitor] - (|do [=monitor (&&/analyse-1 analyse ?monitor)] - (return (&/|list (&/T (&/V "jvm-monitorexit" =monitor) (&/V "lux;TupleT" (&/V "lux;Nil" nil))))))) + analyse-jvm-monitorenter "jvm-monitorenter" + analyse-jvm-monitorexit "jvm-monitorexit" + ) (do-template [<name> <tag> <from-class> <to-class>] - (defn <name> [analyse ?value] - (|do [=value (&&/analyse-1 analyse (&/V "lux;DataT" <from-class>) ?value)] - (return (&/|list (&/T (&/V <tag> =value) (&/V "lux;DataT" <to-class>)))))) + (let [output-type (&/V "lux;DataT" <to-class>)] + (defn <name> [analyse exo-type ?value] + (|do [=value (&&/analyse-1 analyse (&/V "lux;DataT" <from-class>) ?value) + _ (&type/check exo-type output-type)] + (return (&/|list (&/T (&/V <tag> =value) output-type)))))) analyse-jvm-d2f "jvm-d2f" "java.lang.Double" "java.lang.Float" analyse-jvm-d2i "jvm-d2i" "java.lang.Double" "java.lang.Integer" @@ -253,9 +413,11 @@ ) (do-template [<name> <tag> <from-class> <to-class>] - (defn <name> [analyse ?value] - (|do [=value (&&/analyse-1 analyse (&/V "lux;DataT" <from-class>) ?value)] - (return (&/|list (&/T (&/V <tag> =value) (&/V "lux;DataT" <to-class>)))))) + (let [output-type (&/V "lux;DataT" <to-class>)] + (defn <name> [analyse exo-type ?value] + (|do [=value (&&/analyse-1 analyse (&/V "lux;DataT" <from-class>) ?value) + _ (&type/check exo-type output-type)] + (return (&/|list (&/T (&/V <tag> =value) output-type)))))) analyse-jvm-iand "jvm-iand" "java.lang.Integer" "java.lang.Integer" analyse-jvm-ior "jvm-ior" "java.lang.Integer" "java.lang.Integer" @@ -270,11 +432,8 @@ ) (defn analyse-jvm-program [analyse ?args ?body] - (|do [;; =body (&&env/with-local ?args (&/V "lux;AppT" (&/T &type/List &type/Text)) - ;; (&&/analyse-1 analyse ?body)) - =body (&/with-scope "" - (&&env/with-local "" (&/V "lux;AppT" (&/T &type/List &type/Text)) - (analyse-1+ analyse ?body))) - ;; =body (analyse-1+ analyse ?body) - ] - (return (&/|list (&/V "jvm-program" =body))))) + (|let [[_module _name] ?args] + (|do [=body (&/with-scope "" + (&&env/with-local (str _module ";" _name) (&/V "lux;AppT" (&/T &type/List &type/Text)) + (&&/analyse-1 analyse (&/V "lux;AppT" (&/T &type/IO &type/Unit)) ?body)))] + (return (&/|list (&/V "jvm-program" =body)))))) diff --git a/src/lux/analyser/lambda.clj b/src/lux/analyser/lambda.clj index 859f47e56..b1b9e2c22 100644 --- a/src/lux/analyser/lambda.clj +++ b/src/lux/analyser/lambda.clj @@ -1,3 +1,11 @@ +;; 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.analyser.lambda (:require [clojure.core.match :as M :refer [matchv]] clojure.core.match.array @@ -8,8 +16,6 @@ ;; [Resource] (defn with-lambda [self self-type arg arg-type body] - ;; (prn 'with-lambda (&/|length self) (&/|length arg)) - ;; (prn 'with-lambda [(aget self 0) (aget self 1)] [(aget arg 0) (aget arg 1)] (alength self) (alength arg)) (|let [[?module1 ?name1] self [?module2 ?name2] arg] (&/with-closure @@ -21,11 +27,6 @@ (return (&/T scope-name =captured =return))))))))) (defn close-over [scope ident register frame] - ;; (prn 'close-over - ;; (&host/location scope) - ;; (&host/location (&/|list ident)) - ;; register - ;; (->> frame (&/get$ &/$CLOSURE) (&/get$ &/$COUNTER))) (matchv ::M/objects [register] [[_ register-type]] (|let [register* (&/T (&/V "captured" (&/T scope diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj index 2a68e0aeb..065e150d9 100644 --- a/src/lux/analyser/lux.clj +++ b/src/lux/analyser/lux.clj @@ -1,3 +1,11 @@ +;; 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.analyser.lux (:require (clojure [template :refer [do-template]]) [clojure.core.match :as M :refer [matchv]] @@ -15,7 +23,6 @@ (defn ^:private analyse-1+ [analyse ?token] (&type/with-var (fn [$var] - ;; (prn 'analyse-1+ (aget $var 1) (&/show-ast ?token)) (|do [=expr (&&/analyse-1 analyse $var ?token)] (matchv ::M/objects [=expr] [[?item ?type]] @@ -23,18 +30,19 @@ (return (&/T ?item =type))) ))))) +(defn ^:private with-cursor [cursor form] + (matchv ::M/objects [form] + [["lux;Meta" [_ syntax]]] + (&/V "lux;Meta" (&/T cursor syntax)))) + ;; [Exports] (defn analyse-tuple [analyse exo-type ?elems] - ;; (prn "^^ analyse-tuple ^^") - ;; (prn 'analyse-tuple (str "[" (->> ?elems (&/|map &/show-ast) (&/|interpose " ") (&/fold str "")) "]") - ;; (&type/show-type exo-type)) (|do [exo-type* (&type/actual-type exo-type)] (matchv ::M/objects [exo-type*] [["lux;TupleT" ?members]] - (|do [=elems (&/map% (fn [ve] - (|let [[elem-t elem] ve] - (&&/analyse-1 analyse elem-t elem))) - (&/zip2 ?members ?elems))] + (|do [=elems (&/map2% (fn [elem-t elem] + (&&/analyse-1 analyse elem-t elem)) + ?members ?elems)] (return (&/|list (&/T (&/V "tuple" =elems) exo-type)))) @@ -48,28 +56,20 @@ (fail (str "[Analyser Error] Tuples require tuple-types: " (&type/show-type exo-type*)))))) (defn analyse-variant [analyse exo-type ident ?value] - ;; (prn "^^ analyse-variant ^^") - (|do [;; :let [_ (prn 'analyse-variant/exo-type (&type/show-type exo-type))] - exo-type* (matchv ::M/objects [exo-type] + (|do [exo-type* (matchv ::M/objects [exo-type] [["lux;VarT" ?id]] - (&/try-all% (&/|list (|do [exo-type* (&/try-all% (&/|list (&type/deref ?id) - (fail "##8##")))] + (&/try-all% (&/|list (|do [exo-type* (&type/deref ?id)] (&type/actual-type exo-type*)) (|do [_ (&type/set-var ?id &type/Type)] (&type/actual-type &type/Type)))) [_] - (&type/actual-type exo-type)) - ;; :let [_ (prn 'analyse-variant/exo-type* (&type/show-type exo-type*))] - ] + (&type/actual-type exo-type))] (matchv ::M/objects [exo-type*] [["lux;VariantT" ?cases]] (|do [?tag (&&/resolved-ident ident)] (if-let [vtype (&/|get ?tag ?cases)] - (|do [;; :let [_ (prn 'VARIANT_BODY ?tag (&/show-ast ?value) (&type/show-type vtype))] - =value (&&/analyse-1 analyse vtype ?value) - ;; :let [_ (prn 'GOT_VALUE =value)] - ] + (|do [=value (&&/analyse-1 analyse vtype ?value)] (return (&/|list (&/T (&/V "variant" (&/T ?tag =value)) exo-type)))) (fail (str "[Analyser Error] There is no case " ?tag " for variant type " (&type/show-type exo-type*))))) @@ -86,10 +86,18 @@ (defn analyse-record [analyse exo-type ?elems] (|do [exo-type* (matchv ::M/objects [exo-type] [["lux;VarT" ?id]] - (|do [exo-type* (&/try-all% (&/|list (&type/deref ?id) - (fail "##7##")))] + (|do [exo-type* (&type/deref ?id)] (&type/actual-type exo-type*)) + [["lux;AllT" _]] + (|do [$var &type/existential + =type (&type/apply-type exo-type $var)] + (&type/actual-type =type)) + ;; (&type/with-var + ;; (fn [$var] + ;; (|do [=type (&type/apply-type exo-type $var)] + ;; (&type/actual-type =type)))) + [_] (&type/actual-type exo-type)) types (matchv ::M/objects [exo-type*] @@ -97,15 +105,16 @@ (return ?table) [_] - (fail "[Analyser Error] The type of a record must be a record type.")) + (fail (str "[Analyser Error] The type of a record must be a record type:\n" + (&type/show-type exo-type*) + "\n"))) =slots (&/map% (fn [kv] (matchv ::M/objects [kv] - [[["lux;Meta" [_ ["lux;Tag" ?ident]]] ?value]] + [[["lux;Meta" [_ ["lux;TagS" ?ident]]] ?value]] (|do [?tag (&&/resolved-ident ?ident) slot-type (if-let [slot-type (&/|get ?tag types)] (return slot-type) (fail (str "[Analyser Error] Record type does not have slot: " ?tag))) - ;; :let [_ (prn 'slot ?tag (&/show-ast ?value) (&type/show-type slot-type))] =value (&&/analyse-1 analyse slot-type ?value)] (return (&/T ?tag =value))) @@ -118,214 +127,192 @@ (|do [module-name &/get-module-name] (fn [state] (|let [[?module ?name] ident - ;; _ (prn 'analyse-symbol ?module ?name) + ;; _ (prn 'analyse-symbol/_0 ?module ?name) local-ident (str ?module ";" ?name) stack (&/get$ &/$ENVS state) no-binding? #(and (->> % (&/get$ &/$LOCALS) (&/get$ &/$MAPPINGS) (&/|contains? local-ident) not) (->> % (&/get$ &/$CLOSURE) (&/get$ &/$MAPPINGS) (&/|contains? local-ident) not)) [inner outer] (&/|split-with no-binding? stack)] - (do ;; (when (= "<" ?name) - ;; (prn 'HALLO (&/|length inner) (&/|length outer))) - (matchv ::M/objects [outer] - [["lux;Nil" _]] - (&/run-state (|do [[[r-module r-name] $def] (&&module/find-def (if (= "" ?module) module-name ?module) - ?name) - endo-type (matchv ::M/objects [$def] - [["lux;ValueD" ?type]] - (return ?type) + (matchv ::M/objects [outer] + [["lux;Nil" _]] + (do ;; (prn 'analyse-symbol/_1 + ;; [?module ?name] + ;; [(if (.equals "" ?module) module-name ?module) + ;; ?name]) + ((|do [[[r-module r-name] $def] (&&module/find-def (if (.equals "" ?module) module-name ?module) + ?name) + ;; :let [_ (prn 'analyse-symbol/_1.1 r-module r-name)] + endo-type (matchv ::M/objects [$def] + [["lux;ValueD" ?type]] + (return ?type) - [["lux;MacroD" _]] - (return &type/Macro) + [["lux;MacroD" _]] + (return &type/Macro) - [["lux;TypeD" _]] - (return &type/Type)) - ;; :let [_ (println "Got endo-type:" endo-type)] - _ (if (and (= &type/Type endo-type) (= &type/Type exo-type)) - (do ;; (println "OH YEAH" (if (= "" ?module) module-name ?module) - ;; ?name) - (return nil)) - (&type/check exo-type endo-type)) - ;; :let [_ (println "Type-checked:" exo-type endo-type)] - ] - (return (&/|list (&/T (&/V "lux;Global" (&/T r-module r-name)) - endo-type)))) - state) + [["lux;TypeD" _]] + (return &type/Type)) + _ (if (and (clojure.lang.Util/identical &type/Type endo-type) + (clojure.lang.Util/identical &type/Type exo-type)) + (return nil) + (&type/check exo-type endo-type))] + (return (&/|list (&/T (&/V "lux;Global" (&/T r-module r-name)) + endo-type)))) + state)) - [["lux;Cons" [?genv ["lux;Nil" _]]]] - (if-let [global (->> ?genv (&/get$ &/$LOCALS) (&/get$ &/$MAPPINGS) (&/|get local-ident))] - (do (when (= "<" ?name) - (prn 'GOT_GLOBAL local-ident)) - (matchv ::M/objects [global] - [[["lux;Global" [?module* ?name*]] _]] - (&/run-state (|do [;; :let [_ (prn 'GLOBAL/_1 ?module* ?name*)] - ;; :let [_ (when (= "<" ?name) - ;; (println "Pre Found def:" ?module* ?name*))] - [[r-module r-name] $def] (&&module/find-def ?module* ?name*) - ;; :let [_ (prn 'GLOBAL/_2 r-module r-name)] - ;; :let [_ (when (= "<" ?name) - ;; (println "Found def:" r-module r-name))] - endo-type (matchv ::M/objects [$def] - [["lux;ValueD" ?type]] - (return ?type) + [["lux;Cons" [?genv ["lux;Nil" _]]]] + (do ;; (prn 'analyse-symbol/_2 ?module ?name local-ident (->> ?genv (&/get$ &/$LOCALS) (&/get$ &/$MAPPINGS) &/|keys &/->seq)) + (if-let [global (->> ?genv (&/get$ &/$LOCALS) (&/get$ &/$MAPPINGS) (&/|get local-ident))] + (do ;; (prn 'analyse-symbol/_2.1 ?module ?name local-ident (aget global 0)) + (matchv ::M/objects [global] + [[["lux;Global" [?module* ?name*]] _]] + ((|do [[[r-module r-name] $def] (&&module/find-def ?module* ?name*) + ;; :let [_ (prn 'analyse-symbol/_2.1.1 r-module r-name)] + endo-type (matchv ::M/objects [$def] + [["lux;ValueD" ?type]] + (return ?type) - [["lux;MacroD" _]] - (return &type/Macro) + [["lux;MacroD" _]] + (return &type/Macro) - [["lux;TypeD" _]] - (return &type/Type)) - ;; :let [_ (println "Got endo-type:" endo-type)] - _ (if (and (= &type/Type endo-type) (= &type/Type exo-type)) - (do ;; (println "OH YEAH" ?module* ?name*) - (return nil)) - (&type/check exo-type endo-type)) - ;; :let [_ (println "Type-checked:" exo-type endo-type)] - ;; :let [_ (when (= "<" ?name) - ;; (println "Returnin'"))] - ] - (return (&/|list (&/T (&/V "lux;Global" (&/T r-module r-name)) - endo-type)))) - state) + [["lux;TypeD" _]] + (return &type/Type)) + _ (if (and (clojure.lang.Util/identical &type/Type endo-type) + (clojure.lang.Util/identical &type/Type exo-type)) + (return nil) + (&type/check exo-type endo-type))] + (return (&/|list (&/T (&/V "lux;Global" (&/T r-module r-name)) + endo-type)))) + state) - [_] - (fail* "[Analyser Error] Can't have anything other than a global def in the global environment."))) - (fail* "")) - - [["lux;Cons" [top-outer _]]] - (|let [scopes (&/|tail (&/folds #(&/|cons (&/get$ &/$NAME %2) %1) - (&/|map #(&/get$ &/$NAME %) outer) - (&/|reverse inner))) - [=local inner*] (&/fold (fn [register+new-inner frame+in-scope] - (|let [[register new-inner] register+new-inner - [frame in-scope] frame+in-scope - [register* frame*] (&&lambda/close-over (&/|cons module-name (&/|reverse in-scope)) ident register frame)] - (&/T register* (&/|cons frame* new-inner)))) - (&/T (or (->> top-outer (&/get$ &/$LOCALS) (&/get$ &/$MAPPINGS) (&/|get local-ident)) - (->> top-outer (&/get$ &/$CLOSURE) (&/get$ &/$MAPPINGS) (&/|get local-ident))) - (&/|list)) - (&/zip2 (&/|reverse inner) scopes))] - (&/run-state (|do [btype (&&/expr-type =local) - _ (&type/check exo-type btype)] - (return (&/|list =local))) - (&/set$ &/$ENVS (&/|++ inner* outer) state))) - )))) + [_] + (do ;; (prn 'analyse-symbol/_2.1.2 ?module ?name local-ident) + (fail* "[Analyser Error] Can't have anything other than a global def in the global environment.")))) + (fail* "_{_ analyse-symbol _}_"))) + + [["lux;Cons" [top-outer _]]] + (do ;; (prn 'analyse-symbol/_3 ?module ?name) + (|let [scopes (&/|tail (&/folds #(&/|cons (&/get$ &/$NAME %2) %1) + (&/|map #(&/get$ &/$NAME %) outer) + (&/|reverse inner))) + [=local inner*] (&/fold2 (fn [register+new-inner frame in-scope] + (|let [[register new-inner] register+new-inner + [register* frame*] (&&lambda/close-over (&/|reverse in-scope) ident register frame)] + (&/T register* (&/|cons frame* new-inner)))) + (&/T (or (->> top-outer (&/get$ &/$LOCALS) (&/get$ &/$MAPPINGS) (&/|get local-ident)) + (->> top-outer (&/get$ &/$CLOSURE) (&/get$ &/$MAPPINGS) (&/|get local-ident))) + (&/|list)) + (&/|reverse inner) scopes)] + ((|do [btype (&&/expr-type =local) + _ (&type/check exo-type btype)] + (return (&/|list =local))) + (&/set$ &/$ENVS (&/|++ inner* outer) state)))) + ))) )) -(defn ^:private analyse-apply* [analyse exo-type =fn ?args] - ;; (prn 'analyse-apply* (&/->seq (&/|map &/show-ast ?args))) - ;; (prn 'analyse-apply*/exo-type (&type/show-type exo-type)) - (matchv ::M/objects [=fn] - [[?fun-expr ?fun-type]] - (matchv ::M/objects [?args] - [["lux;Nil" _]] - (|do [_ (&type/check exo-type ?fun-type)] - (return =fn)) - - [["lux;Cons" [?arg ?args*]]] - (|do [?fun-type* (&type/actual-type ?fun-type)] - (matchv ::M/objects [?fun-type*] - [["lux;AllT" _]] - (&type/with-var - (fn [$var] - (|do [type* (&type/apply-type ?fun-type* $var) - output (analyse-apply* analyse exo-type (&/T ?fun-expr type*) ?args)] - (matchv ::M/objects [output $var] - [[?expr* ?type*] ["lux;VarT" ?id]] - ;; (|do [? (&type/bound? ?id)] - ;; (if ? - ;; (return (&/T ?expr* ?type*)) - ;; (|do [type** (&type/clean $var ?type*)] - ;; (return (&/T ?expr* type**))))) - (|do [? (&type/bound? ?id) - _ (if ? - (return nil) - (|do [ex &type/existential] - (&type/set-var ?id ex))) - type** (&type/clean $var ?type*)] - (return (&/T ?expr* type**))) - )))) +(defn ^:private analyse-apply* [analyse exo-type fun-type ?args] + ;; (prn 'analyse-apply* (aget fun-type 0)) + (matchv ::M/objects [?args] + [["lux;Nil" _]] + (|do [_ (&type/check exo-type fun-type)] + (return (&/T fun-type (&/|list)))) + + [["lux;Cons" [?arg ?args*]]] + (|do [?fun-type* (&type/actual-type fun-type)] + (matchv ::M/objects [?fun-type*] + [["lux;AllT" [_aenv _aname _aarg _abody]]] + ;; (|do [$var &type/existential + ;; type* (&type/apply-type ?fun-type* $var)] + ;; (analyse-apply* analyse exo-type type* ?args)) + (&type/with-var + (fn [$var] + (|do [type* (&type/apply-type ?fun-type* $var) + [=output-t =args] (analyse-apply* analyse exo-type type* ?args)] + (matchv ::M/objects [$var] + [["lux;VarT" ?id]] + (|do [? (&type/bound? ?id) + type** (if ? + (&type/clean $var =output-t) + (|do [_ (&type/set-var ?id (&/V "lux;BoundT" _aarg))] + (&type/clean $var =output-t)))] + (return (&/T type** =args))) + )))) - [["lux;LambdaT" [?input-t ?output-t]]] - ;; (|do [=arg (&&/analyse-1 analyse ?input-t ?arg)] - ;; (return (&/T (&/V "apply" (&/T =fn =arg)) - ;; ?output-t))) - (|do [=arg (&&/analyse-1 analyse ?input-t ?arg)] - (analyse-apply* analyse exo-type (&/T (&/V "apply" (&/T =fn =arg)) - ?output-t) - ?args*)) + [["lux;LambdaT" [?input-t ?output-t]]] + (|do [[=output-t =args] (analyse-apply* analyse exo-type ?output-t ?args*) + =arg (&&/analyse-1 analyse ?input-t ?arg)] + (return (&/T =output-t (&/|cons =arg =args)))) - [_] - (fail (str "[Analyser Error] Can't apply a non-function: " (&type/show-type ?fun-type*))))) - ))) + ;; [["lux;VarT" ?id-t]] + ;; (|do [ (&type/deref ?id-t)]) + + [_] + (fail (str "[Analyser Error] Can't apply a non-function: " (&type/show-type ?fun-type*))))) + )) -(defn analyse-apply [analyse exo-type =fn ?args] - ;; (prn 'analyse-apply1 (aget =fn 0)) +(defn analyse-apply [analyse exo-type form-cursor =fn ?args] (|do [loader &/loader] (matchv ::M/objects [=fn] [[=fn-form =fn-type]] - (do ;; (prn 'analyse-apply2 (aget =fn-form 0)) - (matchv ::M/objects [=fn-form] - [["lux;Global" [?module ?name]]] - (|do [[[r-module r-name] $def] (&&module/find-def ?module ?name) - ;; :let [_ (prn 'apply [?module ?name] (aget $def 0))] + (matchv ::M/objects [=fn-form] + [["lux;Global" [?module ?name]]] + (|do [[[r-module r-name] $def] (&&module/find-def ?module ?name)] + (matchv ::M/objects [$def] + [["lux;MacroD" macro]] + (|do [macro-expansion #(-> macro (.apply ?args) (.apply %)) + :let [macro-expansion* (&/|map (partial with-cursor form-cursor) macro-expansion)] + ;; :let [_ (when (and ;; (= "lux/control/monad" ?module) + ;; (= "case" ?name)) + ;; (->> (&/|map &/show-ast macro-expansion*) + ;; (&/|interpose "\n") + ;; (&/fold str "") + ;; (prn ?module "case")))] ] - (matchv ::M/objects [$def] - [["lux;MacroD" macro]] - (|do [macro-expansion #(-> macro (.apply ?args) (.apply %)) - ;; :let [_ (cond (= ?name "using") - ;; (println (str "using: " (->> macro-expansion (&/|map &/show-ast) (&/|interpose " ") (&/fold str "")))) - - ;; ;; (= ?name "def") - ;; ;; (println (str "def " ?module ";" ?name ": " (->> macro-expansion (&/|map &/show-ast) (&/|interpose " ") (&/fold str "")))) - - ;; ;; (= ?name "type`") - ;; ;; (println (str "type`: " (->> macro-expansion (&/|map &/show-ast) (&/|interpose " ") (&/fold str "")))) + (&/flat-map% (partial analyse exo-type) macro-expansion*)) - ;; :else - ;; nil)] - ] - (&/flat-map% (partial analyse exo-type) macro-expansion)) - - [_] - (|do [output (analyse-apply* analyse exo-type =fn ?args)] - (return (&/|list output))))) - [_] - (|do [output (analyse-apply* analyse exo-type =fn ?args)] - (return (&/|list output))))) + (|do [[=output-t =args] (analyse-apply* analyse exo-type =fn-type ?args)] + (return (&/|list (&/T (&/V "apply" (&/T =fn =args)) + =output-t)))))) + + [_] + (|do [[=output-t =args] (analyse-apply* analyse exo-type =fn-type ?args)] + (return (&/|list (&/T (&/V "apply" (&/T =fn =args)) + =output-t))))) ))) (defn analyse-case [analyse exo-type ?value ?branches] - ;; (prn 'analyse-case 'exo-type (&type/show-type exo-type) (&/show-ast ?value)) (|do [:let [num-branches (&/|length ?branches)] _ (&/assert! (> num-branches 0) "[Analyser Error] Can't have empty branches in \"case'\" expression.") _ (&/assert! (even? num-branches) "[Analyser Error] Unbalanced branches in \"case'\" expression.") =value (analyse-1+ analyse ?value) =value-type (&&/expr-type =value) - ;; :let [_ (prn 'analyse-case/GOT_VALUE (&type/show-type =value-type))] - =match (&&case/analyse-branches analyse exo-type =value-type (&/|as-pairs ?branches)) - ;; :let [_ (prn 'analyse-case/GOT_MATCH)] - ] + =match (&&case/analyse-branches analyse exo-type =value-type (&/|as-pairs ?branches))] (return (&/|list (&/T (&/V "case" (&/T =value =match)) exo-type))))) (defn analyse-lambda* [analyse exo-type ?self ?arg ?body] - ;; (prn 'analyse-lambda ?self ?arg ?body) - (matchv ::M/objects [exo-type] - [["lux;LambdaT" [?arg-t ?return-t]]] - (|do [[=scope =captured =body] (&&lambda/with-lambda ?self exo-type - ?arg ?arg-t - (&&/analyse-1 analyse ?return-t ?body))] - (return (&/T (&/V "lambda" (&/T =scope =captured =body)) exo-type))) - - [_] - (fail (str "[Analyser Error] Functions require function types: " - ;; (str (aget ?self 0) ";" (aget ?self 1)) - ;; (str( aget ?arg 0) ";" (aget ?arg 1)) - ;; (&/show-ast ?body) - (&type/show-type exo-type))))) + (|do [exo-type* (&type/actual-type exo-type)] + (matchv ::M/objects [exo-type] + [["lux;AllT" _]] + (&type/with-var + (fn [$var] + (|do [exo-type** (&type/apply-type exo-type* $var)] + (analyse-lambda* analyse exo-type** ?self ?arg ?body)))) + ;; (|do [$var &type/existential + ;; exo-type** (&type/apply-type exo-type* $var)] + ;; (analyse-lambda* analyse exo-type** ?self ?arg ?body)) + + [["lux;LambdaT" [?arg-t ?return-t]]] + (|do [[=scope =captured =body] (&&lambda/with-lambda ?self exo-type* + ?arg ?arg-t + (&&/analyse-1 analyse ?return-t ?body))] + (return (&/T (&/V "lambda" (&/T =scope =captured =body)) exo-type*))) + + [_] + (fail (str "[Analyser Error] Functions require function types: " + (&type/show-type exo-type*)))))) (defn analyse-lambda** [analyse exo-type ?self ?arg ?body] - ;; (prn 'analyse-lambda**/&& (aget exo-type 0)) (matchv ::M/objects [exo-type] [["lux;AllT" [_env _self _arg _body]]] (&type/with-var @@ -336,12 +323,24 @@ [["lux;VarT" ?id]] (|do [? (&type/bound? ?id)] (if ? - (|do [dtype (&/try-all% (&/|list (&type/deref ?id) - (fail "##6##")))] + (|do [dtype (&type/deref ?id) + ;; dtype* (&type/actual-type dtype) + ] (matchv ::M/objects [dtype] + [["lux;BoundT" ?vname]] + (return (&/T _expr exo-type)) + [["lux;ExT" _]] (return (&/T _expr exo-type)) + [["lux;VarT" ?_id]] + (|do [?? (&type/bound? ?_id)] + ;; (return (&/T _expr exo-type)) + (if ?? + (fail (str "[Analyser Error] Can't use type-var in any type-specific way inside polymorphic functions: " ?id ":" _arg " " (&type/show-type dtype))) + (return (&/T _expr exo-type))) + ) + [_] (fail (str "[Analyser Error] Can't use type-var in any type-specific way inside polymorphic functions: " ?id ":" _arg " " (&type/show-type dtype))))) (return (&/T _expr exo-type)))))))) @@ -351,55 +350,32 @@ (analyse-lambda* analyse exo-type* ?self ?arg ?body)) )) -;; (defn analyse-lambda** [analyse exo-type ?self ?arg ?body] -;; ;; (prn 'analyse-lambda**/&& (aget exo-type 0)) -;; (matchv ::M/objects [exo-type] -;; [["lux;AllT" [_env _self _arg _body]]] -;; (&type/with-var -;; (fn [$var] -;; (|do [exo-type* (&type/apply-type exo-type $var) -;; output (analyse-lambda** analyse exo-type* ?self ?arg ?body)] -;; (matchv ::M/objects [$var] -;; [["lux;VarT" ?id]] -;; (|do [? (&type/bound? ?id)] -;; (if ? -;; (|do [dtype (&type/deref ?id)] -;; (fail (str "[Analyser Error] Can't use type-var in any type-specific way inside polymorphic functions: " ?id ":" _arg " " (&type/show-type dtype)))) -;; (return output))))))) - -;; [_] -;; (|do [exo-type* (&type/actual-type exo-type)] -;; (analyse-lambda* analyse exo-type* ?self ?arg ?body)) -;; )) - (defn analyse-lambda [analyse exo-type ?self ?arg ?body] (|do [output (analyse-lambda** analyse exo-type ?self ?arg ?body)] (return (&/|list output)))) (defn analyse-def [analyse ?name ?value] - ;; (prn 'analyse-def/CODE ?name (&/show-ast ?value)) - (prn 'analyse-def/BEGIN ?name) + ;; (prn 'analyse-def/BEGIN ?name) (|do [module-name &/get-module-name ? (&&module/defined? module-name ?name)] (if ? - (fail (str "[Analyser Error] Can't redefine " ?name)) - (|do [;; :let [_ (prn 'analyse-def/_0)] - =value (&/with-scope ?name + (fail (str "[Analyser Error] Can't redefine " (str module-name ";" ?name))) + (|do [=value (&/with-scope ?name (analyse-1+ analyse ?value)) - =value-type (&&/expr-type =value) - ;; :let [_ (prn 'analyse-def/_1 [?name ?value] (aget =value 0 0))] - ] + =value-type (&&/expr-type =value)] (matchv ::M/objects [=value] [[["lux;Global" [?r-module ?r-name]] _]] (|do [_ (&&module/def-alias module-name ?name ?r-module ?r-name =value-type) - :let [_ (println 'analyse-def/ALIAS (str module-name ";" ?name) '=> (str ?r-module ";" ?r-name)) - _ (println)]] + ;; :let [_ (println 'analyse-def/ALIAS (str module-name ";" ?name) '=> (str ?r-module ";" ?r-name)) + ;; _ (println)] + ] (return (&/|list))) [_] (|do [=value-type (&&/expr-type =value) - :let [_ (prn 'analyse-def/END ?name) - _ (println) + :let [;; _ (prn 'analyse-def/END ?name) + _ (println 'DEF (str module-name ";" ?name)) + ;; _ (println) def-data (cond (&type/type= &type/Type =value-type) (&/V "lux;TypeD" nil) @@ -410,41 +386,43 @@ )))) (defn analyse-declare-macro [analyse ?name] - (|do [module-name &/get-module-name - _ (&&module/declare-macro module-name ?name)] - (return (&/|list)))) - -(defn analyse-declare-macro [analyse ?name] (|do [module-name &/get-module-name] (return (&/|list (&/V "declare-macro" (&/T module-name ?name)))))) -(defn analyse-import [analyse exo-type ?path] - (return (&/|list))) +(defn analyse-import [analyse compile-module ?path] + (|do [module-name &/get-module-name + _ (if (= module-name ?path) + (fail (str "[Analyser Error] Module can't import itself: " ?path)) + (return nil))] + (&/save-module + (|do [already-compiled? (&&module/exists? ?path) + ;; :let [_ (prn 'analyse-import module-name ?path already-compiled?)] + _ (&&module/add-import ?path) + _ (&/when% (not already-compiled?) (compile-module ?path))] + (return (&/|list)))))) (defn analyse-export [analyse name] (|do [module-name &/get-module-name _ (&&module/export module-name name)] (return (&/|list)))) +(defn analyse-alias [analyse ex-alias ex-module] + (|do [module-name &/get-module-name + _ (&&module/alias module-name ex-alias ex-module)] + (return (&/|list)))) + (defn analyse-check [analyse eval! exo-type ?type ?value] - ;; (println "analyse-check#0") (|do [=type (&&/analyse-1 analyse &type/Type ?type) - ;; =type (analyse-1+ analyse ?type) - ;; :let [_ (println "analyse-check#1")] ==type (eval! =type) _ (&type/check exo-type ==type) - ;; :let [_ (println "analyse-check#4" (&type/show-type ==type))] - =value (&&/analyse-1 analyse ==type ?value) - ;; :let [_ (println "analyse-check#5")] - ] - (matchv ::M/objects [=value] - [[?expr ?expr-type]] - (return (&/|list (&/T ?expr ==type)))))) + =value (&&/analyse-1 analyse ==type ?value)] + (return (&/|list (&/T (&/V "ann" (&/T =value =type)) + ==type))))) (defn analyse-coerce [analyse eval! exo-type ?type ?value] (|do [=type (&&/analyse-1 analyse &type/Type ?type) ==type (eval! =type) + _ (&type/check exo-type ==type) =value (&&/analyse-1 analyse ==type ?value)] - (matchv ::M/objects [=value] - [[?expr ?expr-type]] - (return (&/|list (&/T ?expr ==type)))))) + (return (&/|list (&/T (&/V "ann" (&/T =value =type)) + ==type))))) diff --git a/src/lux/analyser/module.clj b/src/lux/analyser/module.clj index de68f48aa..68cdc4747 100644 --- a/src/lux/analyser/module.clj +++ b/src/lux/analyser/module.clj @@ -1,89 +1,153 @@ +;; 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.analyser.module - (:require [clojure.core.match :as M :refer [matchv]] + (:refer-clojure :exclude [alias]) + (:require [clojure.string :as string] + [clojure.core.match :as M :refer [matchv]] clojure.core.match.array - (lux [base :as & :refer [|do return return* fail fail*]] + (lux [base :as & :refer [|let |do return return* fail fail*]] [type :as &type] [host :as &host]) [lux.analyser.base :as &&])) +;; [Utils] +(def ^:private $DEFS 0) +(def ^:private $ALIASES 1) +(def ^:private $IMPORTS 2) +(def ^:private +init+ + (&/R ;; "lux;defs" + (&/|table) + ;; "lux;module-aliases" + (&/|table) + ;; "lux;imports" + (&/|list) + )) + ;; [Exports] -(def init-module - (&/|table)) +(defn add-import [module] + "(-> Text (Lux (,)))" + (|do [current-module &/get-module-name] + (fn [state] + (return* (&/update$ &/$MODULES + (fn [ms] + (&/|update current-module + (fn [m] (&/update$ $IMPORTS (partial &/|cons module) m)) + ms)) + state) + nil)))) (defn define [module name def-data type] (fn [state] (matchv ::M/objects [(&/get$ &/$ENVS state)] [["lux;Cons" [?env ["lux;Nil" _]]]] (return* (->> state - (&/update$ &/$MODULES (fn [ms] - (&/|update module #(&/|put name (&/T false def-data) %) - ms))) - (&/set$ &/$ENVS (&/|list (&/update$ &/$LOCALS (fn [locals] - (&/update$ &/$MAPPINGS (fn [mappings] - (&/|put (str "" &/+name-separator+ name) - (&/T (&/V "lux;Global" (&/T module name)) type) - mappings)) - locals)) - ?env)))) + (&/update$ &/$MODULES + (fn [ms] + (&/|update module + (fn [m] + (&/update$ $DEFS + #(&/|put name (&/T false def-data) %) + m)) + ms)))) nil) [_] - (fail* "[Analyser Error] Can't create a new global definition outside of a global environment.")))) + (fail* (str "[Analyser Error] Can't create a new global definition outside of a global environment: " module ";" name))))) + +(defn def-type [module name] + "(-> Text Text (Lux Type))" + (fn [state] + (if-let [$module (->> state (&/get$ &/$MODULES) (&/|get module))] + (if-let [$def (->> $module (&/get$ $DEFS) (&/|get name))] + (matchv ::M/objects [$def] + [[_ ["lux;TypeD" _]]] + (return* state &type/Type) + + [[_ ["lux;MacroD" _]]] + (return* state &type/Macro) + + [[_ ["lux;ValueD" _type]]] + (return* state _type) + + [[_ ["lux;AliasD" [?r-module ?r-name]]]] + (&/run-state (def-type ?r-module ?r-name) + state)) + (fail* (str "[Analyser Error] Unknown definition: " (str module ";" name)))) + (fail* (str "[Analyser Error] Unknown module: " module))))) (defn def-alias [a-module a-name r-module r-name type] + ;; (prn 'def-alias [a-module a-name] [r-module r-name] (&type/show-type type)) (fn [state] - ;; (prn 'def-alias [a-module a-name] '=> [r-module r-name]) (matchv ::M/objects [(&/get$ &/$ENVS state)] [["lux;Cons" [?env ["lux;Nil" _]]]] (return* (->> state - (&/update$ &/$MODULES (fn [ms] - (&/|update a-module #(&/|put a-name (&/T false (&/V "lux;AliasD" (&/T r-module r-name))) %) - ms))) - (&/set$ &/$ENVS (&/|list (&/update$ &/$LOCALS (fn [locals] - (&/update$ &/$MAPPINGS (fn [mappings] - (&/|put (str "" &/+name-separator+ a-name) - (&/T (&/V "lux;Global" (&/T r-module r-name)) type) - mappings)) - locals)) - ?env)))) + (&/update$ &/$MODULES + (fn [ms] + (&/|update a-module + (fn [m] + (&/update$ $DEFS + #(&/|put a-name (&/T false (&/V "lux;AliasD" (&/T r-module r-name))) %) + m)) + ms)))) nil) [_] (fail* "[Analyser Error] Can't alias a global definition outside of a global environment.")))) (defn exists? [name] + "(-> Text (Lux Bool))" (fn [state] - ;; (prn `exists? name (->> state (&/get$ &/$MODULES) (&/|contains? name))) (return* state (->> state (&/get$ &/$MODULES) (&/|contains? name))))) -(defn dealias [name] +(defn alias [module alias reference] (fn [state] - (if-let [real-name (->> state (&/get$ &/$MODULE-ALIASES) (&/|get name))] - (return* state real-name) - (fail* (str "Unknown alias: " name))))) + (return* (->> state + (&/update$ &/$MODULES + (fn [ms] + (&/|update module + #(&/update$ $ALIASES + (fn [aliases] + (&/|put alias reference aliases)) + %) + ms)))) + nil))) + +(defn dealias [name] + (|do [current-module &/get-module-name] + (fn [state] + (if-let [real-name (->> state (&/get$ &/$MODULES) (&/|get current-module) (&/get$ $ALIASES) (&/|get name))] + (return* state real-name) + (fail* (str "Unknown alias: " name)))))) (defn find-def [module name] (|do [current-module &/get-module-name] (fn [state] + ;; (prn 'find-def/_0 module name 'current-module current-module) (if-let [$module (->> state (&/get$ &/$MODULES) (&/|get module))] - (if-let [$def (&/|get name $module)] - (matchv ::M/objects [$def] - [[exported? $$def]] - (if (or exported? (= current-module module)) - (matchv ::M/objects [$$def] - [["lux;AliasD" [?r-module ?r-name]]] - (&/run-state (find-def ?r-module ?r-name) - state) + (do ;; (prn 'find-def/_0.1 module (&/->seq (&/|keys $module))) + (if-let [$def (->> $module (&/get$ $DEFS) (&/|get name))] + (matchv ::M/objects [$def] + [[exported? $$def]] + (do ;; (prn 'find-def/_1 module name 'exported? exported? (.equals ^Object current-module module)) + (if (or exported? (.equals ^Object current-module module)) + (matchv ::M/objects [$$def] + [["lux;AliasD" [?r-module ?r-name]]] + (do ;; (prn 'find-def/_2 [module name] [?r-module ?r-name]) + ((find-def ?r-module ?r-name) + state)) - [_] - (return* state (&/T (&/T module name) $$def))) - (fail* (str "[Analyser Error] Can't use unexported definition: " (str module &/+name-separator+ name))))) - (fail* (str "[Analyser Error] Definition doesn't exist: " (str module &/+name-separator+ name)))) - (do (prn [module name] - (str "[Analyser Error] Module doesn't exist: " module) - (->> state (&/get$ &/$MODULES) &/|keys &/->seq)) - (fail* (str "[Analyser Error] Module doesn't exist: " module))))))) + [_] + (return* state (&/T (&/T module name) $$def))) + (fail* (str "[Analyser Error] Can't use unexported definition: " (str module &/+name-separator+ name)))))) + (fail* (str "[Analyser Error] Definition does not exist: " (str module &/+name-separator+ name))))) + (fail* (str "[Analyser Error] Module doesn't exist: " module)))))) (defn defined? [module name] (&/try-all% (&/|list (|do [_ (find-def module name)] @@ -92,38 +156,41 @@ (defn declare-macro [module name] (fn [state] - (if-let [$module (->> state (&/get$ &/$MODULES) (&/|get module))] + (if-let [$module (->> state (&/get$ &/$MODULES) (&/|get module) (&/get$ $DEFS))] (if-let [$def (&/|get name $module)] (matchv ::M/objects [$def] [[exported? ["lux;ValueD" ?type]]] - (do ;; (prn 'declare-macro/?type (aget ?type 0)) - (&/run-state (|do [_ (&type/check &type/Macro ?type) - ^ClassLoader loader &/loader - :let [macro (-> (.loadClass loader (&host/location (&/|list module name))) - (.getField "_datum") - (.get nil))]] - (fn [state*] - (return* (&/update$ &/$MODULES - (fn [$modules] - (&/|put module (&/|put name (&/T exported? (&/V "lux;MacroD" macro)) $module) - $modules)) - state*) - nil))) - state)) + ((|do [_ (&type/check &type/Macro ?type) + ^ClassLoader loader &/loader + :let [macro (-> (.loadClass loader (str (&host/->module-class module) "." (&/normalize-name name))) + (.getField "_datum") + (.get nil))]] + (fn [state*] + (return* (&/update$ &/$MODULES + (fn [$modules] + (&/|update module + (fn [m] + (&/update$ $DEFS + #(&/|put name (&/T exported? (&/V "lux;MacroD" macro)) %) + m)) + $modules)) + state*) + nil))) + state) [[_ ["lux;MacroD" _]]] (fail* (str "[Analyser Error] Can't re-declare a macro: " (str module &/+name-separator+ name))) [[_ ["lux;TypeD" _]]] - (fail* (str "[Analyser Error] Definition doesn't have macro type: " module ";" name))) - (fail* (str "[Analyser Error] Definition doesn't exist: " (str module &/+name-separator+ name)))) - (fail* (str "[Analyser Error] Module doesn't exist: " module))))) + (fail* (str "[Analyser Error] Definition does not have macro type: " (str module &/+name-separator+ name)))) + (fail* (str "[Analyser Error] Definition does not exist: " (str module &/+name-separator+ name)))) + (fail* (str "[Analyser Error] Module does not exist: " module))))) (defn export [module name] (fn [state] (matchv ::M/objects [(&/get$ &/$ENVS state)] [["lux;Cons" [?env ["lux;Nil" _]]]] - (if-let [$def (->> state (&/get$ &/$MODULES) (&/|get module) (&/|get name))] + (if-let [$def (->> state (&/get$ &/$MODULES) (&/|get module) (&/get$ $DEFS) (&/|get name))] (matchv ::M/objects [$def] [[true _]] (fail* (str "[Analyser Error] Definition has already been exported: " module ";" name)) @@ -131,10 +198,52 @@ [[false ?data]] (return* (->> state (&/update$ &/$MODULES (fn [ms] - (&/|update module #(&/|put name (&/T true ?data) %) + (&/|update module (fn [m] + (&/update$ $DEFS + #(&/|put name (&/T true ?data) %) + m)) ms)))) nil)) - (fail* (str "[Analyser Error] Can't export an inexistent definition: " module ";" name))) + (fail* (str "[Analyser Error] Can't export an inexistent definition: " (str module &/+name-separator+ name)))) [_] (fail* "[Analyser Error] Can't export a global definition outside of a global environment.")))) + +(def defs + (|do [module &/get-module-name] + (fn [state] + (return* state + (&/|map (fn [kv] + (|let [[k v] kv] + (matchv ::M/objects [v] + [[?exported? ?def]] + (do ;; (prn 'defs k ?exported?) + (matchv ::M/objects [?def] + [["lux;AliasD" [?r-module ?r-name]]] + (&/T ?exported? k (str "A" ?r-module ";" ?r-name)) + + [["lux;MacroD" _]] + (&/T ?exported? k "M") + + [["lux;TypeD" _]] + (&/T ?exported? k "T") + + [_] + (&/T ?exported? k "V")))))) + (->> state (&/get$ &/$MODULES) (&/|get module) (&/get$ $DEFS))))))) + +(def imports + (|do [module &/get-module-name] + (fn [state] + (return* state (->> state (&/get$ &/$MODULES) (&/|get module) (&/get$ $IMPORTS)))))) + +(defn create-module [name] + (fn [state] + (return* (&/update$ &/$MODULES #(&/|put name +init+ %) state) nil))) + +(defn enter-module [name] + (fn [state] + (return* (->> state + (&/update$ &/$MODULES #(&/|put name +init+ %)) + (&/set$ &/$ENVS (&/|list (&/env name)))) + nil))) diff --git a/src/lux/base.clj b/src/lux/base.clj index 70a658d19..eb94c2c90 100644 --- a/src/lux/base.clj +++ b/src/lux/base.clj @@ -1,3 +1,11 @@ +;; 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.base (:require (clojure [template :refer [do-template]]) [clojure.core.match :as M :refer [matchv]] @@ -15,14 +23,14 @@ (def $NAME 3) ;; Host -(def $EVAL-CTOR 0) +(def $CLASSES 0) (def $LOADER 1) (def $WRITER 2) ;; CompilerState (def $ENVS 0) -(def $HOST 1) -(def $MODULE-ALIASES 2) +(def $EVAL? 1) +(def $HOST 2) (def $MODULES 3) (def $SEED 4) (def $SOURCE 5) @@ -81,13 +89,12 @@ (reverse (partition 2 elems)))) (defn |get [slot table] - ;; (prn '|get slot (aget table 0)) (matchv ::M/objects [table] [["lux;Nil" _]] nil [["lux;Cons" [[k v] table*]]] - (if (= k slot) + (if (.equals ^Object k slot) v (|get slot table*)))) @@ -97,7 +104,7 @@ (V "lux;Cons" (T (T slot value) (V "lux;Nil" nil))) [["lux;Cons" [[k v] table*]]] - (if (= k slot) + (if (.equals ^Object k slot) (V "lux;Cons" (T (T slot value) table*)) (V "lux;Cons" (T (T k v) (|put slot value table*)))))) @@ -107,26 +114,17 @@ table [["lux;Cons" [[k v] table*]]] - (if (= k slot) + (if (.equals ^Object k slot) table* (V "lux;Cons" (T (T k v) (|remove slot table*)))))) -(defn |merge [table1 table2] - ;; (prn '|merge (aget table1 0) (aget table2 0)) - (matchv ::M/objects [table2] - [["lux;Nil" _]] - table1 - - [["lux;Cons" [[k v] table2*]]] - (|merge (|put k v table1) table2*))) - (defn |update [k f table] (matchv ::M/objects [table] [["lux;Nil" _]] table [["lux;Cons" [[k* v] table*]]] - (if (= k k*) + (if (.equals ^Object k k*) (V "lux;Cons" (T (T k* (f v)) table*)) (V "lux;Cons" (T (T k* v) (|update k f table*)))))) @@ -149,7 +147,6 @@ ;; [Resources/Monads] (defn fail [message] (fn [_] - ;; (prn 'FAIL message) (V "lux;Left" message))) (defn return [value] @@ -168,7 +165,6 @@ )))) (defmacro |do [steps return] - (assert (not= 0 (count steps)) "The steps can't be empty!") (assert (= 0 (rem (count steps) 2)) "The number of steps must be even!") (reduce (fn [inner [label computation]] (case label @@ -178,28 +174,15 @@ (fn [val#] (matchv ::M/objects [val#] [~label] - ~inner))) - ;; `(bind ~computation - ;; (fn [~label] ~inner)) - )) + ~inner))))) return (reverse (partition 2 steps)))) ;; [Resources/Combinators] -(defn try% [monad] - (fn [state] - (matchv ::M/objects [(monad state)] - [["lux;Right" [?state ?datum]]] - (return* ?state ?datum) - - [_] - (return* state nil)))) - (defn |cons [head tail] (V "lux;Cons" (T head tail))) (defn |++ [xs ys] - ;; (prn '|++ (and xs (aget xs 0)) (and ys (aget ys 0))) (matchv ::M/objects [xs] [["lux;Nil" _]] ys @@ -208,7 +191,6 @@ (V "lux;Cons" (T x (|++ xs* ys))))) (defn |map [f xs] - ;; (prn '|map (aget xs 0)) (matchv ::M/objects [xs] [["lux;Nil" _]] xs @@ -259,7 +241,7 @@ false [["lux;Cons" [[k* _] table*]]] - (or (= k k*) + (or (.equals ^Object k k*) (|contains? k table*)))) (defn fold [f init xs] @@ -288,7 +270,6 @@ (|cons init (folds f (f init x) xs*)))) (defn |length [xs] - ;; (prn '|length (aget xs 0)) (fold (fn [acc _] (inc acc)) 0 xs)) (let [|range* (fn |range* [from to] @@ -343,21 +324,21 @@ (do-template [<name> <joiner>] (defn <name> [f xs] - ;; (prn '<name> 0 (aget xs 0)) (matchv ::M/objects [xs] [["lux;Nil" _]] (return xs) [["lux;Cons" [x xs*]]] (|do [y (f x) - ;; :let [_ (prn '<name> 1 (class y)) - ;; _ (prn '<name> 2 (aget y 0))] - ys (<name> f xs*)] + ys (<name> f xs*)] (return (<joiner> y ys))))) map% |cons flat-map% |++) +(defn list-join [xss] + (fold |++ (V "lux;Nil" nil) xss)) + (defn |as-pairs [xs] (matchv ::M/objects [xs] [["lux;Cons" [x ["lux;Cons" [y xs*]]]]] @@ -372,65 +353,15 @@ (|list) xs)) -(defn show-table [table] - ;; (prn 'show-table (aget table 0)) - (str "{{" - (->> table - (|map (fn [kv] (|let [[k v] kv] (str k " = ???")))) - (|interpose " ") - (fold str "")) - "}}")) - -(defn apply% [monad call-state] - (fn [state] - ;; (prn 'apply-m monad call-state) - (let [output (monad call-state)] - ;; (prn 'apply-m/output output) - (matchv ::M/objects [output] - [["lux;Right" [?state ?datum]]] - (return* state ?datum) - - [_] - output)))) - (defn assert! [test message] (if test (return nil) (fail message))) -(defn comp% [f-m g-m] - (|do [temp g-m] - (f-m temp))) - -(defn pass [m-value] - (fn [state] - m-value)) - (def get-state (fn [state] (return* state state))) -(defn sequence% [m-values] - (matchv ::M/objects [m-values] - [["lux;Cons" [head tail]]] - (|do [_ head] - (sequence% tail)) - - [_] - (return nil))) - -(def source-consumed? - (fn [state] - (matchv ::M/objects [(get$ $SOURCE state)] - [["lux;None" _]] - (fail* "No source code.") - - [["lux;Some" ["lux;Nil" _]]] - (return* state true) - - [["lux;Some" _]] - (return* state false)))) - (defn try-all% [monads] (matchv ::M/objects [monads] [["lux;Nil" _]] @@ -464,18 +395,9 @@ ((exhaust% step) state*) [["lux;Left" msg]] - ((|do [? source-consumed?] - (if ? - (return nil) - (fail msg))) - state) - ;; (if (= "[Reader Error] EOF" msg) - ;; ((|do [? source-consumed? - ;; :let [_ (prn '? ?)]] - ;; (return nil)) - ;; state) - ;; (fail* msg)) - ))) + (if (.equals "[Reader Error] EOF" msg) + (return* state nil) + (fail* msg))))) (defn ^:private normalize-char [char] (case char @@ -501,16 +423,21 @@ \< "_LT_" \> "_GT_" \~ "_TILDE_" + \| "_PIPE_" ;; default char)) -(defn normalize-ident [ident] +(defn normalize-name [ident] (reduce str "" (map normalize-char ident))) (def loader (fn [state] (return* state (->> state (get$ $HOST) (get$ $LOADER))))) +(def classes + (fn [state] + (return* state (->> state (get$ $HOST) (get$ $CLASSES))))) + (def +init-bindings+ (R ;; "lux;counter" 0 @@ -528,21 +455,40 @@ name )) +(let [define-class (doto (.getDeclaredMethod java.lang.ClassLoader "defineClass" (into-array [String + (class (byte-array [])) + Integer/TYPE + Integer/TYPE])) + (.setAccessible true))] + (defn memory-class-loader [store] + (proxy [java.lang.ClassLoader] + [] + (findClass [^String class-name] + ;; (prn 'findClass class-name) + (if-let [^bytes bytecode (get @store class-name)] + (try (.invoke define-class this (to-array [class-name bytecode (int 0) (int (alength bytecode))])) + (catch java.lang.reflect.InvocationTargetException e + (prn 'InvocationTargetException (.getCause e)) + (throw e))) + (do (prn 'memory-class-loader/store class-name (keys @store)) + (throw (IllegalStateException. (str "[Class Loader] Unknown class: " class-name))))))))) + (defn host [_] - (R ;; "lux;eval-ctor" - 0 - ;; "lux;loader" - (-> (java.io.File. "./output/") .toURL vector into-array java.net.URLClassLoader.) - ;; "lux;writer" - (V "lux;None" nil))) + (let [store (atom {})] + (R ;; "lux;classes" + store + ;; "lux;loader" + (memory-class-loader store) + ;; "lux;writer" + (V "lux;None" nil)))) (defn init-state [_] (R ;; "lux;envs" (|list) + ;; "lux;eval?" + false ;; "lux;host" (host nil) - ;; "lux;module-aliases" - (|table) ;; "lux;modules" (|table) ;; "lux;seed" @@ -553,24 +499,34 @@ +init-bindings+ )) -(defn from-some [some] - (matchv ::M/objects [some] - [["lux;Some" datum]] - datum +(defn save-module [body] + (fn [state] + (matchv ::M/objects [(body state)] + [["lux;Right" [state* output]]] + (return* (->> state* + (set$ $ENVS (get$ $ENVS state)) + (set$ $SOURCE (get$ $SOURCE state))) + output) - [_] - (assert false))) + [["lux;Left" msg]] + (fail* msg)))) + +(defn with-eval [body] + (fn [state] + (matchv ::M/objects [(body (set$ $EVAL? true state))] + [["lux;Right" [state* output]]] + (return* (set$ $EVAL? (get$ $EVAL? state) state*) output) -(def get-eval-ctor + [["lux;Left" msg]] + (fail* msg)))) + +(def get-eval (fn [state] - (return* (update$ $HOST #(update$ $EVAL-CTOR inc %) state) - (get$ $EVAL-CTOR (get$ $HOST state))))) + (return* state (get$ $EVAL? state)))) (def get-writer (fn [state] (let [writer* (->> state (get$ $HOST) (get$ $WRITER))] - ;; (prn 'get-writer (class writer*)) - ;; (prn 'get-writer (aget writer* 0)) (matchv ::M/objects [writer*] [["lux;Some" datum]] (return* state datum) @@ -640,9 +596,8 @@ state)))))) (def get-scope-name - (|do [module-name get-module-name] - (fn [state] - (return* state (->> state (get$ $ENVS) (|map #(get$ $NAME %)) |reverse (|cons module-name)))))) + (fn [state] + (return* state (->> state (get$ $ENVS) (|map #(get$ $NAME %)) |reverse)))) (defn with-writer [writer body] (fn [state] @@ -656,54 +611,113 @@ output)))) (defn show-ast [ast] - ;; (prn 'show-ast (aget ast 0)) - ;; (prn 'show-ast (aget ast 1 1 0)) - ;; (cond (= "lux;Meta" (aget ast 1 1 0)) - ;; (prn 'EXTRA 'show-ast (aget ast 1 1 1 1 0)) - - ;; (= "lux;Symbol" (aget ast 1 1 0)) - ;; (prn 'EXTRA 'show-ast (aget ast 1 1 1 1)) - - ;; :else - ;; nil) (matchv ::M/objects [ast] - [["lux;Meta" [_ ["lux;Bool" ?value]]]] + [["lux;Meta" [_ ["lux;BoolS" ?value]]]] (pr-str ?value) - [["lux;Meta" [_ ["lux;Int" ?value]]]] + [["lux;Meta" [_ ["lux;IntS" ?value]]]] (pr-str ?value) - [["lux;Meta" [_ ["lux;Real" ?value]]]] + [["lux;Meta" [_ ["lux;RealS" ?value]]]] (pr-str ?value) - [["lux;Meta" [_ ["lux;Char" ?value]]]] + [["lux;Meta" [_ ["lux;CharS" ?value]]]] (pr-str ?value) - [["lux;Meta" [_ ["lux;Text" ?value]]]] + [["lux;Meta" [_ ["lux;TextS" ?value]]]] (str "\"" ?value "\"") - [["lux;Meta" [_ ["lux;Tag" [?module ?tag]]]]] + [["lux;Meta" [_ ["lux;TagS" [?module ?tag]]]]] (str "#" ?module ";" ?tag) - [["lux;Meta" [_ ["lux;Symbol" [?module ?ident]]]]] - (if (= "" ?module) + [["lux;Meta" [_ ["lux;SymbolS" [?module ?ident]]]]] + (if (.equals "" ?module) ?ident (str ?module ";" ?ident)) - [["lux;Meta" [_ ["lux;Tuple" ?elems]]]] + [["lux;Meta" [_ ["lux;TupleS" ?elems]]]] (str "[" (->> ?elems (|map show-ast) (|interpose " ") (fold str "")) "]") - [["lux;Meta" [_ ["lux;Record" ?elems]]]] + [["lux;Meta" [_ ["lux;RecordS" ?elems]]]] (str "{" (->> ?elems (|map (fn [elem] (|let [[k v] elem] (str (show-ast k) " " (show-ast v))))) (|interpose " ") (fold str "")) "}") - [["lux;Meta" [_ ["lux;Form" ?elems]]]] + [["lux;Meta" [_ ["lux;FormS" ?elems]]]] (str "(" (->> ?elems (|map show-ast) (|interpose " ") (fold str "")) ")") )) (defn ident->text [ident] (|let [[?module ?name] ident] (str ?module ";" ?name))) + +(defn fold2% [f init xs ys] + (matchv ::M/objects [xs ys] + [["lux;Cons" [x xs*]] ["lux;Cons" [y ys*]]] + (|do [init* (f init x y)] + (fold2% f init* xs* ys*)) + + [["lux;Nil" _] ["lux;Nil" _]] + (return init) + + [_ _] + (fail "Lists don't match in size."))) + +(defn map2% [f xs ys] + (matchv ::M/objects [xs ys] + [["lux;Cons" [x xs*]] ["lux;Cons" [y ys*]]] + (|do [z (f x y) + zs (map2% f xs* ys*)] + (return (|cons z zs))) + + [["lux;Nil" _] ["lux;Nil" _]] + (return (V "lux;Nil" nil)) + + [_ _] + (fail "Lists don't match in size."))) + +(defn map2 [f xs ys] + (matchv ::M/objects [xs ys] + [["lux;Cons" [x xs*]] ["lux;Cons" [y ys*]]] + (|cons (f x y) (map2 f xs* ys*)) + + [_ _] + (V "lux;Nil" nil))) + +(defn fold2 [f init xs ys] + (matchv ::M/objects [xs ys] + [["lux;Cons" [x xs*]] ["lux;Cons" [y ys*]]] + (and init + (fold2 f (f init x y) xs* ys*)) + + [["lux;Nil" _] ["lux;Nil" _]] + init + + [_ _] + false)) + +(defn ^:private enumerate* [idx xs] + (matchv ::M/objects [xs] + [["lux;Cons" [x xs*]]] + (V "lux;Cons" (T (T idx x) + (enumerate* (inc idx) xs*))) + + [["lux;Nil" _]] + xs + )) + +(defn enumerate [xs] + (enumerate* 0 xs)) + +(def modules + "(Lux (List Text))" + (fn [state] + (return* state (|keys (get$ $MODULES state))))) + +(defn when% [test body] + "(-> Bool (Lux (,)) (Lux (,)))" + (if test + body + (return nil))) diff --git a/src/lux/compiler.clj b/src/lux/compiler.clj index 5a9f1b39d..3449900e0 100644 --- a/src/lux/compiler.clj +++ b/src/lux/compiler.clj @@ -1,3 +1,11 @@ +;; 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 (:refer-clojure :exclude [compile]) (:require (clojure [string :as string] @@ -5,7 +13,7 @@ [template :refer [do-template]]) [clojure.core.match :as M :refer [matchv]] clojure.core.match.array - (lux [base :as & :refer [|do return* return fail fail*]] + (lux [base :as & :refer [|let |do return* return fail fail*]] [type :as &type] [reader :as &reader] [lexer :as &lexer] @@ -16,12 +24,12 @@ [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] - [lambda :as &&lambda]) - ;; :reload - ) + [lambda :as &&lambda] + [package :as &&package])) (:import (org.objectweb.asm Opcodes Label ClassWriter @@ -29,280 +37,293 @@ ;; [Utils/Compilers] (defn ^:private compile-expression [syntax] - ;; (prn 'compile-expression (aget syntax 0)) (matchv ::M/objects [syntax] [[?form ?type]] - (do ;; (prn 'compile-expression2 (aget ?form 0)) - (matchv ::M/objects [?form] - [["bool" ?value]] - (&&lux/compile-bool compile-expression ?type ?value) + (matchv ::M/objects [?form] + [["bool" ?value]] + (&&lux/compile-bool compile-expression ?type ?value) + + [["int" ?value]] + (&&lux/compile-int compile-expression ?type ?value) + + [["real" ?value]] + (&&lux/compile-real compile-expression ?type ?value) + + [["char" ?value]] + (&&lux/compile-char compile-expression ?type ?value) - [["int" ?value]] - (&&lux/compile-int compile-expression ?type ?value) + [["text" ?value]] + (&&lux/compile-text compile-expression ?type ?value) - [["real" ?value]] - (&&lux/compile-real compile-expression ?type ?value) + [["tuple" ?elems]] + (&&lux/compile-tuple compile-expression ?type ?elems) - [["char" ?value]] - (&&lux/compile-char compile-expression ?type ?value) + [["record" ?elems]] + (&&lux/compile-record compile-expression ?type ?elems) - [["text" ?value]] - (&&lux/compile-text compile-expression ?type ?value) + [["lux;Local" ?idx]] + (&&lux/compile-local compile-expression ?type ?idx) - [["tuple" ?elems]] - (&&lux/compile-tuple compile-expression ?type ?elems) + [["captured" [?scope ?captured-id ?source]]] + (&&lux/compile-captured compile-expression ?type ?scope ?captured-id ?source) - [["record" ?elems]] - (&&lux/compile-record compile-expression ?type ?elems) + [["lux;Global" [?owner-class ?name]]] + (&&lux/compile-global compile-expression ?type ?owner-class ?name) - [["lux;Local" ?idx]] - (&&lux/compile-local compile-expression ?type ?idx) + [["apply" [?fn ?args]]] + (&&lux/compile-apply compile-expression ?type ?fn ?args) - [["captured" [?scope ?captured-id ?source]]] - (&&lux/compile-captured compile-expression ?type ?scope ?captured-id ?source) + [["variant" [?tag ?members]]] + (&&lux/compile-variant compile-expression ?type ?tag ?members) - [["lux;Global" [?owner-class ?name]]] - (&&lux/compile-global compile-expression ?type ?owner-class ?name) + [["case" [?value ?match]]] + (&&case/compile-case compile-expression ?type ?value ?match) - [["apply" [?fn ?arg]]] - (&&lux/compile-apply compile-expression ?type ?fn ?arg) + [["lambda" [?scope ?env ?body]]] + (&&lambda/compile-lambda compile-expression ?scope ?env ?body) - [["variant" [?tag ?members]]] - (&&lux/compile-variant compile-expression ?type ?tag ?members) + [["ann" [?value-ex ?type-ex]]] + (&&lux/compile-ann compile-expression ?type ?value-ex ?type-ex) - [["case" [?value ?match]]] - (&&case/compile-case compile-expression ?type ?value ?match) + ;; Characters + [["jvm-ceq" [?x ?y]]] + (&&host/compile-jvm-ceq compile-expression ?type ?x ?y) - [["lambda" [?scope ?env ?body]]] - (&&lambda/compile-lambda compile-expression ?scope ?env ?body) + [["jvm-clt" [?x ?y]]] + (&&host/compile-jvm-clt compile-expression ?type ?x ?y) - ;; Integer arithmetic - [["jvm-iadd" [?x ?y]]] - (&&host/compile-jvm-iadd compile-expression ?type ?x ?y) + [["jvm-cgt" [?x ?y]]] + (&&host/compile-jvm-cgt compile-expression ?type ?x ?y) + + ;; Integer arithmetic + [["jvm-iadd" [?x ?y]]] + (&&host/compile-jvm-iadd compile-expression ?type ?x ?y) - [["jvm-isub" [?x ?y]]] - (&&host/compile-jvm-isub compile-expression ?type ?x ?y) - - [["jvm-imul" [?x ?y]]] - (&&host/compile-jvm-imul compile-expression ?type ?x ?y) - - [["jvm-idiv" [?x ?y]]] - (&&host/compile-jvm-idiv compile-expression ?type ?x ?y) - - [["jvm-irem" [?x ?y]]] - (&&host/compile-jvm-irem compile-expression ?type ?x ?y) + [["jvm-isub" [?x ?y]]] + (&&host/compile-jvm-isub compile-expression ?type ?x ?y) + + [["jvm-imul" [?x ?y]]] + (&&host/compile-jvm-imul compile-expression ?type ?x ?y) + + [["jvm-idiv" [?x ?y]]] + (&&host/compile-jvm-idiv compile-expression ?type ?x ?y) + + [["jvm-irem" [?x ?y]]] + (&&host/compile-jvm-irem compile-expression ?type ?x ?y) - [["jvm-ieq" [?x ?y]]] - (&&host/compile-jvm-ieq compile-expression ?type ?x ?y) + [["jvm-ieq" [?x ?y]]] + (&&host/compile-jvm-ieq compile-expression ?type ?x ?y) - [["jvm-ilt" [?x ?y]]] - (&&host/compile-jvm-ilt compile-expression ?type ?x ?y) + [["jvm-ilt" [?x ?y]]] + (&&host/compile-jvm-ilt compile-expression ?type ?x ?y) - [["jvm-igt" [?x ?y]]] - (&&host/compile-jvm-igt compile-expression ?type ?x ?y) + [["jvm-igt" [?x ?y]]] + (&&host/compile-jvm-igt compile-expression ?type ?x ?y) - ;; Long arithmetic - [["jvm-ladd" [?x ?y]]] - (&&host/compile-jvm-ladd compile-expression ?type ?x ?y) - - [["jvm-lsub" [?x ?y]]] - (&&host/compile-jvm-lsub compile-expression ?type ?x ?y) - - [["jvm-lmul" [?x ?y]]] - (&&host/compile-jvm-lmul compile-expression ?type ?x ?y) - - [["jvm-ldiv" [?x ?y]]] - (&&host/compile-jvm-ldiv compile-expression ?type ?x ?y) - - [["jvm-lrem" [?x ?y]]] - (&&host/compile-jvm-lrem compile-expression ?type ?x ?y) + ;; Long arithmetic + [["jvm-ladd" [?x ?y]]] + (&&host/compile-jvm-ladd compile-expression ?type ?x ?y) + + [["jvm-lsub" [?x ?y]]] + (&&host/compile-jvm-lsub compile-expression ?type ?x ?y) + + [["jvm-lmul" [?x ?y]]] + (&&host/compile-jvm-lmul compile-expression ?type ?x ?y) + + [["jvm-ldiv" [?x ?y]]] + (&&host/compile-jvm-ldiv compile-expression ?type ?x ?y) + + [["jvm-lrem" [?x ?y]]] + (&&host/compile-jvm-lrem compile-expression ?type ?x ?y) - [["jvm-leq" [?x ?y]]] - (&&host/compile-jvm-leq compile-expression ?type ?x ?y) + [["jvm-leq" [?x ?y]]] + (&&host/compile-jvm-leq compile-expression ?type ?x ?y) - [["jvm-llt" [?x ?y]]] - (&&host/compile-jvm-llt compile-expression ?type ?x ?y) + [["jvm-llt" [?x ?y]]] + (&&host/compile-jvm-llt compile-expression ?type ?x ?y) - [["jvm-lgt" [?x ?y]]] - (&&host/compile-jvm-lgt compile-expression ?type ?x ?y) + [["jvm-lgt" [?x ?y]]] + (&&host/compile-jvm-lgt compile-expression ?type ?x ?y) - ;; Float arithmetic - [["jvm-fadd" [?x ?y]]] - (&&host/compile-jvm-fadd compile-expression ?type ?x ?y) - - [["jvm-fsub" [?x ?y]]] - (&&host/compile-jvm-fsub compile-expression ?type ?x ?y) - - [["jvm-fmul" [?x ?y]]] - (&&host/compile-jvm-fmul compile-expression ?type ?x ?y) - - [["jvm-fdiv" [?x ?y]]] - (&&host/compile-jvm-fdiv compile-expression ?type ?x ?y) - - [["jvm-frem" [?x ?y]]] - (&&host/compile-jvm-frem compile-expression ?type ?x ?y) + ;; Float arithmetic + [["jvm-fadd" [?x ?y]]] + (&&host/compile-jvm-fadd compile-expression ?type ?x ?y) + + [["jvm-fsub" [?x ?y]]] + (&&host/compile-jvm-fsub compile-expression ?type ?x ?y) + + [["jvm-fmul" [?x ?y]]] + (&&host/compile-jvm-fmul compile-expression ?type ?x ?y) + + [["jvm-fdiv" [?x ?y]]] + (&&host/compile-jvm-fdiv compile-expression ?type ?x ?y) + + [["jvm-frem" [?x ?y]]] + (&&host/compile-jvm-frem compile-expression ?type ?x ?y) - [["jvm-feq" [?x ?y]]] - (&&host/compile-jvm-feq compile-expression ?type ?x ?y) + [["jvm-feq" [?x ?y]]] + (&&host/compile-jvm-feq compile-expression ?type ?x ?y) - [["jvm-flt" [?x ?y]]] - (&&host/compile-jvm-flt compile-expression ?type ?x ?y) + [["jvm-flt" [?x ?y]]] + (&&host/compile-jvm-flt compile-expression ?type ?x ?y) - [["jvm-fgt" [?x ?y]]] - (&&host/compile-jvm-fgt compile-expression ?type ?x ?y) + [["jvm-fgt" [?x ?y]]] + (&&host/compile-jvm-fgt compile-expression ?type ?x ?y) - ;; Double arithmetic - [["jvm-dadd" [?x ?y]]] - (&&host/compile-jvm-dadd compile-expression ?type ?x ?y) - - [["jvm-dsub" [?x ?y]]] - (&&host/compile-jvm-dsub compile-expression ?type ?x ?y) - - [["jvm-dmul" [?x ?y]]] - (&&host/compile-jvm-dmul compile-expression ?type ?x ?y) - - [["jvm-ddiv" [?x ?y]]] - (&&host/compile-jvm-ddiv compile-expression ?type ?x ?y) - - [["jvm-drem" [?x ?y]]] - (&&host/compile-jvm-drem compile-expression ?type ?x ?y) + ;; Double arithmetic + [["jvm-dadd" [?x ?y]]] + (&&host/compile-jvm-dadd compile-expression ?type ?x ?y) + + [["jvm-dsub" [?x ?y]]] + (&&host/compile-jvm-dsub compile-expression ?type ?x ?y) + + [["jvm-dmul" [?x ?y]]] + (&&host/compile-jvm-dmul compile-expression ?type ?x ?y) + + [["jvm-ddiv" [?x ?y]]] + (&&host/compile-jvm-ddiv compile-expression ?type ?x ?y) + + [["jvm-drem" [?x ?y]]] + (&&host/compile-jvm-drem compile-expression ?type ?x ?y) - [["jvm-deq" [?x ?y]]] - (&&host/compile-jvm-deq compile-expression ?type ?x ?y) + [["jvm-deq" [?x ?y]]] + (&&host/compile-jvm-deq compile-expression ?type ?x ?y) - [["jvm-dlt" [?x ?y]]] - (&&host/compile-jvm-dlt compile-expression ?type ?x ?y) + [["jvm-dlt" [?x ?y]]] + (&&host/compile-jvm-dlt compile-expression ?type ?x ?y) - [["jvm-dgt" [?x ?y]]] - (&&host/compile-jvm-dgt compile-expression ?type ?x ?y) - - [["jvm-null" _]] - (&&host/compile-jvm-null compile-expression ?type) + [["jvm-dgt" [?x ?y]]] + (&&host/compile-jvm-dgt compile-expression ?type ?x ?y) + + [["jvm-null" _]] + (&&host/compile-jvm-null compile-expression ?type) - [["jvm-null?" ?object]] - (&&host/compile-jvm-null? compile-expression ?type ?object) - - [["jvm-new" [?class ?classes ?args]]] - (&&host/compile-jvm-new compile-expression ?type ?class ?classes ?args) + [["jvm-null?" ?object]] + (&&host/compile-jvm-null? compile-expression ?type ?object) + + [["jvm-new" [?class ?classes ?args]]] + (&&host/compile-jvm-new compile-expression ?type ?class ?classes ?args) - [["jvm-getstatic" [?class ?field]]] - (&&host/compile-jvm-getstatic compile-expression ?type ?class ?field) + [["jvm-getstatic" [?class ?field]]] + (&&host/compile-jvm-getstatic compile-expression ?type ?class ?field) - [["jvm-getfield" [?class ?field ?object]]] - (&&host/compile-jvm-getfield compile-expression ?type ?class ?field ?object) + [["jvm-getfield" [?class ?field ?object]]] + (&&host/compile-jvm-getfield compile-expression ?type ?class ?field ?object) - [["jvm-putstatic" [?class ?field ?value]]] - (&&host/compile-jvm-putstatic compile-expression ?type ?class ?field ?value) + [["jvm-putstatic" [?class ?field ?value]]] + (&&host/compile-jvm-putstatic compile-expression ?type ?class ?field ?value) - [["jvm-putfield" [?class ?field ?object ?value]]] - (&&host/compile-jvm-putfield compile-expression ?type ?class ?field ?object ?value) + [["jvm-putfield" [?class ?field ?object ?value]]] + (&&host/compile-jvm-putfield compile-expression ?type ?class ?field ?object ?value) - [["jvm-invokestatic" [?class ?method ?classes ?args]]] - (&&host/compile-jvm-invokestatic compile-expression ?type ?class ?method ?classes ?args) + [["jvm-invokestatic" [?class ?method ?classes ?args]]] + (&&host/compile-jvm-invokestatic compile-expression ?type ?class ?method ?classes ?args) - [["jvm-invokevirtual" [?class ?method ?classes ?object ?args]]] - (&&host/compile-jvm-invokevirtual compile-expression ?type ?class ?method ?classes ?object ?args) + [["jvm-invokevirtual" [?class ?method ?classes ?object ?args]]] + (&&host/compile-jvm-invokevirtual compile-expression ?type ?class ?method ?classes ?object ?args) - [["jvm-invokeinterface" [?class ?method ?classes ?object ?args]]] - (&&host/compile-jvm-invokeinterface compile-expression ?type ?class ?method ?classes ?object ?args) + [["jvm-invokeinterface" [?class ?method ?classes ?object ?args]]] + (&&host/compile-jvm-invokeinterface compile-expression ?type ?class ?method ?classes ?object ?args) - [["jvm-invokespecial" [?class ?method ?classes ?object ?args]]] - (&&host/compile-jvm-invokespecial compile-expression ?type ?class ?method ?classes ?object ?args) - - [["jvm-new-array" [?class ?length]]] - (&&host/compile-jvm-new-array compile-expression ?type ?class ?length) + [["jvm-invokespecial" [?class ?method ?classes ?object ?args]]] + (&&host/compile-jvm-invokespecial compile-expression ?type ?class ?method ?classes ?object ?args) + + [["jvm-new-array" [?class ?length]]] + (&&host/compile-jvm-new-array compile-expression ?type ?class ?length) - [["jvm-aastore" [?array ?idx ?elem]]] - (&&host/compile-jvm-aastore compile-expression ?type ?array ?idx ?elem) + [["jvm-aastore" [?array ?idx ?elem]]] + (&&host/compile-jvm-aastore compile-expression ?type ?array ?idx ?elem) - [["jvm-aaload" [?array ?idx]]] - (&&host/compile-jvm-aaload compile-expression ?type ?array ?idx) + [["jvm-aaload" [?array ?idx]]] + (&&host/compile-jvm-aaload compile-expression ?type ?array ?idx) - [["jvm-try" [?body ?catches ?finally]]] - (&&host/compile-jvm-try compile-expression ?type ?body ?catches ?finally) + [["jvm-try" [?body ?catches ?finally]]] + (&&host/compile-jvm-try compile-expression ?type ?body ?catches ?finally) - [["jvm-throw" ?ex]] - (&&host/compile-jvm-throw compile-expression ?type ?ex) + [["jvm-throw" ?ex]] + (&&host/compile-jvm-throw compile-expression ?type ?ex) - [["jvm-monitorenter" ?monitor]] - (&&host/compile-jvm-monitorenter compile-expression ?type ?monitor) + [["jvm-monitorenter" ?monitor]] + (&&host/compile-jvm-monitorenter compile-expression ?type ?monitor) - [["jvm-monitorexit" ?monitor]] - (&&host/compile-jvm-monitorexit compile-expression ?type ?monitor) + [["jvm-monitorexit" ?monitor]] + (&&host/compile-jvm-monitorexit compile-expression ?type ?monitor) - [["jvm-d2f" ?value]] - (&&host/compile-jvm-d2f compile-expression ?type ?value) + [["jvm-d2f" ?value]] + (&&host/compile-jvm-d2f compile-expression ?type ?value) - [["jvm-d2i" ?value]] - (&&host/compile-jvm-d2i compile-expression ?type ?value) + [["jvm-d2i" ?value]] + (&&host/compile-jvm-d2i compile-expression ?type ?value) - [["jvm-d2l" ?value]] - (&&host/compile-jvm-d2l compile-expression ?type ?value) - - [["jvm-f2d" ?value]] - (&&host/compile-jvm-f2d compile-expression ?type ?value) + [["jvm-d2l" ?value]] + (&&host/compile-jvm-d2l compile-expression ?type ?value) + + [["jvm-f2d" ?value]] + (&&host/compile-jvm-f2d compile-expression ?type ?value) - [["jvm-f2i" ?value]] - (&&host/compile-jvm-f2i compile-expression ?type ?value) + [["jvm-f2i" ?value]] + (&&host/compile-jvm-f2i compile-expression ?type ?value) - [["jvm-f2l" ?value]] - (&&host/compile-jvm-f2l compile-expression ?type ?value) - - [["jvm-i2b" ?value]] - (&&host/compile-jvm-i2b compile-expression ?type ?value) + [["jvm-f2l" ?value]] + (&&host/compile-jvm-f2l compile-expression ?type ?value) + + [["jvm-i2b" ?value]] + (&&host/compile-jvm-i2b compile-expression ?type ?value) - [["jvm-i2c" ?value]] - (&&host/compile-jvm-i2c compile-expression ?type ?value) + [["jvm-i2c" ?value]] + (&&host/compile-jvm-i2c compile-expression ?type ?value) - [["jvm-i2d" ?value]] - (&&host/compile-jvm-i2d compile-expression ?type ?value) + [["jvm-i2d" ?value]] + (&&host/compile-jvm-i2d compile-expression ?type ?value) - [["jvm-i2f" ?value]] - (&&host/compile-jvm-i2f compile-expression ?type ?value) + [["jvm-i2f" ?value]] + (&&host/compile-jvm-i2f compile-expression ?type ?value) - [["jvm-i2l" ?value]] - (&&host/compile-jvm-i2l compile-expression ?type ?value) + [["jvm-i2l" ?value]] + (&&host/compile-jvm-i2l compile-expression ?type ?value) - [["jvm-i2s" ?value]] - (&&host/compile-jvm-i2s compile-expression ?type ?value) + [["jvm-i2s" ?value]] + (&&host/compile-jvm-i2s compile-expression ?type ?value) - [["jvm-l2d" ?value]] - (&&host/compile-jvm-l2d compile-expression ?type ?value) + [["jvm-l2d" ?value]] + (&&host/compile-jvm-l2d compile-expression ?type ?value) - [["jvm-l2f" ?value]] - (&&host/compile-jvm-l2f compile-expression ?type ?value) + [["jvm-l2f" ?value]] + (&&host/compile-jvm-l2f compile-expression ?type ?value) - [["jvm-l2i" ?value]] - (&&host/compile-jvm-l2i compile-expression ?type ?value) + [["jvm-l2i" ?value]] + (&&host/compile-jvm-l2i compile-expression ?type ?value) - [["jvm-iand" [?x ?y]]] - (&&host/compile-jvm-iand compile-expression ?type ?x ?y) + [["jvm-iand" [?x ?y]]] + (&&host/compile-jvm-iand compile-expression ?type ?x ?y) - [["jvm-ior" [?x ?y]]] - (&&host/compile-jvm-ior compile-expression ?type ?x ?y) + [["jvm-ior" [?x ?y]]] + (&&host/compile-jvm-ior compile-expression ?type ?x ?y) - [["jvm-land" [?x ?y]]] - (&&host/compile-jvm-land compile-expression ?type ?x ?y) + [["jvm-land" [?x ?y]]] + (&&host/compile-jvm-land compile-expression ?type ?x ?y) - [["jvm-lor" [?x ?y]]] - (&&host/compile-jvm-lor compile-expression ?type ?x ?y) + [["jvm-lor" [?x ?y]]] + (&&host/compile-jvm-lor compile-expression ?type ?x ?y) - [["jvm-lxor" [?x ?y]]] - (&&host/compile-jvm-lxor compile-expression ?type ?x ?y) + [["jvm-lxor" [?x ?y]]] + (&&host/compile-jvm-lxor compile-expression ?type ?x ?y) - [["jvm-lshl" [?x ?y]]] - (&&host/compile-jvm-lshl compile-expression ?type ?x ?y) + [["jvm-lshl" [?x ?y]]] + (&&host/compile-jvm-lshl compile-expression ?type ?x ?y) - [["jvm-lshr" [?x ?y]]] - (&&host/compile-jvm-lshr compile-expression ?type ?x ?y) + [["jvm-lshr" [?x ?y]]] + (&&host/compile-jvm-lshr compile-expression ?type ?x ?y) - [["jvm-lushr" [?x ?y]]] - (&&host/compile-jvm-lushr compile-expression ?type ?x ?y) - )) + [["jvm-lushr" [?x ?y]]] + (&&host/compile-jvm-lushr compile-expression ?type ?x ?y) + + [["jvm-instanceof" [?class ?object]]] + (&&host/compile-jvm-instanceof compile-expression ?type ?class ?object) + ) )) (defn ^:private compile-statement [syntax] - ;; (prn 'compile-statement syntax) (matchv ::M/objects [syntax] [["def" [?name ?body ?def-data]]] (&&lux/compile-def compile-expression ?name ?body ?def-data) @@ -313,24 +334,25 @@ [["jvm-program" ?body]] (&&host/compile-jvm-program compile-expression ?body) - [["jvm-interface" [?package ?name ?methods]]] - (&&host/compile-jvm-interface compile-expression ?package ?name ?methods) + [["jvm-interface" [?name ?supers ?methods]]] + (&&host/compile-jvm-interface compile-expression ?name ?supers ?methods) - [["jvm-class" [?package ?name ?super-class ?fields ?methods]]] - (&&host/compile-jvm-class compile-expression ?package ?name ?super-class ?fields ?methods))) + [["jvm-class" [?name ?super-class ?interfaces ?fields ?methods]]] + (&&host/compile-jvm-class compile-expression ?name ?super-class ?interfaces ?fields ?methods))) (defn ^:private eval! [expr] - ;; (prn 'eval! (aget expr 0)) - ;; (assert false) - (|do [eval-ctor &/get-eval-ctor - :let [class-name (str eval-ctor) - =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) - (.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER) - class-name nil "java/lang/Object" nil) - (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) "_eval" "Ljava/lang/Object;" nil nil) - (doto (.visitEnd))))] - _ (&/with-writer (.visitMethod =class Opcodes/ACC_PUBLIC "<clinit>" "()V" nil nil) - (|do [^MethodVisitor *writer* &/get-writer + (&/with-eval + (|do [module &/get-module-name + id &/gen-id + :let [class-name (str (&host/->module-class module) "/" id) + ;; _ (prn 'eval! id class-name) + =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) + (.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER) + class-name nil "java/lang/Object" nil) + (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) "_eval" "Ljava/lang/Object;" nil nil) + (doto (.visitEnd))))] + _ (&/with-writer (.visitMethod =class Opcodes/ACC_PUBLIC "<clinit>" "()V" nil nil) + (|do [^MethodVisitor *writer* &/get-writer :let [_ (.visitCode *writer*)] _ (compile-expression expr) :let [_ (doto *writer* @@ -338,62 +360,78 @@ (.visitInsn Opcodes/RETURN) (.visitMaxs 0 0) (.visitEnd))]] - (return nil))) - :let [bytecode (.toByteArray (doto =class - .visitEnd))] - _ (&&/save-class! class-name bytecode) - loader &/loader] - (-> (.loadClass ^ClassLoader loader class-name) - (.getField "_eval") - (.get nil) - return))) + (return nil))) + :let [bytecode (.toByteArray (doto =class + .visitEnd))] + _ (&&/save-class! (str id) bytecode) + loader &/loader] + (-> (.loadClass ^ClassLoader loader (str (&host/->module-class module) "." id)) + (.getField "_eval") + (.get nil) + return)))) + +(defn ^:private compile-module [name] + ;; (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 (&&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)] + (if module-exists? + (fail "[Compiler Error] Can't redefine a module!") + (|do [_ (&a-module/enter-module name) + :let [=class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) + (.visit Opcodes/V1_6 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER) + (str (&host/->module-class name) "/_") nil "java/lang/Object" nil) + (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) "_hash" "I" nil file-hash) + .visitEnd) + (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) "_compiler" "Ljava/lang/String;" nil &&/version) + .visitEnd)) + ;; _ (prn 'compile-module name =class) + ]] + (fn [state] + (matchv ::M/objects [((&/with-writer =class + (&/exhaust% compiler-step)) + (&/set$ &/$SOURCE (&reader/from file-name file-content) state))] + [["lux;Right" [?state _]]] + (&/run-state (|do [defs &a-module/defs + imports &a-module/imports + :let [_ (doto =class + (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) "_defs" "Ljava/lang/String;" nil + (->> defs + (&/|map (fn [_def] + (|let [[?exported ?name ?ann] _def] + (str (if ?exported "1" "0") " " ?name " " ?ann)))) + (&/|interpose "\t") + (&/fold str ""))) + .visitEnd) + (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) "_imports" "Ljava/lang/String;" nil + (->> imports (&/|interpose "\t") (&/fold str ""))) + .visitEnd) + (.visitEnd)) + ;; _ (prn 'CLOSED name =class) + ]] + (&&/save-class! "_" (.toByteArray =class))) + ?state) + + [["lux;Left" ?message]] + (fail* ?message))))))) + ))) -(let [compiler-step (|do [analysis+ (&optimizer/optimize eval!) - ;; :let [_ (prn 'analysis+ analysis+)] - ] - (&/map% compile-statement analysis+) - ;; (if (&/|empty? analysis+) - ;; (fail "[Compiler Error] No more to compile.") - ;; (&/map% compile-statement analysis+)) - )] - (defn ^:private compile-module [name] - (fn [state] - (prn 'compile-module name (->> state (&/get$ &/$MODULES) &/|keys &/->seq)) - (if (->> state (&/get$ &/$MODULES) (&/|contains? name)) - (if (= name "lux") - (return* state nil) - (fail* "[Compiler Error] Can't redefine a module!")) - (let [=class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) - (.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER) - (&host/->class name) nil "java/lang/Object" nil))] - (matchv ::M/objects [(&/run-state (&/exhaust% compiler-step) (->> state - (&/set$ &/$SOURCE (&/V "lux;Some" (&reader/from (str "source/" name ".lux")))) - (&/set$ &/$ENVS (&/|list (&/env name))) - (&/update$ &/$HOST #(&/set$ &/$WRITER (&/V "lux;Some" =class) %)) - (&/update$ &/$MODULES #(&/|put name &a-module/init-module %))))] - [["lux;Right" [?state _]]] - (do (.visitEnd =class) - ;; (prn 'compile-module 'DONE name) - ;; (prn 'compile-module/?vals ?vals) - (&/run-state (&&/save-class! name (.toByteArray =class)) ?state)) - - [["lux;Left" ?message]] - (fail* ?message))))))) +(defn ^:private init! [] + (.mkdirs (java.io.File. &&/output-dir))) ;; [Resources] -(defn compile-all [modules] - (.mkdir (java.io.File. "output")) - (matchv ::M/objects [(&/run-state (&/map% compile-module (&/|cons "lux" modules)) (&/init-state nil))] +(defn compile-program [program-module] + (init!) + (matchv ::M/objects [((&/map% compile-module (&/|list "lux" program-module)) (&/init-state nil))] [["lux;Right" [?state _]]] - (println (str "Compilation complete! " (str "[" (->> modules - (&/|interpose " ") - (&/fold str "")) - "]"))) + (do (println "Compilation complete!") + (&&cache/clean ?state) + (&&package/package program-module)) [["lux;Left" ?message]] - (do (prn 'compile-all '?message ?message) - (assert false ?message)))) - -(comment - (compile-all ["lux"]) - ) + (assert false ?message))) diff --git a/src/lux/compiler/base.clj b/src/lux/compiler/base.clj index dd7e0ae13..28339c162 100644 --- a/src/lux/compiler/base.clj +++ b/src/lux/compiler/base.clj @@ -1,135 +1,91 @@ +;; 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.base - (:require [clojure.string :as string] + (:require (clojure [template :refer [do-template]] + [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*]]) - [lux.analyser.base :as &a]) + (lux [base :as & :refer [|do return* return fail fail*]] + [type :as &type] + [host :as &host]) + (lux.analyser [base :as &a] + [module :as &a-module])) (:import (org.objectweb.asm Opcodes Label ClassWriter - MethodVisitor))) + MethodVisitor) + (java.io File + BufferedOutputStream + FileOutputStream) + (java.lang.reflect Field))) -;; [Exports] -(def local-prefix "l") -(def partial-prefix "p") -(def closure-prefix "c") -(def apply-signature "(Ljava/lang/Object;)Ljava/lang/Object;") +;; [Constants] +(def ^String version "0.2") +(def ^String input-dir "source") +(def ^String output-dir "target/jvm") +(def ^String output-package (str output-dir "/program.jar")) +(def ^String function-class "lux/Function") + +(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;") -(defn write-file [^String file ^bytes data] - (with-open [stream (java.io.BufferedOutputStream. (java.io.FileOutputStream. file))] +;; [Utils] +(defn ^:private write-file [^String file ^bytes data] + (with-open [stream (BufferedOutputStream. (FileOutputStream. file))] (.write stream data))) -(defn write-class [name data] - (write-file (str "output/" name ".class") data)) +(defn ^:private write-output [module name data] + (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] (defn load-class! [^ClassLoader loader name] + ;; (prn 'load-class! name) (.loadClass loader name)) (defn save-class! [name bytecode] - (|do [loader &/loader - :let [_ (write-class name bytecode) - _ (load-class! loader (string/replace name #"/" "."))]] + (|do [eval? &/get-eval + module &/get-module-name + loader &/loader + !classes &/classes + :let [real-name (str (&host/->module-class module) "." name) + _ (swap! !classes assoc real-name bytecode) + _ (when (not eval?) + (write-output module name bytecode)) + _ (load-class! loader real-name)]] (return nil))) -(defn total-locals [expr] - ;; (prn 'total-locals1 (aget expr 0)) - (matchv ::M/objects [expr] - [[?struct ?type]] - (do ;; (prn 'total-locals2 (aget ?struct 0)) - (matchv ::M/objects [?struct] - [["case" [?variant ?base-register ?num-registers ?branches]]] - (+ ?num-registers (&/fold max 0 (&/|map (comp total-locals second) ?branches))) - - [["tuple" ?members]] - (&/fold max 0 (&/|map total-locals ?members)) - - [["variant" [?tag ?value]]] - (total-locals ?value) - - [["call" [?fn ?args]]] - (&/fold max 0 (&/|map total-locals (&/|cons ?fn ?args))) - - [["jvm-iadd" [?x ?y]]] - (&/fold max 0 (&/|map total-locals (&/|list ?x ?y))) - - [["jvm-isub" [?x ?y]]] - (&/fold max 0 (&/|map total-locals (&/|list ?x ?y))) - - [["jvm-imul" [?x ?y]]] - (&/fold max 0 (&/|map total-locals (&/|list ?x ?y))) - - [["jvm-idiv" [?x ?y]]] - (&/fold max 0 (&/|map total-locals (&/|list ?x ?y))) - - [["jvm-irem" [?x ?y]]] - (&/fold max 0 (&/|map total-locals (&/|list ?x ?y))) - - [["jvm-ladd" [?x ?y]]] - (&/fold max 0 (&/|map total-locals (&/|list ?x ?y))) - - [["jvm-lsub" [?x ?y]]] - (&/fold max 0 (&/|map total-locals (&/|list ?x ?y))) - - [["jvm-lmul" [?x ?y]]] - (&/fold max 0 (&/|map total-locals (&/|list ?x ?y))) - - [["jvm-ldiv" [?x ?y]]] - (&/fold max 0 (&/|map total-locals (&/|list ?x ?y))) - - [["jvm-lrem" [?x ?y]]] - (&/fold max 0 (&/|map total-locals (&/|list ?x ?y))) - - [["jvm-fadd" [?x ?y]]] - (&/fold max 0 (&/|map total-locals (&/|list ?x ?y))) - - [["jvm-fsub" [?x ?y]]] - (&/fold max 0 (&/|map total-locals (&/|list ?x ?y))) - - [["jvm-fmul" [?x ?y]]] - (&/fold max 0 (&/|map total-locals (&/|list ?x ?y))) - - [["jvm-fdiv" [?x ?y]]] - (&/fold max 0 (&/|map total-locals (&/|list ?x ?y))) - - [["jvm-frem" [?x ?y]]] - (&/fold max 0 (&/|map total-locals (&/|list ?x ?y))) - - [["jvm-dadd" [?x ?y]]] - (&/fold max 0 (&/|map total-locals (&/|list ?x ?y))) - - [["jvm-dsub" [?x ?y]]] - (&/fold max 0 (&/|map total-locals (&/|list ?x ?y))) - - [["jvm-dmul" [?x ?y]]] - (&/fold max 0 (&/|map total-locals (&/|list ?x ?y))) - - [["jvm-ddiv" [?x ?y]]] - (&/fold max 0 (&/|map total-locals (&/|list ?x ?y))) - - [["jvm-drem" [?x ?y]]] - (&/fold max 0 (&/|map total-locals (&/|list ?x ?y))) - - [["|do" ?exprs]] - (&/fold max 0 (&/|map total-locals ?exprs)) - - [["jvm-new" [?class ?classes ?args]]] - (&/fold max 0 (&/|map total-locals ?args)) - - [["jvm-invokestatic" [?class ?method ?classes ?args]]] - (&/fold max 0 (&/|map total-locals ?args)) - - [["jvm-invokevirtual" [?class ?method ?classes ?object ?args]]] - (&/fold max 0 (&/|map total-locals ?args)) - - [["jvm-aastore" [?array ?idx ?elem]]] - (&/fold max 0 (&/|map total-locals (&/|list ?array ?elem))) - - [["jvm-aaload" [?array ?idx]]] - (total-locals ?array) +(do-template [<name> <class> <sig> <dup>] + (defn <name> [^MethodVisitor writer] + (doto writer + (.visitMethodInsn Opcodes/INVOKESTATIC <class> "valueOf" (str <sig> (&host/->type-signature <class>)))) + ;; (doto writer + ;; ;; X + ;; (.visitTypeInsn Opcodes/NEW <class>) ;; XW + ;; (.visitInsn <dup>) ;; WXW + ;; (.visitInsn <dup>) ;; WWXW + ;; (.visitInsn Opcodes/POP) ;; WWX + ;; (.visitMethodInsn Opcodes/INVOKESPECIAL <class> "<init>" <sig>) ;; W + ;; ) + ) - ;; [["lambda" _]] - ;; 0 - - [_] - 0 - )))) + wrap-boolean "java/lang/Boolean" "(Z)" Opcodes/DUP_X1 + wrap-byte "java/lang/Byte" "(B)" Opcodes/DUP_X1 + wrap-short "java/lang/Short" "(S)" Opcodes/DUP_X1 + wrap-int "java/lang/Integer" "(I)" Opcodes/DUP_X1 + wrap-long "java/lang/Long" "(J)" Opcodes/DUP_X2 + wrap-float "java/lang/Float" "(F)" Opcodes/DUP_X1 + wrap-double "java/lang/Double" "(D)" Opcodes/DUP_X2 + wrap-char "java/lang/Character" "(C)" Opcodes/DUP_X1 + ) diff --git a/src/lux/compiler/cache.clj b/src/lux/compiler/cache.clj new file mode 100644 index 000000000..c0d978146 --- /dev/null +++ b/src/lux/compiler/cache.clj @@ -0,0 +1,138 @@ +;; 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? #(-> ^File % .getName (string/replace &host/module-separator "/") (->> (contains? needed-modules)) not) + outdate-files (->> &&/output-dir (new File) .listFiles seq (filter outdated?)) + program-file (new File &&/output-package)] + (when (.exists program-file) + (.delete program-file)) + (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))))) diff --git a/src/lux/compiler/case.clj b/src/lux/compiler/case.clj index 738d6bc35..fc0cce31f 100644 --- a/src/lux/compiler/case.clj +++ b/src/lux/compiler/case.clj @@ -1,3 +1,11 @@ +;; 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.case (:require (clojure [set :as set] [template :refer [do-template]]) @@ -16,12 +24,8 @@ MethodVisitor))) ;; [Utils] -(let [+tag-sig+ (&host/->type-signature "java.lang.String") - +oclass+ (&host/->class "java.lang.Object") - +equals-sig+ (str "(" (&host/->type-signature "java.lang.Object") ")Z") - compare-kv #(.compareTo ^String (aget ^objects %1 0) ^String (aget ^objects %2 0))] +(let [compare-kv #(.compareTo ^String (aget ^objects %1 0) ^String (aget ^objects %2 0))] (defn ^:private compile-match [^MethodVisitor writer ?match $target $else] - ;; (prn 'compile-match (aget ?match 0) $target $else) (matchv ::M/objects [?match] [["StoreTestAC" ?idx]] (doto writer @@ -30,9 +34,9 @@ [["BoolTestAC" ?value]] (doto writer - (.visitTypeInsn Opcodes/CHECKCAST (&host/->class "java.lang.Boolean")) + (.visitTypeInsn Opcodes/CHECKCAST "java/lang/Boolean") (.visitInsn Opcodes/DUP) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL (&host/->class "java.lang.Boolean") "booleanValue" "()Z") + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/Boolean" "booleanValue" "()Z") (.visitLdcInsn ?value) (.visitJumpInsn Opcodes/IF_ICMPNE $else) (.visitInsn Opcodes/POP) @@ -40,9 +44,9 @@ [["IntTestAC" ?value]] (doto writer - (.visitTypeInsn Opcodes/CHECKCAST (&host/->class "java.lang.Long")) + (.visitTypeInsn Opcodes/CHECKCAST "java/lang/Long") (.visitInsn Opcodes/DUP) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL (&host/->class "java.lang.Long") "longValue" "()J") + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/Long" "longValue" "()J") (.visitLdcInsn ?value) (.visitInsn Opcodes/LCMP) (.visitJumpInsn Opcodes/IFNE $else) @@ -51,9 +55,9 @@ [["RealTestAC" ?value]] (doto writer - (.visitTypeInsn Opcodes/CHECKCAST (&host/->class "java.lang.Double")) + (.visitTypeInsn Opcodes/CHECKCAST "java/lang/Double") (.visitInsn Opcodes/DUP) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL (&host/->class "java.lang.Double") "doubleValue" "()D") + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/Double" "doubleValue" "()D") (.visitLdcInsn ?value) (.visitInsn Opcodes/DCMPL) (.visitJumpInsn Opcodes/IFNE $else) @@ -62,9 +66,9 @@ [["CharTestAC" ?value]] (doto writer - (.visitTypeInsn Opcodes/CHECKCAST (&host/->class "java.lang.Character")) + (.visitTypeInsn Opcodes/CHECKCAST "java/lang/Character") (.visitInsn Opcodes/DUP) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL (&host/->class "java.lang.Character") "charValue" "()C") + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/Character" "charValue" "()C") (.visitLdcInsn ?value) (.visitJumpInsn Opcodes/IF_ICMPNE $else) (.visitInsn Opcodes/POP) @@ -74,7 +78,7 @@ (doto writer (.visitInsn Opcodes/DUP) (.visitLdcInsn ?value) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL (&host/->class "java.lang.Object") "equals" (str "(" (&host/->type-signature "java.lang.Object") ")Z")) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/Object" "equals" "(Ljava/lang/Object;)Z") (.visitJumpInsn Opcodes/IFEQ $else) (.visitInsn Opcodes/POP) (.visitJumpInsn Opcodes/GOTO $target)) @@ -93,7 +97,7 @@ (->> (|let [[idx test] idx+member $next (new Label) $sub-else (new Label)]) - (doseq [idx+member (&/->seq (&/zip2 (&/|range (&/|length ?members)) ?members))]))) + (doseq [idx+member (->> ?members &/enumerate &/->seq)]))) (.visitInsn Opcodes/POP) (.visitJumpInsn Opcodes/GOTO $target)) @@ -111,11 +115,12 @@ (->> (|let [[idx [_ test]] idx+member $next (new Label) $sub-else (new Label)]) - (doseq [idx+member (&/->seq (&/zip2 (&/|range (&/|length ?slots)) - (->> ?slots - &/->seq - (sort compare-kv) - &/->list)))]))) + (doseq [idx+member (->> ?slots + &/->seq + (sort compare-kv) + &/->list + &/enumerate + &/->seq)]))) (.visitInsn Opcodes/POP) (.visitJumpInsn Opcodes/GOTO $target)) @@ -126,7 +131,7 @@ (.visitLdcInsn (int 0)) (.visitInsn Opcodes/AALOAD) (.visitLdcInsn ?tag) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL +oclass+ "equals" +equals-sig+) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/Object" "equals" "(Ljava/lang/Object;)Z") (.visitJumpInsn Opcodes/IFEQ $else) (.visitInsn Opcodes/DUP) (.visitLdcInsn (int 1)) @@ -143,7 +148,6 @@ ))) (defn ^:private separate-bodies [patterns] - ;; (prn 'separate-bodies (aget matches 0)) (|let [[_ mappings patterns*] (&/fold (fn [$id+mappings+=matches pattern+body] (|let [[$id mappings =matches] $id+mappings+=matches [pattern body] pattern+body] @@ -152,42 +156,36 @@ patterns)] (&/T mappings (&/|reverse patterns*)))) -(let [ex-class (&host/->class "java.lang.IllegalStateException")] - (defn ^:private compile-pattern-matching [^MethodVisitor writer compile mappings patterns $end] - ;; (prn 'compile-pattern-matching ?matches $end) - (let [entries (&/|map (fn [?branch+?body] - (|let [[?branch ?body] ?branch+?body - label (new Label)] - (&/T (&/T ?branch label) - (&/T label ?body)))) - mappings) - mappings* (&/|map &/|first entries)] - (doto writer - (-> (doto (compile-match ?match (&/|get ?body mappings*) $else) - (.visitLabel $else)) - (->> (|let [[?body ?match] ?body+?match]) - (doseq [?body+?match (&/->seq patterns) - :let [;; _ (prn 'compile-pattern-matching/pattern pattern) - ;; _ (prn '?body+?match (alength ?body+?match) (aget ?body+?match 0)) - ;; _ (prn '?body+?match (aget ?body+?match 0)) - $else (new Label)]]))) - (.visitInsn Opcodes/POP) - (.visitTypeInsn Opcodes/NEW ex-class) - (.visitInsn Opcodes/DUP) - (.visitMethodInsn Opcodes/INVOKESPECIAL ex-class "<init>" "()V") - (.visitInsn Opcodes/ATHROW)) - (&/map% (fn [?label+?body] - (|let [[?label ?body] ?label+?body] - (|do [:let [_ (.visitLabel writer ?label)] - ret (compile ?body) - :let [_ (.visitJumpInsn writer Opcodes/GOTO $end)]] - (return ret)))) - (&/|map &/|second entries)) - ))) +(defn ^:private compile-pattern-matching [^MethodVisitor writer compile mappings patterns $end] + (let [entries (&/|map (fn [?branch+?body] + (|let [[?branch ?body] ?branch+?body + label (new Label)] + (&/T (&/T ?branch label) + (&/T label ?body)))) + mappings) + mappings* (&/|map &/|first entries)] + (doto writer + (-> (doto (compile-match ?match (&/|get ?body mappings*) $else) + (.visitLabel $else)) + (->> (|let [[?body ?match] ?body+?match]) + (doseq [?body+?match (&/->seq patterns) + :let [$else (new Label)]]))) + (.visitInsn Opcodes/POP) + (.visitTypeInsn Opcodes/NEW "java/lang/IllegalStateException") + (.visitInsn Opcodes/DUP) + (.visitMethodInsn Opcodes/INVOKESPECIAL "java/lang/IllegalStateException" "<init>" "()V") + (.visitInsn Opcodes/ATHROW)) + (&/map% (fn [?label+?body] + (|let [[?label ?body] ?label+?body] + (|do [:let [_ (.visitLabel writer ?label)] + ret (compile ?body) + :let [_ (.visitJumpInsn writer Opcodes/GOTO $end)]] + (return ret)))) + (&/|map &/|second entries)) + )) ;; [Resources] (defn compile-case [compile *type* ?value ?matches] - ;; (prn 'compile-case ?value ?matches) (|do [^MethodVisitor *writer* &/get-writer :let [$end (new Label)] _ (compile ?value) diff --git a/src/lux/compiler/host.clj b/src/lux/compiler/host.clj index 71d3ced53..346b66fd2 100644 --- a/src/lux/compiler/host.clj +++ b/src/lux/compiler/host.clj @@ -1,3 +1,11 @@ +;; 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.host (:require (clojure [string :as string] [set :as set] @@ -44,7 +52,7 @@ char-class "java.lang.Character"] (defn prepare-return! [^MethodVisitor *writer* *type*] (matchv ::M/objects [*type*] - [["lux;VariantT" ["lux;Nil" _]]] + [["lux;TupleT" ["lux;Nil" _]]] (.visitInsn *writer* Opcodes/ACONST_NULL) [["lux;DataT" "boolean"]] @@ -76,7 +84,7 @@ *writer*)) ;; [Resources] -(do-template [<name> <opcode> <wrapper-class> <value-method> <value-method-sig> <wrapper-method> <wrapper-method-sig>] +(do-template [<name> <opcode> <wrapper-class> <value-method> <value-method-sig> <wrap>] (defn <name> [compile *type* ?x ?y] (|do [:let [+wrapper-class+ (&host/->class <wrapper-class>)] ^MethodVisitor *writer* &/get-writer @@ -90,32 +98,32 @@ (.visitMethodInsn Opcodes/INVOKEVIRTUAL +wrapper-class+ <value-method> <value-method-sig>)) _ (doto *writer* (.visitInsn <opcode>) - (.visitMethodInsn Opcodes/INVOKESTATIC +wrapper-class+ <wrapper-method> (str <wrapper-method-sig> (&host/->type-signature <wrapper-class>))))]] + (<wrap>))]] (return nil))) - compile-jvm-iadd Opcodes/IADD "java.lang.Integer" "intValue" "()I" "valueOf" "(I)" - compile-jvm-isub Opcodes/ISUB "java.lang.Integer" "intValue" "()I" "valueOf" "(I)" - compile-jvm-imul Opcodes/IMUL "java.lang.Integer" "intValue" "()I" "valueOf" "(I)" - compile-jvm-idiv Opcodes/IDIV "java.lang.Integer" "intValue" "()I" "valueOf" "(I)" - compile-jvm-irem Opcodes/IREM "java.lang.Integer" "intValue" "()I" "valueOf" "(I)" + compile-jvm-iadd Opcodes/IADD "java.lang.Integer" "intValue" "()I" &&/wrap-int + compile-jvm-isub Opcodes/ISUB "java.lang.Integer" "intValue" "()I" &&/wrap-int + compile-jvm-imul Opcodes/IMUL "java.lang.Integer" "intValue" "()I" &&/wrap-int + compile-jvm-idiv Opcodes/IDIV "java.lang.Integer" "intValue" "()I" &&/wrap-int + compile-jvm-irem Opcodes/IREM "java.lang.Integer" "intValue" "()I" &&/wrap-int - compile-jvm-ladd Opcodes/LADD "java.lang.Long" "longValue" "()J" "valueOf" "(J)" - compile-jvm-lsub Opcodes/LSUB "java.lang.Long" "longValue" "()J" "valueOf" "(J)" - compile-jvm-lmul Opcodes/LMUL "java.lang.Long" "longValue" "()J" "valueOf" "(J)" - compile-jvm-ldiv Opcodes/LDIV "java.lang.Long" "longValue" "()J" "valueOf" "(J)" - compile-jvm-lrem Opcodes/LREM "java.lang.Long" "longValue" "()J" "valueOf" "(J)" + compile-jvm-ladd Opcodes/LADD "java.lang.Long" "longValue" "()J" &&/wrap-long + compile-jvm-lsub Opcodes/LSUB "java.lang.Long" "longValue" "()J" &&/wrap-long + compile-jvm-lmul Opcodes/LMUL "java.lang.Long" "longValue" "()J" &&/wrap-long + compile-jvm-ldiv Opcodes/LDIV "java.lang.Long" "longValue" "()J" &&/wrap-long + compile-jvm-lrem Opcodes/LREM "java.lang.Long" "longValue" "()J" &&/wrap-long - compile-jvm-fadd Opcodes/FADD "java.lang.Float" "floatValue" "()F" "valueOf" "(F)" - compile-jvm-fsub Opcodes/FSUB "java.lang.Float" "floatValue" "()F" "valueOf" "(F)" - compile-jvm-fmul Opcodes/FMUL "java.lang.Float" "floatValue" "()F" "valueOf" "(F)" - compile-jvm-fdiv Opcodes/FDIV "java.lang.Float" "floatValue" "()F" "valueOf" "(F)" - compile-jvm-frem Opcodes/FREM "java.lang.Float" "floatValue" "()F" "valueOf" "(F)" + compile-jvm-fadd Opcodes/FADD "java.lang.Float" "floatValue" "()F" &&/wrap-float + compile-jvm-fsub Opcodes/FSUB "java.lang.Float" "floatValue" "()F" &&/wrap-float + compile-jvm-fmul Opcodes/FMUL "java.lang.Float" "floatValue" "()F" &&/wrap-float + compile-jvm-fdiv Opcodes/FDIV "java.lang.Float" "floatValue" "()F" &&/wrap-float + compile-jvm-frem Opcodes/FREM "java.lang.Float" "floatValue" "()F" &&/wrap-float - compile-jvm-dadd Opcodes/DADD "java.lang.Double" "doubleValue" "()D" "valueOf" "(D)" - compile-jvm-dsub Opcodes/DSUB "java.lang.Double" "doubleValue" "()D" "valueOf" "(D)" - compile-jvm-dmul Opcodes/DMUL "java.lang.Double" "doubleValue" "()D" "valueOf" "(D)" - compile-jvm-ddiv Opcodes/DDIV "java.lang.Double" "doubleValue" "()D" "valueOf" "(D)" - compile-jvm-drem Opcodes/DREM "java.lang.Double" "doubleValue" "()D" "valueOf" "(D)" + compile-jvm-dadd Opcodes/DADD "java.lang.Double" "doubleValue" "()D" &&/wrap-double + compile-jvm-dsub Opcodes/DSUB "java.lang.Double" "doubleValue" "()D" &&/wrap-double + compile-jvm-dmul Opcodes/DMUL "java.lang.Double" "doubleValue" "()D" &&/wrap-double + compile-jvm-ddiv Opcodes/DDIV "java.lang.Double" "doubleValue" "()D" &&/wrap-double + compile-jvm-drem Opcodes/DREM "java.lang.Double" "doubleValue" "()D" &&/wrap-double ) (do-template [<name> <opcode> <wrapper-class> <value-method> <value-method-sig>] @@ -144,9 +152,13 @@ compile-jvm-ieq Opcodes/IF_ICMPEQ "java.lang.Integer" "intValue" "()I" compile-jvm-ilt Opcodes/IF_ICMPLT "java.lang.Integer" "intValue" "()I" compile-jvm-igt Opcodes/IF_ICMPGT "java.lang.Integer" "intValue" "()I" + + compile-jvm-ceq Opcodes/IF_ICMPEQ "java.lang.Character" "charValue" "()C" + compile-jvm-clt Opcodes/IF_ICMPLT "java.lang.Character" "charValue" "()C" + compile-jvm-cgt Opcodes/IF_ICMPGT "java.lang.Character" "charValue" "()C" ) -(do-template [<name> <cmpcode> <ifcode> <wrapper-class> <value-method> <value-method-sig>] +(do-template [<name> <cmpcode> <cmp-output> <wrapper-class> <value-method> <value-method-sig>] (defn <name> [compile *type* ?x ?y] (|do [:let [+wrapper-class+ (&host/->class <wrapper-class>)] ^MethodVisitor *writer* &/get-writer @@ -162,63 +174,81 @@ $end (new Label) _ (doto *writer* (.visitInsn <cmpcode>) - (.visitJumpInsn <ifcode> $then) - (.visitFieldInsn Opcodes/GETSTATIC (&host/->class "java.lang.Boolean") "TRUE" (&host/->type-signature "java.lang.Boolean")) + (.visitLdcInsn (int <cmp-output>)) + (.visitJumpInsn Opcodes/IF_ICMPEQ $then) + (.visitFieldInsn Opcodes/GETSTATIC (&host/->class "java.lang.Boolean") "FALSE" (&host/->type-signature "java.lang.Boolean")) (.visitJumpInsn Opcodes/GOTO $end) (.visitLabel $then) - (.visitFieldInsn Opcodes/GETSTATIC (&host/->class "java.lang.Boolean") "FALSE" (&host/->type-signature "java.lang.Boolean")) + (.visitFieldInsn Opcodes/GETSTATIC (&host/->class "java.lang.Boolean") "TRUE" (&host/->type-signature "java.lang.Boolean")) (.visitLabel $end))]] (return nil))) - compile-jvm-leq Opcodes/LCMP Opcodes/IFEQ "java.lang.Long" "longValue" "()J" - compile-jvm-llt Opcodes/LCMP Opcodes/IFLT "java.lang.Long" "longValue" "()J" - compile-jvm-lgt Opcodes/LCMP Opcodes/IFGT "java.lang.Long" "longValue" "()J" + compile-jvm-leq Opcodes/LCMP 0 "java.lang.Long" "longValue" "()J" + compile-jvm-llt Opcodes/LCMP 1 "java.lang.Long" "longValue" "()J" + compile-jvm-lgt Opcodes/LCMP -1 "java.lang.Long" "longValue" "()J" - compile-jvm-feq Opcodes/FCMPG Opcodes/IFEQ "java.lang.Float" "floatValue" "()F" - compile-jvm-flt Opcodes/FCMPG Opcodes/IFLT "java.lang.Float" "floatValue" "()F" - compile-jvm-fgt Opcodes/FCMPG Opcodes/IFGT "java.lang.Float" "floatValue" "()F" + compile-jvm-feq Opcodes/FCMPG 0 "java.lang.Float" "floatValue" "()F" + compile-jvm-flt Opcodes/FCMPG 1 "java.lang.Float" "floatValue" "()F" + compile-jvm-fgt Opcodes/FCMPG -1 "java.lang.Float" "floatValue" "()F" - compile-jvm-deq Opcodes/DCMPG Opcodes/IFEQ "java.lang.Double" "doubleValue" "()I" - compile-jvm-dlt Opcodes/DCMPG Opcodes/IFLT "java.lang.Double" "doubleValue" "()I" - compile-jvm-dgt Opcodes/FCMPG Opcodes/IFGT "java.lang.Double" "doubleValue" "()I" + compile-jvm-deq Opcodes/DCMPG 0 "java.lang.Double" "doubleValue" "()I" + compile-jvm-dlt Opcodes/DCMPG 1 "java.lang.Double" "doubleValue" "()I" + compile-jvm-dgt Opcodes/FCMPG -1 "java.lang.Double" "doubleValue" "()I" ) (defn compile-jvm-invokestatic [compile *type* ?class ?method ?classes ?args] (|do [^MethodVisitor *writer* &/get-writer - :let [method-sig (str "(" (reduce str "" (map &host/->type-signature ?classes)) ")" (&host/->java-sig *type*))] - _ (&/map% (fn [[class-name arg]] - (|do [ret (compile arg) - :let [_ (prepare-arg! *writer* class-name)]] - (return ret))) - (map vector ?classes ?args)) + :let [method-sig (str "(" (&/fold str "" (&/|map &host/->type-signature ?classes)) ")" (&host/->java-sig *type*))] + _ (&/map2% (fn [class-name arg] + (|do [ret (compile arg) + :let [_ (prepare-arg! *writer* class-name)]] + (return ret))) + ?classes ?args) :let [_ (doto *writer* - (.visitMethodInsn Opcodes/INVOKESTATIC (&host/->class ?class) ?method method-sig) + (.visitMethodInsn Opcodes/INVOKESTATIC (&host/->class (&type/as-obj ?class)) ?method method-sig) (prepare-return! *type*))]] (return nil))) (do-template [<name> <op>] (defn <name> [compile *type* ?class ?method ?classes ?object ?args] - ;; (prn 'compile-jvm-invokevirtual ?classes *type*) - (|do [^MethodVisitor *writer* &/get-writer + (|do [:let [?class* (&host/->class (&type/as-obj ?class))] + ^MethodVisitor *writer* &/get-writer :let [method-sig (str "(" (&/fold str "" (&/|map &host/->type-signature ?classes)) ")" (&host/->java-sig *type*))] _ (compile ?object) - :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST (&host/->class ?class))] - _ (&/map% (fn [class-name+arg] - (|let [[class-name arg] class-name+arg] - (|do [ret (compile arg) - :let [_ (prepare-arg! *writer* class-name)]] - (return ret)))) - (&/zip2 ?classes ?args)) + :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST ?class*)] + _ (&/map2% (fn [class-name arg] + (|do [ret (compile arg) + :let [_ (prepare-arg! *writer* class-name)]] + (return ret))) + ?classes ?args) :let [_ (doto *writer* - (.visitMethodInsn <op> (&host/->class ?class) ?method method-sig) + (.visitMethodInsn <op> ?class* ?method method-sig) (prepare-return! *type*))]] (return nil))) compile-jvm-invokevirtual Opcodes/INVOKEVIRTUAL compile-jvm-invokeinterface Opcodes/INVOKEINTERFACE - compile-jvm-invokespecial Opcodes/INVOKESPECIAL + ;; compile-jvm-invokespecial Opcodes/INVOKESPECIAL ) +(defn compile-jvm-invokespecial [compile *type* ?class ?method ?classes ?object ?args] + (|do [:let [?class* (&host/->class (&type/as-obj ?class))] + ^MethodVisitor *writer* &/get-writer + :let [method-sig (str "(" (&/fold str "" (&/|map &host/->type-signature ?classes)) ")" (&host/->java-sig *type*))] + _ (compile ?object) + ;; :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST ?class*)] + :let [_ (when (not= "<init>" ?method) + (.visitTypeInsn *writer* Opcodes/CHECKCAST ?class*))] + _ (&/map2% (fn [class-name arg] + (|do [ret (compile arg) + :let [_ (prepare-arg! *writer* class-name)]] + (return ret))) + ?classes ?args) + :let [_ (doto *writer* + (.visitMethodInsn Opcodes/INVOKESPECIAL ?class* ?method method-sig) + (prepare-return! *type*))]] + (return nil))) + (defn compile-jvm-null [compile *type*] (|do [^MethodVisitor *writer* &/get-writer :let [_ (.visitInsn *writer* Opcodes/ACONST_NULL)]] @@ -240,7 +270,7 @@ (defn compile-jvm-new [compile *type* ?class ?classes ?args] (|do [^MethodVisitor *writer* &/get-writer - :let [init-sig (str "(" (reduce str "" (map &host/->type-signature ?classes)) ")V") + :let [init-sig (str "(" (&/fold str "" (&/|map &host/->type-signature ?classes)) ")V") class* (&host/->class ?class) _ (doto *writer* (.visitTypeInsn Opcodes/NEW class*) @@ -249,7 +279,7 @@ (|do [ret (compile arg) :let [_ (prepare-arg! *writer* class-name)]] (return ret))) - (map vector ?classes ?args)) + (&/zip2 ?classes ?args)) :let [_ (doto *writer* (.visitMethodInsn Opcodes/INVOKESPECIAL class* "<init>" init-sig))]] (return nil))) @@ -281,68 +311,101 @@ (defn compile-jvm-getstatic [compile *type* ?class ?field] (|do [^MethodVisitor *writer* &/get-writer - :let [_ (.visitFieldInsn *writer* Opcodes/GETSTATIC (&host/->class ?class) ?field (&host/->java-sig *type*))]] + :let [_ (doto *writer* + (.visitFieldInsn Opcodes/GETSTATIC (&host/->class (&type/as-obj ?class)) ?field (&host/->java-sig *type*)) + (prepare-return! *type*))]] (return nil))) (defn compile-jvm-getfield [compile *type* ?class ?field ?object] - (|do [^MethodVisitor *writer* &/get-writer + (|do [:let [class* (&host/->class (&type/as-obj ?class))] + ^MethodVisitor *writer* &/get-writer _ (compile ?object) - :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST (&host/->class ?class))] - :let [_ (.visitFieldInsn *writer* Opcodes/GETFIELD (&host/->class ?class) ?field (&host/->java-sig *type*))]] + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/CHECKCAST class*) + (.visitFieldInsn Opcodes/GETFIELD class* ?field (&host/->java-sig *type*)) + (prepare-return! *type*))]] (return nil))) (defn compile-jvm-putstatic [compile *type* ?class ?field ?value] (|do [^MethodVisitor *writer* &/get-writer _ (compile ?value) - :let [_ (.visitFieldInsn *writer* Opcodes/PUTSTATIC (&host/->class ?class) ?field (&host/->java-sig *type*))]] + :let [_ (.visitFieldInsn *writer* Opcodes/PUTSTATIC (&host/->class (&type/as-obj ?class)) ?field (&host/->java-sig *type*))]] (return nil))) (defn compile-jvm-putfield [compile *type* ?class ?field ?object ?value] - (|do [^MethodVisitor *writer* &/get-writer + (|do [:let [class* (&host/->class (&type/as-obj ?class))] + ^MethodVisitor *writer* &/get-writer _ (compile ?object) _ (compile ?value) - :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST (&host/->class ?class))] - :let [_ (.visitFieldInsn *writer* Opcodes/PUTFIELD (&host/->class ?class) ?field (&host/->java-sig *type*))]] + :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST class*)] + :let [_ (.visitFieldInsn *writer* Opcodes/PUTFIELD class* ?field (&host/->java-sig *type*))]] (return nil))) -(defn compile-jvm-class [compile ?package ?name ?super-class ?fields ?methods] - (let [parent-dir (&host/->package ?package) - full-name (str parent-dir "/" ?name) - super-class* (&host/->class ?super-class) - =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) - (.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER) - full-name nil super-class* nil)) - _ (do (doseq [[field props] ?fields] - (doto (.visitField =class Opcodes/ACC_PUBLIC field (&host/->type-signature (:type props)) nil nil) - (.visitEnd))) - (doto (.visitMethod =class Opcodes/ACC_PUBLIC "<init>" "()V" nil nil) - (.visitCode) - (.visitVarInsn Opcodes/ALOAD 0) - (.visitMethodInsn Opcodes/INVOKESPECIAL super-class* "<init>" "()V") - (.visitInsn Opcodes/RETURN) - (.visitMaxs 0 0) - (.visitEnd)) - (.visitEnd =class) - (.mkdirs (java.io.File. (str "output/" parent-dir))))] - (&&/save-class! full-name (.toByteArray =class)))) +(defn ^:private modifiers->int [mods] + (+ (case (:visibility mods) + "default" 0 + "public" Opcodes/ACC_PUBLIC + "private" Opcodes/ACC_PRIVATE + "protected" Opcodes/ACC_PROTECTED) + (if (:static? mods) Opcodes/ACC_STATIC 0) + (if (:final? mods) Opcodes/ACC_FINAL 0) + (if (:abstract? mods) Opcodes/ACC_ABSTRACT 0) + (case (:concurrency mods) + "synchronized" Opcodes/ACC_SYNCHRONIZED + "volatile" Opcodes/ACC_VOLATILE + ;; else + 0))) -(defn compile-jvm-interface [compile ?package ?name ?methods] - ;; (prn 'compile-jvm-interface ?package ?name ?methods) - (let [parent-dir (&host/->package ?package) - full-name (str parent-dir "/" ?name) - =interface (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) - (.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_INTERFACE) - full-name nil "java/lang/Object" nil)) - _ (do (doseq [[?method ?props] ?methods - :let [[?args ?return] (:type ?props) - signature (str "(" (&/fold str "" (&/|map &host/->type-signature ?args)) ")" (&host/->type-signature ?return)) - ;; _ (prn 'signature signature) - ]] - (.visitMethod =interface (+ Opcodes/ACC_PUBLIC Opcodes/ACC_ABSTRACT) ?method signature nil nil)) - (.visitEnd =interface) - (.mkdirs (java.io.File. (str "output/" parent-dir))))] - ;; (prn 'SAVED_CLASS full-name) - (&&/save-class! full-name (.toByteArray =interface)))) +(defn compile-jvm-instanceof [compile *type* class object] + (|do [:let [class* (&host/->class class)] + ^MethodVisitor *writer* &/get-writer + _ (compile object) + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/INSTANCEOF class*) + (&&/wrap-boolean))]] + (return nil))) + +(defn compile-jvm-class [compile ?name ?super-class ?interfaces ?fields ?methods] + (|do [module &/get-module-name] + (let [super-class* (&host/->class ?super-class) + =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) + (.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER) + (str module "/" ?name) nil super-class* (->> ?interfaces (&/|map &host/->class) &/->seq (into-array String)))) + _ (&/|map (fn [field] + (doto (.visitField =class (modifiers->int (:modifiers field)) (:name field) + (&host/->type-signature (:type field)) nil nil) + (.visitEnd))) + ?fields)] + (|do [_ (&/map% (fn [method] + (|let [signature (str "(" (&/fold str "" (&/|map &host/->type-signature (:inputs method))) ")" + (&host/->type-signature (:output method)))] + (&/with-writer (.visitMethod =class (modifiers->int (:modifiers method)) + (:name method) + signature nil nil) + (|do [^MethodVisitor =method &/get-writer + :let [_ (.visitCode =method)] + _ (compile (:body method)) + :let [_ (doto =method + (.visitInsn (if (= "void" (:output method)) Opcodes/RETURN Opcodes/ARETURN)) + (.visitMaxs 0 0) + (.visitEnd))]] + (return nil))))) + ?methods)] + (&&/save-class! ?name (.toByteArray (doto =class .visitEnd))))))) + +(defn compile-jvm-interface [compile ?name ?supers ?methods] + ;; (prn 'compile-jvm-interface (->> ?supers &/->seq pr-str)) + (|do [module &/get-module-name] + (let [=interface (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) + (.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_INTERFACE) + (str module "/" ?name) nil "java/lang/Object" (->> ?supers (&/|map &host/->class) &/->seq (into-array String)))) + _ (do (&/|map (fn [method] + (|let [signature (str "(" (&/fold str "" (&/|map &host/->type-signature (:inputs method))) ")" + (&host/->type-signature (:output method)))] + (.visitMethod =interface (modifiers->int (:modifiers method)) (:name method) signature nil nil))) + ?methods) + (.visitEnd =interface))] + (&&/save-class! ?name (.toByteArray =interface))))) (defn compile-jvm-try [compile *type* ?body ?catches ?finally] (|do [^MethodVisitor *writer* &/get-writer @@ -350,46 +413,50 @@ $to (new Label) $end (new Label) $catch-finally (new Label) - compile-finally (if ?finally - (|do [_ (return nil) - _ (compile ?finally) - :let [_ (doto *writer* - (.visitInsn Opcodes/POP) - (.visitJumpInsn Opcodes/GOTO $end))]] - (return nil)) - (|do [_ (return nil) - :let [_ (.visitJumpInsn *writer* Opcodes/GOTO $end)]] - (return nil))) - _ (.visitLabel *writer* $from)] + compile-finally (matchv ::M/objects [?finally] + [["lux;Some" ?finally*]] (|do [_ (return nil) + _ (compile ?finally*) + :let [_ (doto *writer* + (.visitInsn Opcodes/POP) + (.visitJumpInsn Opcodes/GOTO $end))]] + (return nil)) + [["lux;None" _]] (|do [_ (return nil) + :let [_ (.visitJumpInsn *writer* Opcodes/GOTO $end)]] + (return nil))) + catch-boundaries (&/|map (fn [[?ex-class ?ex-idx ?catch-body]] [?ex-class (new Label) (new Label)]) + ?catches) + _ (doseq [[?ex-class $handler-start $handler-end] (&/->seq catch-boundaries) + ;; :let [_ (prn 'HANDLER ?ex-class (&host/->class ?ex-class) $handler-start $handler-end $from $to $catch-finally)] + ] + (doto *writer* + (.visitTryCatchBlock $from $to $handler-start (&host/->class ?ex-class)) + (.visitTryCatchBlock $handler-start $handler-end $catch-finally nil))) + _ (.visitTryCatchBlock *writer* $from $to $catch-finally nil)] + :let [_ (.visitLabel *writer* $from)] _ (compile ?body) :let [_ (.visitLabel *writer* $to)] _ compile-finally - handlers (&/map% (fn [[?ex-class ?ex-arg ?catch-body]] - (|do [:let [$handler-start (new Label) - $handler-end (new Label)] - _ (compile ?catch-body) - :let [_ (.visitLabel *writer* $handler-end)] - _ compile-finally] - (return [?ex-class $handler-start $handler-end]))) - ?catches) + handlers (&/map2% (fn [[?ex-class ?ex-idx ?catch-body] [_ $handler-start $handler-end]] + (|do [:let [_ (doto *writer* + (.visitLabel $handler-start) + (.visitVarInsn Opcodes/ASTORE ?ex-idx))] + _ (compile ?catch-body) + :let [_ (.visitLabel *writer* $handler-end)]] + compile-finally)) + ?catches + catch-boundaries) + ;; :let [_ (prn 'handlers (&/->seq handlers))] :let [_ (.visitLabel *writer* $catch-finally)] - _ (if ?finally - (|do [_ (compile ?finally) - :let [_ (doto *writer* - (.visitInsn Opcodes/POP) - (.visitInsn Opcodes/ATHROW))]] - (return nil)) - (|do [_ (return nil) - :let [_ (.visitInsn *writer* Opcodes/ATHROW)]] - (return nil))) + _ (matchv ::M/objects [?finally] + [["lux;Some" ?finally*]] (|do [_ (compile ?finally*) + :let [_ (.visitInsn *writer* Opcodes/POP)] + :let [_ (.visitInsn *writer* Opcodes/ATHROW)]] + (return nil)) + [["lux;None" _]] (|do [_ (return nil) + :let [_ (.visitInsn *writer* Opcodes/ATHROW)]] + (return nil))) :let [_ (.visitJumpInsn *writer* Opcodes/GOTO $end)] - :let [_ (.visitLabel *writer* $end)] - :let [_ (doseq [[?ex-class $handler-start $handler-end] handlers] - (doto *writer* - (.visitTryCatchBlock $from $to $handler-start ?ex-class) - (.visitTryCatchBlock $handler-start $handler-end $catch-finally nil)) - ) - _ (.visitTryCatchBlock *writer* $from $to $catch-finally nil)]] + :let [_ (.visitLabel *writer* $end)]] (return nil))) (defn compile-jvm-throw [compile *type* ?ex] @@ -477,14 +544,97 @@ ) (defn compile-jvm-program [compile ?body] - (|do [^ClassWriter *writer* &/get-writer] + (|do [module-name &/get-module-name + ;; :let [_ (prn 'compile-jvm-program module-name)] + ^ClassWriter *writer* &/get-writer] (&/with-writer (doto (.visitMethod *writer* (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "main" "([Ljava/lang/String;)V" nil nil) (.visitCode)) - (|do [main-writer &/get-writer + (|do [^MethodVisitor main-writer &/get-writer + :let [;; _ (prn "#1" module-name *writer*) + $loop (new Label) + ;; _ (prn "#2") + $end (new Label) + ;; _ (prn "#3") + _ (doto main-writer + ;; Tail: Begin + (.visitLdcInsn (int 2)) ;; S + (.visitTypeInsn Opcodes/ANEWARRAY "java/lang/Object") ;; V + (.visitInsn Opcodes/DUP) ;; VV + (.visitLdcInsn (int 0)) ;; VVI + (.visitLdcInsn "lux;Nil") ;; VVIT + (.visitInsn Opcodes/AASTORE) ;; V + (.visitInsn Opcodes/DUP) ;; VV + (.visitLdcInsn (int 1)) ;; VVI + (.visitInsn Opcodes/ACONST_NULL) ;; VVIN + (.visitInsn Opcodes/AASTORE) ;; V + ;; Tail: End + ;; Size: Begin + (.visitVarInsn Opcodes/ALOAD 0) ;; VA + (.visitInsn Opcodes/ARRAYLENGTH) ;; VI + ;; Size: End + ;; Loop: Begin + (.visitLabel $loop) + (.visitLdcInsn (int 1)) ;; VII + (.visitInsn Opcodes/ISUB) ;; VI + (.visitInsn Opcodes/DUP) ;; VII + (.visitJumpInsn Opcodes/IFLT $end) ;; VI + ;; Head: Begin + (.visitInsn Opcodes/DUP) ;; VII + (.visitVarInsn Opcodes/ALOAD 0) ;; VIIA + (.visitInsn Opcodes/SWAP) ;; VIAI + (.visitInsn Opcodes/AALOAD) ;; VIO + (.visitInsn Opcodes/SWAP) ;; VOI + (.visitInsn Opcodes/DUP_X2) ;; IVOI + (.visitInsn Opcodes/POP) ;; IVO + ;; Head: End + ;; Tuple: Begin + (.visitLdcInsn (int 2)) ;; IVOS + (.visitTypeInsn Opcodes/ANEWARRAY "java/lang/Object") ;; IVO2 + (.visitInsn Opcodes/DUP_X1) ;; IV2O2 + (.visitInsn Opcodes/SWAP) ;; IV22O + (.visitLdcInsn (int 0)) ;; IV22OI + (.visitInsn Opcodes/SWAP) ;; IV22IO + (.visitInsn Opcodes/AASTORE) ;; IV2 + (.visitInsn Opcodes/DUP_X1) ;; I2V2 + (.visitInsn Opcodes/SWAP) ;; I22V + (.visitLdcInsn (int 1)) ;; I22VI + (.visitInsn Opcodes/SWAP) ;; I22IV + (.visitInsn Opcodes/AASTORE) ;; I2 + ;; Tuple: End + ;; Cons: Begin + (.visitLdcInsn (int 2)) ;; I2I + (.visitTypeInsn Opcodes/ANEWARRAY "java/lang/Object") ;; I2V + (.visitInsn Opcodes/DUP) ;; I2VV + (.visitLdcInsn (int 0)) ;; I2VVI + (.visitLdcInsn "lux;Cons") ;; I2VVIT + (.visitInsn Opcodes/AASTORE) ;; I2V + (.visitInsn Opcodes/DUP_X1) ;; IV2V + (.visitInsn Opcodes/SWAP) ;; IVV2 + (.visitLdcInsn (int 1)) ;; IVV2I + (.visitInsn Opcodes/SWAP) ;; IVVI2 + (.visitInsn Opcodes/AASTORE) ;; IV + ;; Cons: End + (.visitInsn Opcodes/SWAP) ;; VI + (.visitJumpInsn Opcodes/GOTO $loop) + ;; Loop: End + (.visitLabel $end) ;; VI + (.visitInsn Opcodes/POP) ;; V + (.visitVarInsn Opcodes/ASTORE (int 0)) ;; + ) + ;; _ (prn "#4") + ] _ (compile ?body) - :let [_ (doto ^MethodVisitor main-writer + :let [;; _ (prn "#5") + _ (doto main-writer + (.visitInsn Opcodes/ACONST_NULL) + (.visitMethodInsn Opcodes/INVOKEINTERFACE &&/function-class "apply" &&/apply-signature)) + ;; _ (prn "#6") + ] + :let [_ (doto main-writer (.visitInsn Opcodes/POP) (.visitInsn Opcodes/RETURN) (.visitMaxs 0 0) - (.visitEnd))]] + (.visitEnd)) + ;; _ (prn "#7") + ]] (return nil))))) diff --git a/src/lux/compiler/lambda.clj b/src/lux/compiler/lambda.clj index 962a32ab6..ccd12e68a 100644 --- a/src/lux/compiler/lambda.clj +++ b/src/lux/compiler/lambda.clj @@ -1,3 +1,11 @@ +;; 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.lambda (:require (clojure [string :as string] [set :as set] @@ -11,9 +19,7 @@ [analyser :as &analyser] [host :as &host]) [lux.analyser.base :as &a] - (lux.compiler [base :as &&]) - ;; :reload - ) + (lux.compiler [base :as &&])) (:import (org.objectweb.asm Opcodes Label ClassWriter @@ -39,9 +45,7 @@ (-> (doto (.visitVarInsn Opcodes/ALOAD 0) (.visitVarInsn Opcodes/ALOAD (inc ?captured-id)) (.visitFieldInsn Opcodes/PUTFIELD class-name captured-name clo-field-sig)) - (->> (let [captured-name (str &&/closure-prefix ?captured-id) - ;; _ (prn 'add-lambda-<init> class-name ?captured-id) - ]) + (->> (let [captured-name (str &&/closure-prefix ?captured-id)]) (matchv ::M/objects [?name+?captured] [[?name [["captured" [_ ?captured-id ?source]] _]]]) (doseq [?name+?captured (&/->seq env)]))) @@ -63,13 +67,8 @@ (&/with-writer (doto (.visitMethod ^ClassWriter class Opcodes/ACC_PUBLIC "impl" impl-signature nil nil) (.visitCode)) (|do [^MethodVisitor *writer* &/get-writer - :let [num-locals (&&/total-locals impl-body) - $start (new Label) - $end (new Label) - _ (doto *writer* - (-> (.visitLocalVariable (str &&/local-prefix idx) (&host/->java-sig (&/V "lux;DataT" "java.lang.Object")) nil $start $end (+ 2 idx)) - (->> (dotimes [idx num-locals]))) - (.visitLabel $start))] + :let [$start (new Label) + $end (new Label)] ret (compile impl-body) :let [_ (doto *writer* (.visitLabel $end) @@ -79,48 +78,36 @@ (return ret)))) (defn ^:private instance-closure [compile lambda-class closed-over init-signature] - ;; (prn 'instance-closure lambda-class (&/|length closed-over) init-signature) (|do [^MethodVisitor *writer* &/get-writer :let [_ (doto *writer* (.visitTypeInsn Opcodes/NEW lambda-class) (.visitInsn Opcodes/DUP))] - _ (->> closed-over - &/->seq - (sort #(matchv ::M/objects [(&/|second %1) (&/|second %2)] - [[["captured" [_ ?cid1 _]] _] - [["captured" [_ ?cid2 _]] _]] - (< ?cid1 ?cid2))) - &/->list - (&/map% (fn [?name+?captured] - (matchv ::M/objects [?name+?captured] - [[?name [["captured" [_ _ ?source]] _]]] - (compile ?source))))) + _ (&/map% (fn [?name+?captured] + (matchv ::M/objects [?name+?captured] + [[?name [["captured" [_ _ ?source]] _]]] + (compile ?source))) + closed-over) :let [_ (.visitMethodInsn *writer* Opcodes/INVOKESPECIAL lambda-class "<init>" init-signature)]] (return nil))) ;; [Exports] (defn compile-lambda [compile ?scope ?env ?body] - ;; (prn 'compile-lambda ?scope (&host/location ?scope) ?env) - (|do [:let [lambda-class (&host/location ?scope) + ;; (prn 'compile-lambda (->> ?scope &/->seq)) + (|do [:let [name (&host/location (&/|tail ?scope)) + class-name (str (&host/->module-class (&/|head ?scope)) "/" name) =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) (.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_SUPER) - lambda-class nil "java/lang/Object" (into-array [(&host/->class &host/function-class)])) + class-name nil "java/lang/Object" (into-array [&&/function-class])) (-> (doto (.visitField (+ Opcodes/ACC_PRIVATE Opcodes/ACC_FINAL) captured-name clo-field-sig nil nil) (.visitEnd)) (->> (let [captured-name (str &&/closure-prefix ?captured-id)]) (matchv ::M/objects [?name+?captured] [[?name [["captured" [_ ?captured-id ?source]] _]]]) - (doseq [?name+?captured (&/->seq ?env) - ;; :let [_ (prn '?name+?captured (alength ?name+?captured)) - ;; _ (prn '?name+?captured (aget ?name+?captured 1 0)) - ;; _ (prn '?name+?captured (aget ?name+?captured 1 1 0 0))] - ]))) - (add-lambda-apply lambda-class ?env) - (add-lambda-<init> lambda-class ?env) + (doseq [?name+?captured (&/->seq ?env)]))) + (add-lambda-apply class-name ?env) + (add-lambda-<init> class-name ?env) )] _ (add-lambda-impl =class compile lambda-impl-signature ?body) - :let [_ (.visitEnd =class) - ;; _ (prn 'SAVING_LAMBDA lambda-class) - ] - _ (&&/save-class! lambda-class (.toByteArray =class))] - (instance-closure compile lambda-class ?env (lambda-<init>-signature ?env)))) + :let [_ (.visitEnd =class)] + _ (&&/save-class! name (.toByteArray =class))] + (instance-closure compile class-name ?env (lambda-<init>-signature ?env)))) diff --git a/src/lux/compiler/lux.clj b/src/lux/compiler/lux.clj index ad2c9d0c6..b1023689e 100644 --- a/src/lux/compiler/lux.clj +++ b/src/lux/compiler/lux.clj @@ -1,3 +1,11 @@ +;; 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.lux (:require (clojure [string :as string] [set :as set] @@ -13,36 +21,32 @@ (lux.analyser [base :as &a] [module :as &a-module]) (lux.compiler [base :as &&] - [lambda :as &&lambda]) - ;; :reload - ) + [lambda :as &&lambda] + [type :as &&type])) (:import (org.objectweb.asm Opcodes Label ClassWriter MethodVisitor))) ;; [Exports] -(let [+class+ (&host/->class "java.lang.Boolean") - +sig+ (&host/->type-signature "java.lang.Boolean")] - (defn compile-bool [compile *type* ?value] - (|do [^MethodVisitor *writer* &/get-writer - :let [_ (.visitFieldInsn *writer* Opcodes/GETSTATIC (&host/->class "java.lang.Boolean") (if ?value "TRUE" "FALSE") (&host/->type-signature "java.lang.Boolean"))]] - (return nil)))) +(defn compile-bool [compile *type* ?value] + (|do [^MethodVisitor *writer* &/get-writer + :let [_ (.visitFieldInsn *writer* Opcodes/GETSTATIC "java/lang/Boolean" (if ?value "TRUE" "FALSE") "Ljava/lang/Boolean;")]] + (return nil))) (do-template [<name> <class> <sig> <caster>] - (let [+class+ (&host/->class <class>)] - (defn <name> [compile *type* value] - (|do [^MethodVisitor *writer* &/get-writer - :let [_ (doto *writer* - (.visitTypeInsn Opcodes/NEW +class+) - (.visitInsn Opcodes/DUP) - (.visitLdcInsn (<caster> value)) - (.visitMethodInsn Opcodes/INVOKESPECIAL +class+ "<init>" <sig>))]] - (return nil)))) + (defn <name> [compile *type* value] + (|do [^MethodVisitor *writer* &/get-writer + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/NEW <class>) + (.visitInsn Opcodes/DUP) + (.visitLdcInsn (<caster> value)) + (.visitMethodInsn Opcodes/INVOKESPECIAL <class> "<init>" <sig>))]] + (return nil))) - compile-int "java.lang.Long" "(J)V" long - compile-real "java.lang.Double" "(D)V" double - compile-char "java.lang.Character" "(C)V" char + compile-int "java/lang/Long" "(J)V" long + compile-real "java/lang/Double" "(D)V" double + compile-char "java/lang/Character" "(C)V" char ) (defn compile-text [compile *type* ?value] @@ -55,46 +59,43 @@ :let [num-elems (&/|length ?elems) _ (doto *writer* (.visitLdcInsn (int num-elems)) - (.visitTypeInsn Opcodes/ANEWARRAY (&host/->class "java.lang.Object")))] - _ (&/map% (fn [idx+elem] - (|let [[idx elem] idx+elem] - (|do [:let [_ (doto *writer* - (.visitInsn Opcodes/DUP) - (.visitLdcInsn (int idx)))] - ret (compile elem) - :let [_ (.visitInsn *writer* Opcodes/AASTORE)]] - (return ret)))) - (&/zip2 (&/|range num-elems) ?elems))] + (.visitTypeInsn Opcodes/ANEWARRAY "java/lang/Object"))] + _ (&/map2% (fn [idx elem] + (|do [:let [_ (doto *writer* + (.visitInsn Opcodes/DUP) + (.visitLdcInsn (int idx)))] + ret (compile elem) + :let [_ (.visitInsn *writer* Opcodes/AASTORE)]] + (return ret))) + (&/|range num-elems) ?elems)] (return nil))) (defn compile-record [compile *type* ?elems] - ;; (prn 'compile-record (str "{{" (->> ?elems &/|keys (&/|interpose " ") (&/fold str "")) "}}")) (|do [^MethodVisitor *writer* &/get-writer :let [elems* (->> ?elems &/->seq (sort #(compare (&/|first %1) (&/|first %2))) &/->list) - ;; _ (prn 'compile-record (str "{{" (->> elems* &/|keys (&/|interpose " ") (&/fold str "")) "}}")) num-elems (&/|length elems*) _ (doto *writer* (.visitLdcInsn (int num-elems)) - (.visitTypeInsn Opcodes/ANEWARRAY (&host/->class "java.lang.Object")))] - _ (&/map% (fn [idx+kv] - (|let [[idx [k v]] idx+kv] - (|do [:let [_ (doto *writer* - (.visitInsn Opcodes/DUP) - (.visitLdcInsn (int idx)))] - ret (compile v) - :let [_ (.visitInsn *writer* Opcodes/AASTORE)]] - (return ret)))) - (&/zip2 (&/|range num-elems) elems*))] + (.visitTypeInsn Opcodes/ANEWARRAY "java/lang/Object"))] + _ (&/map2% (fn [idx kv] + (|let [[k v] kv] + (|do [:let [_ (doto *writer* + (.visitInsn Opcodes/DUP) + (.visitLdcInsn (int idx)))] + ret (compile v) + :let [_ (.visitInsn *writer* Opcodes/AASTORE)]] + (return ret)))) + (&/|range num-elems) elems*)] (return nil))) (defn compile-variant [compile *type* ?tag ?value] (|do [^MethodVisitor *writer* &/get-writer :let [_ (doto *writer* (.visitLdcInsn (int 2)) - (.visitTypeInsn Opcodes/ANEWARRAY (&host/->class "java.lang.Object")) + (.visitTypeInsn Opcodes/ANEWARRAY "java/lang/Object") (.visitInsn Opcodes/DUP) (.visitLdcInsn (int 0)) (.visitLdcInsn ?tag) @@ -111,61 +112,106 @@ (return nil))) (defn compile-captured [compile *type* ?scope ?captured-id ?source] - ;; (prn 'compile-captured ?scope ?captured-id) (|do [^MethodVisitor *writer* &/get-writer :let [_ (doto *writer* (.visitVarInsn Opcodes/ALOAD 0) (.visitFieldInsn Opcodes/GETFIELD - (&host/location ?scope) + (str (&host/->module-class (&/|head ?scope)) "/" (&host/location (&/|tail ?scope))) (str &&/closure-prefix ?captured-id) "Ljava/lang/Object;"))]] (return nil))) (defn compile-global [compile *type* ?owner-class ?name] (|do [^MethodVisitor *writer* &/get-writer - :let [_ (.visitFieldInsn *writer* Opcodes/GETSTATIC (&host/->class (&host/location (&/|list ?owner-class ?name))) "_datum" "Ljava/lang/Object;")]] + :let [_ (.visitFieldInsn *writer* Opcodes/GETSTATIC (str (&host/->module-class ?owner-class) "/" (&/normalize-name ?name)) "_datum" "Ljava/lang/Object;")]] (return nil))) -(defn compile-apply [compile *type* ?fn ?arg] +(defn compile-apply [compile *type* ?fn ?args] (|do [^MethodVisitor *writer* &/get-writer _ (compile ?fn) - _ (compile ?arg) - :let [_ (.visitMethodInsn *writer* Opcodes/INVOKEINTERFACE (&host/->class &host/function-class) "apply" &&/apply-signature)]] + _ (&/map% (fn [?arg] + (|do [=arg (compile ?arg) + :let [_ (.visitMethodInsn *writer* Opcodes/INVOKEINTERFACE &&/function-class "apply" &&/apply-signature)]] + (return =arg))) + ?args)] (return nil))) +(defn ^:private compile-def-type [compile ?body ?def-data] + (|do [^MethodVisitor **writer** &/get-writer] + (matchv ::M/objects [?def-data] + [["lux;TypeD" _]] + (let [_ (doto **writer** + ;; Tail: Begin + (.visitLdcInsn (int 2)) ;; S + (.visitTypeInsn Opcodes/ANEWARRAY "java/lang/Object") ;; V + (.visitInsn Opcodes/DUP) ;; VV + (.visitLdcInsn (int 0)) ;; VVI + (.visitLdcInsn "lux;TypeD") ;; VVIT + (.visitInsn Opcodes/AASTORE) ;; V + (.visitInsn Opcodes/DUP) ;; VV + (.visitLdcInsn (int 1)) ;; VVI + (.visitInsn Opcodes/ACONST_NULL) ;; VVIN + (.visitInsn Opcodes/AASTORE) ;; V + )] + (return nil)) + + [["lux;ValueD" _]] + (|let [;; _ (prn '?body (aget ?body 0) (aget ?body 1 0)) + [?def-value ?def-type] (matchv ::M/objects [?body] + [[["ann" [?def-value ?type-expr]] ?def-type]] + (&/T ?def-value ?type-expr) + + [[?def-value ?def-type]] + (&/T ?body (&&type/->analysis ?def-type)))] + (|do [:let [_ (doto **writer** + (.visitLdcInsn (int 2)) ;; S + (.visitTypeInsn Opcodes/ANEWARRAY "java/lang/Object") ;; V + (.visitInsn Opcodes/DUP) ;; VV + (.visitLdcInsn (int 0)) ;; VVI + (.visitLdcInsn "lux;ValueD") ;; VVIT + (.visitInsn Opcodes/AASTORE) ;; V + (.visitInsn Opcodes/DUP) ;; VV + (.visitLdcInsn (int 1)) ;; VVI + )] + _ (compile ?def-type) + :let [_ (.visitInsn **writer** Opcodes/AASTORE)]] + (return nil))) + ))) + (defn compile-def [compile ?name ?body ?def-data] (|do [^ClassWriter *writer* &/get-writer module-name &/get-module-name - :let [outer-class (&host/->class module-name) - datum-sig (&host/->type-signature "java.lang.Object") - current-class (&host/location (&/|list outer-class ?name)) - _ (.visitInnerClass *writer* current-class outer-class nil (+ Opcodes/ACC_STATIC Opcodes/ACC_SYNTHETIC)) + :let [datum-sig "Ljava/lang/Object;" + def-name (&/normalize-name ?name) + current-class (str (&host/->module-class module-name) "/" def-name) =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) (.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_SUPER) - current-class nil "java/lang/Object" (into-array [(&host/->class &host/function-class)])) + current-class nil "java/lang/Object" (into-array [&&/function-class])) + (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) "_name" "Ljava/lang/String;" nil ?name) + (doto (.visitEnd))) (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) "_datum" datum-sig nil nil) + (doto (.visitEnd))) + (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) "_meta" datum-sig nil nil) (doto (.visitEnd))))] - ;; :let [_ (prn 'compile-def/pre-body)] _ (&/with-writer (.visitMethod =class Opcodes/ACC_PUBLIC "<clinit>" "()V" nil nil) (|do [^MethodVisitor **writer** &/get-writer :let [_ (.visitCode **writer**)] - ;; :let [_ (prn 'compile-def/pre-body2)] _ (compile ?body) - ;; :let [_ (prn 'compile-def/post-body2)] + :let [_ (.visitFieldInsn **writer** Opcodes/PUTSTATIC current-class "_datum" datum-sig)] + _ (compile-def-type compile ?body ?def-data) + :let [_ (.visitFieldInsn **writer** Opcodes/PUTSTATIC current-class "_meta" datum-sig)] :let [_ (doto **writer** - (.visitFieldInsn Opcodes/PUTSTATIC current-class "_datum" datum-sig) (.visitInsn Opcodes/RETURN) (.visitMaxs 0 0) (.visitEnd))]] (return nil))) - ;; :let [_ (prn 'compile-def/post-body)] :let [_ (.visitEnd *writer*)] - ;; :let [_ (prn 'compile-def/_1 ?name current-class)] - _ (&&/save-class! current-class (.toByteArray =class)) - ;; :let [_ (prn 'compile-def/_2 ?name)] - ] + _ (&&/save-class! def-name (.toByteArray =class))] (return nil))) +(defn compile-ann [compile *type* ?value-ex ?type-ex] + (compile ?value-ex)) + (defn compile-declare-macro [compile module name] (|do [_ (&a-module/declare-macro module name)] (return nil))) diff --git a/src/lux/compiler/package.clj b/src/lux/compiler/package.clj new file mode 100644 index 000000000..40639e85a --- /dev/null +++ b/src/lux/compiler/package.clj @@ -0,0 +1,61 @@ +;; 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.package + (:require [clojure.core.match :as M :refer [matchv]] + clojure.core.match.array + (lux [base :as & :refer [|let |do return* return fail fail*]] + [host :as &host]) + (lux.compiler [base :as &&])) + (:import (java.io File + FileInputStream + FileOutputStream + BufferedInputStream) + (java.util.jar Manifest + Attributes$Name + JarEntry + JarOutputStream + ))) + +;; [Utils] +(def ^:private kilobyte 1024) + +(defn ^:private manifest [^String module] + "(-> Text Manifest)" + (doto (new Manifest) + (-> .getMainAttributes (doto (.put Attributes$Name/MAIN_CLASS (str (&host/->module-class module) "._")) + (.put Attributes$Name/MANIFEST_VERSION "1.0"))))) + +(defn ^:private write-class! [^String path ^File file ^JarOutputStream out] + "(-> Text File JarOutputStream Unit)" + (with-open [in (new BufferedInputStream (new FileInputStream file))] + (let [buffer (byte-array (* 10 kilobyte))] + (doto out + (.putNextEntry (new JarEntry (str path "/" (.getName file)))) + (-> (.write buffer 0 bytes-read) + (->> (when (not= -1 bytes-read)) + (loop [bytes-read (.read in buffer)]))) + (.flush) + (.closeEntry) + )) + )) + +(defn ^:private write-module! [^File file ^JarOutputStream out] + "(-> File JarOutputStream Unit)" + (let [module-name (.getName file)] + (doseq [$class (.listFiles file)] + (write-class! module-name $class out)))) + +;; [Resources] +(defn package [module] + "(-> Text (,))" + ;; (prn 'package module) + (with-open [out (new JarOutputStream (->> &&/output-package (new File) (new FileOutputStream)) (manifest module))] + (doseq [$group (.listFiles (new File &&/output-dir))] + (write-module! $group out)) + )) diff --git a/src/lux/compiler/type.clj b/src/lux/compiler/type.clj new file mode 100644 index 000000000..a92911444 --- /dev/null +++ b/src/lux/compiler/type.clj @@ -0,0 +1,97 @@ +;; 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.type + (:require [clojure.core.match :as M :refer [matchv]] + clojure.core.match.array + (lux [base :as & :refer [|do return* return fail fail* |let]] + [type :as &type]))) + +;; [Utils] +(defn ^:private variant$ [tag body] + "(-> Text Analysis Analysis)" + (&/T (&/V "variant" (&/T tag body)) + &type/$Void)) + +(defn ^:private tuple$ [members] + "(-> (List Analysis) Analysis)" + (&/T (&/V "tuple" members) + &type/$Void)) + +(defn ^:private text$ [text] + "(-> Text Analysis)" + (&/T (&/V "text" text) + &type/$Void)) + +(def ^:private $Nil + "Analysis" + (variant$ "lux;Nil" (tuple$ (&/|list)))) + +(defn ^:private Cons$ [head tail] + "(-> Analysis Analysis Analysis)" + (variant$ "lux;Cons" (tuple$ (&/|list head tail)))) + +;; [Exports] +(defn ->analysis [type] + "(-> Type Analysis)" + (matchv ::M/objects [type] + [["lux;DataT" ?class]] + (variant$ "lux;DataT" (text$ ?class)) + + [["lux;TupleT" ?members]] + (variant$ "lux;TupleT" + (&/fold (fn [tail head] + (Cons$ (->analysis head) tail)) + $Nil + (&/|reverse ?members))) + + [["lux;VariantT" ?cases]] + (variant$ "lux;VariantT" + (&/fold (fn [tail head] + (|let [[hlabel htype] head] + (Cons$ (tuple$ (&/|list (text$ hlabel) (->analysis htype))) + tail))) + $Nil + (&/|reverse ?cases))) + + [["lux;RecordT" ?slots]] + (variant$ "lux;RecordT" + (&/fold (fn [tail head] + (|let [[hlabel htype] head] + (Cons$ (tuple$ (&/|list (text$ hlabel) (->analysis htype))) + tail))) + $Nil + (&/|reverse ?slots))) + + [["lux;LambdaT" [?input ?output]]] + (variant$ "lux;LambdaT" (tuple$ (&/|list (->analysis ?input) (->analysis ?output)))) + + [["lux;AllT" [?env ?name ?arg ?body]]] + (variant$ "lux;AllT" + (tuple$ (&/|list (matchv ::M/objects [?env] + [["lux;None" _]] + (variant$ "lux;Some" (tuple$ (&/|list))) + + [["lux;Some" ??env]] + (variant$ "lux;Some" + (&/fold (fn [tail head] + (|let [[hlabel htype] head] + (Cons$ (tuple$ (&/|list (text$ hlabel) (->analysis htype))) + tail))) + $Nil + (&/|reverse ??env)))) + (text$ ?name) + (text$ ?arg) + (->analysis ?body)))) + + [["lux;BoundT" ?name]] + (variant$ "lux;BoundT" (text$ ?name)) + + [["lux;AppT" [?fun ?arg]]] + (variant$ "lux;AppT" (tuple$ (&/|list (->analysis ?fun) (->analysis ?arg)))) + )) diff --git a/src/lux/host.clj b/src/lux/host.clj index 80dfd78d5..906e3c714 100644 --- a/src/lux/host.clj +++ b/src/lux/host.clj @@ -1,3 +1,11 @@ +;; 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.host (:require (clojure [string :as string] [template :refer [do-template]]) @@ -10,6 +18,7 @@ ;; [Constants] (def prefix "lux.") (def function-class (str prefix "Function")) +(def module-separator "_") ;; [Utils] (defn ^:private class->type [^Class class] @@ -18,45 +27,26 @@ (str (.getName pkg) ".") "") (.getSimpleName class)))] - (if (= "void" base) - (return &type/$Void) + (if (.equals "void" base) + (return &type/Unit) (return (&/V "lux;DataT" (str (reduce str "" (repeat (int (/ (count arr-level) 2)) "[")) base))) ))) (defn ^:private method->type [^Method method] - (|do [;; =args (&/map% class->type (&/->list (seq (.getParameterTypes method)))) - =return (class->type (.getReturnType method))] - (return =return))) + (class->type (.getReturnType method))) ;; [Resources] -(defn full-class [class-name] - (case class-name - "boolean" (return Boolean/TYPE) - "byte" (return Byte/TYPE) - "short" (return Short/TYPE) - "int" (return Integer/TYPE) - "long" (return Long/TYPE) - "float" (return Float/TYPE) - "double" (return Double/TYPE) - "char" (return Character/TYPE) - ;; else - (try (return (Class/forName class-name)) - (catch Exception e - (fail (str "[Analyser Error] Unknown class: " class-name)))))) - -(defn full-class-name [class-name] - ;; (prn 'full-class-name class-name) - (|do [^Class =class (full-class class-name)] - (return (.getName =class)))) - (defn ^String ->class [class] (string/replace class #"\." "/")) -(def ->package ->class) +(defn ^String ->module-class [module-name] + (string/replace module-name #"/" module-separator)) + +(def ->package ->module-class) (defn ->type-signature [class] - (assert (string? class)) + ;; (assert (string? class)) (case class "void" "V" "boolean" "Z" @@ -82,58 +72,41 @@ [["lux;LambdaT" [_ _]]] (->type-signature function-class) - [["lux;VariantT" ["lux;Nil" _]]] + [["lux;TupleT" ["lux;Nil" _]]] "V" - - [_] - (assert false (prn-str '->java-sig (aget type 0))))) - -(defn extract-jvm-param [token] - (matchv ::M/objects [token] - [["lux;Meta" [_ ["lux;Symbol" [_ ?ident]]]]] - (full-class-name ?ident) - - [_] - (fail (str "[Host] Unknown JVM param: " (pr-str token))))) + )) (do-template [<name> <static?>] - (defn <name> [target field] - (let [target (Class/forName target)] - (if-let [type* (first (for [^Field =field (.getFields target) - :when (and (= target (.getDeclaringClass =field)) - (= field (.getName =field)) - (= <static?> (Modifier/isStatic (.getModifiers =field))))] - (.getType =field)))] - (|do [=type (class->type type*)] - (return =type)) - (fail (str "[Analyser Error] Field does not exist: " target field))))) + (defn <name> [class-loader target field] + (if-let [type* (first (for [^Field =field (.getDeclaredFields (Class/forName (&type/as-obj target) true class-loader)) + :when (and (.equals ^Object field (.getName =field)) + (.equals ^Object <static?> (Modifier/isStatic (.getModifiers =field))))] + (.getType =field)))] + (|do [=type (class->type type*)] + (return =type)) + (fail (str "[Analyser Error] Field does not exist: " target "." field)))) lookup-static-field true lookup-field false ) (do-template [<name> <static?>] - (defn <name> [target method-name args] - (let [target (Class/forName target)] - (if-let [method (first (for [^Method =method (.getMethods target) - ;; :let [_ (prn '<name> '=method =method (mapv #(.getName %) (.getParameterTypes =method)))] - :when (and (= target (.getDeclaringClass =method)) - (= method-name (.getName =method)) - (= <static?> (Modifier/isStatic (.getModifiers =method))) - (&/fold #(and %1 %2) - true - (&/|map (fn [xy] - (|let [[x y] xy] - (= x y))) - (&/zip2 args - (&/|map #(.getName ^Class %) (&/->list (seq (.getParameterTypes =method))))))))] - =method))] - (method->type method) - (fail (str "[Analyser Error] Method does not exist: " target method-name))))) + (defn <name> [class-loader target method-name args] + ;; (prn '<name> target method-name) + (if-let [method (first (for [^Method =method (.getDeclaredMethods (Class/forName (&type/as-obj target) true class-loader)) + :when (and (.equals ^Object method-name (.getName =method)) + (.equals ^Object <static?> (Modifier/isStatic (.getModifiers =method))) + (&/fold2 #(and %1 (.equals ^Object %2 %3)) + true + args + (&/|map #(.getName ^Class %) (&/->list (seq (.getParameterTypes =method))))))] + =method))] + (method->type method) + (fail (str "[Analyser Error] Method does not exist: " target "." method-name)))) lookup-static-method true lookup-virtual-method false ) (defn location [scope] - (->> scope (&/|map &/normalize-ident) (&/|interpose "$") (&/fold str ""))) + (->> scope (&/|map &/normalize-name) (&/|interpose "$") (&/fold str ""))) diff --git a/src/lux/lexer.clj b/src/lux/lexer.clj index b7729156a..bb6e54cb4 100644 --- a/src/lux/lexer.clj +++ b/src/lux/lexer.clj @@ -1,3 +1,11 @@ +;; 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.lexer (:require [clojure.template :refer [do-template]] (lux [base :as & :refer [|do return* return fail fail*]] @@ -6,120 +14,120 @@ ;; [Utils] (defn ^:private escape-char [escaped] - ;; (prn 'escape-char escaped) - (condp = escaped - "\\t" (return "\t") - "\\b" (return "\b") - "\\n" (return "\n") - "\\r" (return "\r") - "\\f" (return "\f") - "\\\"" (return "\"") - "\\\\" (return "\\") - ;; else - (fail (str "[Lexer Error] Unknown escape character: " escaped)))) + (cond (.equals ^Object escaped "\\t") (return "\t") + (.equals ^Object escaped "\\b") (return "\b") + (.equals ^Object escaped "\\n") (return "\n") + (.equals ^Object escaped "\\r") (return "\r") + (.equals ^Object escaped "\\f") (return "\f") + (.equals ^Object escaped "\\\"") (return "\"") + (.equals ^Object escaped "\\\\") (return "\\") + :else + (fail (str "[Lexer Error] Unknown escape character: " escaped)))) (defn ^:private lex-text-body [_] - (&/try-all% (&/|list (|do [[_ [_ [prefix escaped]]] (&reader/read-regex2 #"(?s)^([^\"\\]*)(\\.)") - ;; :let [_ (prn '[prefix escaped] [prefix escaped])] + (&/try-all% (&/|list (|do [[_ [prefix escaped]] (&reader/read-regex2 #"(?s)^([^\"\\]*)(\\.)") unescaped (escape-char escaped) - ;; :let [_ (prn 'unescaped unescaped)] - postfix (lex-text-body nil) - ;; :let [_ (prn 'postfix postfix)] - ] + postfix (lex-text-body nil)] (return (str prefix unescaped postfix))) - (|do [[_ [_ body]] (&reader/read-regex #"(?s)^([^\"\\]*)")] + (|do [[_ body] (&reader/read-regex #"(?s)^([^\"\\]*)")] (return body))))) -(def ^:private +ident-re+ #"^([a-zA-Z\-\+\_\=!@$%^&*<>\.,/\\\|'`:\~\?][0-9a-zA-Z\-\+\_\=!@$%^&*<>\.,/\\\|'`:\~\?]*)") +(def ^:private +ident-re+ #"^([a-zA-Z\-\+\_\=!@$%^&*<>\.,/\\\|'`:\~\?][0-9a-zA-Z\-\+\_\=!@$%^&*<>\.,/\\\|'`:\~\?]*)" + ;; #"^([^0-9\[\]\(\)\{\};#\s\"][^\[\]\(\)\{\};#\s\"]*)" + ) ;; [Lexers] (def ^:private lex-white-space - (|do [[_ [meta white-space]] (&reader/read-regex #"^(\s+)")] + (|do [[meta white-space] (&reader/read-regex #"^(\s+)")] (return (&/V "lux;Meta" (&/T meta (&/V "White_Space" white-space)))))) (def ^:private lex-single-line-comment - (|do [[_ [meta _]] (&reader/read-text "##") - [_ [_ comment]] (&reader/read-regex #"^(.*)$")] + (|do [_ (&reader/read-text "##") + [meta comment] (&reader/read-regex #"^(.*)$")] (return (&/V "lux;Meta" (&/T meta (&/V "Comment" comment)))))) (defn ^:private lex-multi-line-comment [_] (|do [_ (&reader/read-text "#(") - [meta comment] (&/try-all% (&/|list (|do [[_ [meta comment]] (&reader/read-regex #"(?is)^((?!#\().)*?(?=\)#)")] - (return comment)) - (|do [[_ [meta pre]] (&reader/read-regex #"(?is)^(.+?(?=#\())") - [_ inner] (lex-multi-line-comment nil) - [_ [_ post]] (&reader/read-regex #"(?is)^(.+?(?=\)#))")] - (return (str pre "#(" inner ")#" post))))) - _ (&reader/read-text ")#")] + [meta comment] (&/try-all% (&/|list (|do [[meta comment] (&reader/read-regex #"(?is)^(?!#\()(.*?(?=\)#))") + ;; :let [_ (prn 'immediate comment)] + _ (&reader/read-text ")#")] + (return (&/T meta comment))) + (|do [;; :let [_ (prn 'pre/_0)] + [meta pre] (&reader/read-regex+ #"(?is)^(.*?)(#\(|$)") + ;; :let [_ (prn 'pre pre)] + [_ inner] (lex-multi-line-comment nil) + ;; :let [_ (prn 'inner inner)] + [_ post] (&reader/read-regex #"(?is)^(.+?(?=\)#))") + ;; :let [_ (prn 'post post (str pre "#(" inner ")#" post))] + ] + (return (&/T meta (str pre "#(" inner ")#" post)))))) + ;; :let [_ (prn 'lex-multi-line-comment (str comment ")#"))] + _ (&reader/read-text ")#")] (return (&/V "lux;Meta" (&/T meta (&/V "Comment" comment)))))) (def ^:private lex-comment (&/try-all% (&/|list lex-single-line-comment - ;; (lex-multi-line-comment nil) - ))) + (lex-multi-line-comment nil)))) (do-template [<name> <tag> <regex>] (def <name> - (|do [[_ [meta token]] (&reader/read-regex <regex>)] + (|do [[meta token] (&reader/read-regex <regex>)] (return (&/V "lux;Meta" (&/T meta (&/V <tag> token)))))) ^:private lex-bool "Bool" #"^(true|false)" - ^:private lex-int "Int" #"^-?(0|[1-9][0-9]*)" - ^:private lex-real "Real" #"^-?(0|[1-9][0-9]*)\.[0-9]+" + ^:private lex-int "Int" #"^(-?0|-?[1-9][0-9]*)" + ^:private lex-real "Real" #"^-?(-?0\.[0-9]+|-?[1-9][0-9]*\.[0-9]+)" ) (def ^:private lex-char - (|do [[_ [meta _]] (&reader/read-text "#\"") - token (&/try-all% (&/|list (|do [[_ [_ escaped]] (&reader/read-regex #"^(\\.)")] - (escape-char escaped)) - (|do [[_ [_ char]] (&reader/read-regex #"^(.)")] - (return char)))) - _ (&reader/read-text "\"")] + (|do [[meta _] (&reader/read-text "#\"") + token (&/try-all% (&/|list (|do [[_ escaped] (&reader/read-regex #"^(\\.)")] + (escape-char escaped)) + (|do [[_ char] (&reader/read-regex #"^(.)")] + (return char)))) + _ (&reader/read-text "\"")] (return (&/V "lux;Meta" (&/T meta (&/V "Char" token)))))) (def ^:private lex-text - (|do [[_ [meta _]] (&reader/read-text "\"") - token (lex-text-body nil) - _ (&reader/read-text "\"")] + (|do [[meta _] (&reader/read-text "\"") + token (lex-text-body nil) + _ (&reader/read-text "\"")] (return (&/V "lux;Meta" (&/T meta (&/V "Text" token)))))) (def ^:private lex-ident - (&/try-all% (&/|list (|do [[_ [meta token]] (&reader/read-regex +ident-re+)] + (&/try-all% (&/|list (|do [[meta token] (&reader/read-regex +ident-re+)] (&/try-all% (&/|list (|do [_ (&reader/read-text ";") - [_ [_ local-token]] (&reader/read-regex +ident-re+)] - (&/try-all% (&/|list (|do [unaliased (&module/dealias token)] - (return (&/V "lux;Meta" (&/T meta (&/T unaliased local-token))))) - (|do [? (&module/exists? token)] - (if ? - (return (&/V "lux;Meta" (&/T meta (&/T token local-token)))) - (fail (str "[Lexer Error] Unknown module: " token)))) - ))) - (return (&/V "lux;Meta" (&/T meta (&/T "" token)))) + [_ local-token] (&reader/read-regex +ident-re+) + ? (&module/exists? token)] + (if ? + (return (&/T meta (&/T token local-token))) + (|do [unaliased (do ;; (prn "Unaliasing: " token ";" local-token) + (&module/dealias token))] + (do ;; (prn "Unaliased: " unaliased ";" local-token) + (return (&/T meta (&/T unaliased local-token))))))) + (return (&/T meta (&/T "" token))) ))) - (|do [[_ [meta _]] (&reader/read-text ";;") - [_ [_ token]] (&reader/read-regex +ident-re+) + (|do [[meta _] (&reader/read-text ";;") + [_ token] (&reader/read-regex +ident-re+) module-name &/get-module-name] - (return (&/V "lux;Meta" (&/T meta (&/T module-name token))))) - (|do [[_ [meta _]] (&reader/read-text ";") - [_ [_ token]] (&reader/read-regex +ident-re+)] - (return (&/V "lux;Meta" (&/T meta (&/T "lux" token))))) + (return (&/T meta (&/T module-name token)))) + (|do [[meta _] (&reader/read-text ";") + [_ token] (&reader/read-regex +ident-re+)] + (return (&/T meta (&/T "lux" token)))) ))) (def ^:private lex-symbol - (|do [[_ [meta ident]] lex-ident] + (|do [[meta ident] lex-ident] (return (&/V "lux;Meta" (&/T meta (&/V "Symbol" ident)))))) (def ^:private lex-tag - (|do [[_ [meta _]] (&reader/read-text "#") - ;; :let [_ (prn 'lex-tag)] - [_ [_ ident]] lex-ident - ;; :let [_ (prn 'lex-tag [(aget ident 0) (aget ident 1)])] - ] + (|do [[meta _] (&reader/read-text "#") + [_ ident] lex-ident] (return (&/V "lux;Meta" (&/T meta (&/V "Tag" ident)))))) (do-template [<name> <text> <tag>] (def <name> - (|do [[_ [meta _]] (&reader/read-text <text>)] + (|do [[meta _] (&reader/read-text <text>)] (return (&/V "lux;Meta" (&/T meta (&/V <tag> nil)))))) ^:private lex-open-paren "(" "Open_Paren" diff --git a/src/lux/optimizer.clj b/src/lux/optimizer.clj index e50d2aae9..5056a09e0 100644 --- a/src/lux/optimizer.clj +++ b/src/lux/optimizer.clj @@ -1,3 +1,11 @@ +;; 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.optimizer (:require [lux.analyser :as &analyser])) @@ -12,8 +20,7 @@ ;; Pre-compute constant expressions: Find function calls for which all arguments are known at compile-time and pre-calculate everything prior to compilation. ;; Convert pattern-matching on booleans into regular if-then-else structures ;; Local var aliasing. -;; Global var aliasing. ;; [Exports] -(defn optimize [eval!] - (&analyser/analyse eval!)) +(defn optimize [eval! compile-module] + (&analyser/analyse eval! compile-module)) diff --git a/src/lux/parser.clj b/src/lux/parser.clj index cb89f63a2..966c322bf 100644 --- a/src/lux/parser.clj +++ b/src/lux/parser.clj @@ -1,3 +1,11 @@ +;; 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.parser (:require [clojure.template :refer [do-template]] [clojure.core.match :as M :refer [matchv]] @@ -17,24 +25,18 @@ [_] (fail (str "[Parser Error] Unbalanced " <description> "."))))) - ^:private parse-form "Close_Paren" "parantheses" "lux;Form" - ^:private parse-tuple "Close_Bracket" "brackets" "lux;Tuple" + ^:private parse-form "Close_Paren" "parantheses" "lux;FormS" + ^:private parse-tuple "Close_Bracket" "brackets" "lux;TupleS" ) (defn ^:private parse-record [parse] - (|do [;; :let [_ (prn 'parse-record 0)] - elems* (&/repeat% parse) - ;; :let [_ (prn 'parse-record 1)] + (|do [elems* (&/repeat% parse) token &lexer/lex - ;; :let [_ (prn 'parse-record 2)] - :let [elems (&/fold &/|++ (&/|list) elems*)] - ;; :let [_ (prn 'parse-record 3)] - ] + :let [elems (&/fold &/|++ (&/|list) elems*)]] (matchv ::M/objects [token] [["lux;Meta" [meta ["Close_Brace" _]]]] (if (even? (&/|length elems)) - (do ;; (prn 'PARSED_RECORD (&/|length elems)) - (return (&/V "lux;Record" (&/|as-pairs elems)))) + (return (&/V "lux;RecordS" (&/|as-pairs elems))) (fail (str "[Parser Error] Records must have an even number of elements."))) [_] @@ -42,50 +44,49 @@ ;; [Interface] (def parse - (|do [token &lexer/lex - ;; :let [_ (prn 'parse/token token)] - ;; :let [_ (prn 'parse (aget token 0))] - ] + (|do [token &lexer/lex] (matchv ::M/objects [token] - [["lux;Meta" [meta ["White_Space" _]]]] - (return (&/|list)) + [["lux;Meta" [meta token*]]] + (matchv ::M/objects [token*] + [["White_Space" _]] + (return (&/|list)) - [["lux;Meta" [meta ["Comment" _]]]] - (return (&/|list)) - - [["lux;Meta" [meta ["Bool" ?value]]]] - (return (&/|list (&/V "lux;Meta" (&/T meta (&/V "lux;Bool" (Boolean/parseBoolean ?value)))))) + [["Comment" _]] + (return (&/|list)) + + [["Bool" ?value]] + (return (&/|list (&/V "lux;Meta" (&/T meta (&/V "lux;BoolS" (Boolean/parseBoolean ?value)))))) - [["lux;Meta" [meta ["Int" ?value]]]] - (return (&/|list (&/V "lux;Meta" (&/T meta (&/V "lux;Int" (Integer/parseInt ?value)))))) + [["Int" ?value]] + (return (&/|list (&/V "lux;Meta" (&/T meta (&/V "lux;IntS" (Integer/parseInt ?value)))))) - [["lux;Meta" [meta ["Real" ?value]]]] - (return (&/|list (&/V "lux;Meta" (&/T meta (&/V "lux;Real" (Float/parseFloat ?value)))))) + [["Real" ?value]] + (return (&/|list (&/V "lux;Meta" (&/T meta (&/V "lux;RealS" (Float/parseFloat ?value)))))) - [["lux;Meta" [meta ["Char" ^String ?value]]]] - (return (&/|list (&/V "lux;Meta" (&/T meta (&/V "lux;Char" (.charAt ?value 0)))))) + [["Char" ^String ?value]] + (return (&/|list (&/V "lux;Meta" (&/T meta (&/V "lux;CharS" (.charAt ?value 0)))))) - [["lux;Meta" [meta ["Text" ?value]]]] - (return (&/|list (&/V "lux;Meta" (&/T meta (&/V "lux;Text" ?value))))) + [["Text" ?value]] + (return (&/|list (&/V "lux;Meta" (&/T meta (&/V "lux;TextS" ?value))))) - [["lux;Meta" [meta ["Symbol" ?ident]]]] - (return (&/|list (&/V "lux;Meta" (&/T meta (&/V "lux;Symbol" ?ident))))) + [["Symbol" ?ident]] + (return (&/|list (&/V "lux;Meta" (&/T meta (&/V "lux;SymbolS" ?ident))))) - [["lux;Meta" [meta ["Tag" ?ident]]]] - (return (&/|list (&/V "lux;Meta" (&/T meta (&/V "lux;Tag" ?ident))))) + [["Tag" ?ident]] + (return (&/|list (&/V "lux;Meta" (&/T meta (&/V "lux;TagS" ?ident))))) - [["lux;Meta" [meta ["Open_Paren" _]]]] - (|do [syntax (parse-form parse)] - (return (&/|list (&/V "lux;Meta" (&/T meta syntax))))) - - [["lux;Meta" [meta ["Open_Bracket" _]]]] - (|do [syntax (parse-tuple parse)] - (return (&/|list (&/V "lux;Meta" (&/T meta syntax))))) + [["Open_Paren" _]] + (|do [syntax (parse-form parse)] + (return (&/|list (&/V "lux;Meta" (&/T meta syntax))))) + + [["Open_Bracket" _]] + (|do [syntax (parse-tuple parse)] + (return (&/|list (&/V "lux;Meta" (&/T meta syntax))))) - [["lux;Meta" [meta ["Open_Brace" _]]]] - (|do [syntax (parse-record parse)] - (return (&/|list (&/V "lux;Meta" (&/T meta syntax))))) + [["Open_Brace" _]] + (|do [syntax (parse-record parse)] + (return (&/|list (&/V "lux;Meta" (&/T meta syntax))))) - [_] - (fail "[Parser Error] Unknown lexer token.") - ))) + [_] + (fail "[Parser Error] Unknown lexer token.") + )))) diff --git a/src/lux/reader.clj b/src/lux/reader.clj index d66a671aa..9fd9b14ea 100644 --- a/src/lux/reader.clj +++ b/src/lux/reader.clj @@ -1,3 +1,11 @@ +;; 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.reader (:require [clojure.string :as string] [clojure.core.match :as M :refer [matchv]] @@ -8,93 +16,131 @@ (defn ^:private with-line [body] (fn [state] (matchv ::M/objects [(&/get$ &/$SOURCE state)] - [["lux;None" _]] - (fail* "[Reader Error] No source code.") - - [["lux;Some" ["lux;Nil" _]]] + [["lux;Nil" _]] (fail* "[Reader Error] EOF") - [["lux;Some" ["lux;Cons" [["lux;Meta" [[file-name line-num column-num] line]] - more]]]] + [["lux;Cons" [[[file-name line-num column-num] line] + more]]] (matchv ::M/objects [(body file-name line-num column-num line)] [["No" msg]] (fail* msg) - [["Yes" [meta ["lux;None" _]]]] - (return* (&/set$ &/$SOURCE (&/V "lux;Some" more) state) - meta) + [["Done" output]] + (return* (&/set$ &/$SOURCE more state) + output) + + [["Yes" [output line*]]] + (return* (&/set$ &/$SOURCE (&/|cons line* more) state) + output)) + ))) + +(defn ^:private with-lines [body] + (fn [state] + (matchv ::M/objects [(body (&/get$ &/$SOURCE state))] + [["lux;Right" [reader* match]]] + (return* (&/set$ &/$SOURCE reader* state) + match) - [["Yes" [meta ["lux;Some" line-meta]]]] - (return* (&/set$ &/$SOURCE (&/V "lux;Some" (&/|cons line-meta more)) state) - meta)) + [["lux;Left" msg]] + (fail* msg) ))) ;; [Exports] +(defn ^:private re-find! [^java.util.regex.Pattern regex column ^String line] + (let [matcher (doto (.matcher regex line) + (.region column (.length line)) + (.useAnchoringBounds true))] + (when (.find matcher) + (.group matcher 0)))) + +(defn ^:private re-find1! [^java.util.regex.Pattern regex column ^String line] + (let [matcher (doto (.matcher regex line) + (.region column (.length line)) + (.useAnchoringBounds true))] + (when (.find matcher) + (.group matcher 1)))) + +(defn ^:private re-find3! [^java.util.regex.Pattern regex column ^String line] + (let [matcher (doto (.matcher regex line) + (.region column (.length line)) + (.useAnchoringBounds true))] + (when (.find matcher) + (list (.group matcher 0) + (.group matcher 1) + (.group matcher 2))))) + (defn read-regex [regex] (with-line (fn [file-name line-num column-num ^String line] - (if-let [[^String match] (re-find regex line)] - (let [match-length (.length match) - line* (.substring line match-length) - ;; _ (prn 'with-line line*) - ] - (&/V "Yes" (&/T (&/V "lux;Meta" (&/T (&/T file-name line-num column-num) match)) - (if (empty? line*) - (&/V "lux;None" nil) - (&/V "lux;Some" (&/V "lux;Meta" (&/T (&/T file-name line-num (+ column-num match-length)) line*))))))) + ;; (prn 'read-regex [file-name line-num column-num regex line]) + (if-let [^String match (do ;; (prn '[regex line] [regex line]) + (re-find! regex column-num line))] + (let [;; _ (prn 'match match) + match-length (.length match) + column-num* (+ column-num match-length)] + (if (= column-num* (.length line)) + (&/V "Done" (&/T (&/T file-name line-num column-num) match)) + (&/V "Yes" (&/T (&/T (&/T file-name line-num column-num) match) + (&/T (&/T file-name line-num column-num*) line))))) (&/V "No" (str "[Reader Error] Pattern failed: " regex)))))) (defn read-regex2 [regex] (with-line (fn [file-name line-num column-num ^String line] - (if-let [[^String match tok1 tok2] (re-find regex line)] + ;; (prn 'read-regex2 [file-name line-num column-num regex line]) + (if-let [[^String match tok1 tok2] (re-find3! regex column-num line)] (let [match-length (.length match) - line* (.substring line match-length) - ;; _ (prn 'with-line line*) - ] - (&/V "Yes" (&/T (&/V "lux;Meta" (&/T (&/T file-name line-num column-num) (&/T tok1 tok2))) - (if (empty? line*) - (&/V "lux;None" nil) - (&/V "lux;Some" (&/V "lux;Meta" (&/T (&/T file-name line-num (+ column-num match-length)) line*))))))) + column-num* (+ column-num match-length)] + (if (= column-num* (.length line)) + (&/V "Done" (&/T (&/T file-name line-num column-num) (&/T tok1 tok2))) + (&/V "Yes" (&/T (&/T (&/T file-name line-num column-num) (&/T tok1 tok2)) + (&/T (&/T file-name line-num column-num*) line))))) (&/V "No" (str "[Reader Error] Pattern failed: " regex)))))) +(defn read-regex+ [regex] + (with-lines + (fn [reader] + (loop [prefix "" + reader* reader] + (matchv ::M/objects [reader*] + [["lux;Nil" _]] + (&/V "lux;Left" "[Reader Error] EOF") + + [["lux;Cons" [[[file-name line-num column-num] ^String line] + reader**]]] + (if-let [^String match (do ;; (prn 'read-regex+ regex line) + (re-find1! regex column-num line))] + (let [match-length (.length match) + column-num* (+ column-num match-length)] + (if (= column-num* (.length line)) + (recur (str prefix match "\n") reader**) + (&/V "lux;Right" (&/T (&/|cons (&/T (&/T file-name line-num column-num*) line) + reader**) + (&/T (&/T file-name line-num column-num) (str prefix match)))))) + (&/V "lux;Left" (str "[Reader Error] Pattern failed: " regex)))))))) + (defn read-text [^String text] (with-line (fn [file-name line-num column-num ^String line] - ;; (prn 'read-text text line) - (if (.startsWith line text) + ;; (prn 'read-text [file-name line-num column-num text line]) + (if (.startsWith line text column-num) (let [match-length (.length text) - line* (.substring line match-length) - ;; _ (prn 'with-line line*) - ] - (&/V "Yes" (&/T (&/V "lux;Meta" (&/T (&/T file-name line-num column-num) text)) - (if (empty? line*) - (&/V "lux;None" nil) - (&/V "lux;Some" (&/V "lux;Meta" (&/T (&/T file-name line-num (+ column-num match-length)) line*))))))) + column-num* (+ column-num match-length)] + (if (= column-num* (.length line)) + (&/V "Done" (&/T (&/T file-name line-num column-num) text)) + (&/V "Yes" (&/T (&/T (&/T file-name line-num column-num) text) + (&/T (&/T file-name line-num column-num*) line))))) (&/V "No" (str "[Reader Error] Text failed: " text)))))) -(defn from [file-name] - (let [lines (&/->list (string/split-lines (slurp file-name)))] +(def ^:private ^String +source-dir+ "input/") +(defn from [^String file-name ^String file-content] + (let [lines (&/->list (string/split-lines file-content)) + file-name (.substring file-name (.length +source-dir+))] (&/|map (fn [line+line-num] - (|let [[line line-num] line+line-num] - (&/V "lux;Meta" (&/T (&/T file-name line-num 0) - line)))) + (|let [[line-num line] line+line-num] + (&/T (&/T file-name (inc line-num) 0) + line))) (&/|filter (fn [line+line-num] - (|let [[line line-num] line+line-num] - (not (empty? line)))) - (&/zip2 lines - (&/|range (&/|length lines))))))) - -(def current-line - (fn [state] - (matchv ::M/objects [(&/get$ &/$SOURCE state)] - [["lux;None" _]] - (fail* "[Reader Error] No source code.") - - [["lux;Some" ["lux;Nil" _]]] - (fail* "[Reader Error] EOF") - - [["lux;Some" ["lux;Cons" [["lux;Meta" [_ line]] - more]]]] - (return* state line) - ))) + (|let [[line-num line] line+line-num] + (not= "" line))) + (&/enumerate lines))))) diff --git a/src/lux/type.clj b/src/lux/type.clj index 0df628b15..f5b8d3f25 100644 --- a/src/lux/type.clj +++ b/src/lux/type.clj @@ -1,3 +1,11 @@ +;; 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.type (:refer-clojure :exclude [deref apply merge bound?]) (:require [clojure.core.match :as M :refer [match matchv]] @@ -15,15 +23,19 @@ (def Unit (&/V "lux;TupleT" (&/|list))) (def $Void (&/V "lux;VariantT" (&/|list))) +(def IO + (&/V "lux;AllT" (&/T (&/V "lux;Some" (&/V "lux;Nil" nil)) "IO" "a" + (&/V "lux;LambdaT" (&/T Unit (&/V "lux;BoundT" "a")))))) + (def List - (&/V "lux;AllT" (&/T (&/V "lux;None" nil) "List" "a" + (&/V "lux;AllT" (&/T (&/V "lux;Some" (&/V "lux;Nil" nil)) "lux;List" "a" (&/V "lux;VariantT" (&/|list (&/T "lux;Nil" Unit) (&/T "lux;Cons" (&/V "lux;TupleT" (&/|list (&/V "lux;BoundT" "a") - (&/V "lux;AppT" (&/T (&/V "lux;BoundT" "List") + (&/V "lux;AppT" (&/T (&/V "lux;BoundT" "lux;List") (&/V "lux;BoundT" "a"))))))))))) (def Maybe - (&/V "lux;AllT" (&/T (&/V "lux;None" nil) "Maybe" "a" + (&/V "lux;AllT" (&/T (&/V "lux;Some" (&/V "lux;Nil" nil)) "lux;Maybe" "a" (&/V "lux;VariantT" (&/|list (&/T "lux;None" Unit) (&/T "lux;Some" (&/V "lux;BoundT" "a"))))))) @@ -31,7 +43,7 @@ (let [Type (&/V "lux;AppT" (&/T (&/V "lux;BoundT" "Type") (&/V "lux;BoundT" "_"))) TypeEnv (&/V "lux;AppT" (&/T List (&/V "lux;TupleT" (&/|list Text Type)))) TypePair (&/V "lux;TupleT" (&/|list Type Type))] - (&/V "lux;AppT" (&/T (&/V "lux;AllT" (&/T (&/V "lux;None" nil) "Type" "_" + (&/V "lux;AppT" (&/T (&/V "lux;AllT" (&/T (&/V "lux;Some" (&/V "lux;Nil" nil)) "Type" "_" (&/V "lux;VariantT" (&/|list (&/T "lux;DataT" Text) (&/T "lux;TupleT" (&/V "lux;AppT" (&/T List Type))) (&/T "lux;VariantT" TypeEnv) @@ -49,7 +61,7 @@ (&/V "lux;AllT" (&/T (&/V "lux;None" nil) name arg body))) (def Bindings - (fAll "Bindings" "k" + (fAll "lux;Bindings" "k" (fAll "" "v" (&/V "lux;RecordT" (&/|list (&/T "lux;counter" Int) (&/T "lux;mappings" (&/V "lux;AppT" (&/T List @@ -59,7 +71,7 @@ (def Env (let [bindings (&/V "lux;AppT" (&/T (&/V "lux;AppT" (&/T Bindings (&/V "lux;BoundT" "k"))) (&/V "lux;BoundT" "v")))] - (fAll "Env" "k" + (fAll "lux;Env" "k" (fAll "" "v" (&/V "lux;RecordT" (&/|list (&/T "lux;name" Text) @@ -72,7 +84,7 @@ (&/V "lux;TupleT" (&/|list Text Int Int))) (def Meta - (fAll "Meta" "m" + (fAll "lux;Meta" "m" (fAll "" "v" (&/V "lux;VariantT" (&/|list (&/T "lux;Meta" (&/V "lux;TupleT" (&/|list (&/V "lux;BoundT" "m") (&/V "lux;BoundT" "v"))))))))) @@ -81,20 +93,20 @@ (def Syntax* (let [Syntax* (&/V "lux;AppT" (&/T (&/V "lux;BoundT" "w") - (&/V "lux;AppT" (&/T (&/V "lux;BoundT" "Syntax'") + (&/V "lux;AppT" (&/T (&/V "lux;BoundT" "lux;Syntax'") (&/V "lux;BoundT" "w"))))) Syntax*List (&/V "lux;AppT" (&/T List Syntax*))] - (fAll "Syntax'" "w" - (&/V "lux;VariantT" (&/|list (&/T "lux;Bool" Bool) - (&/T "lux;Int" Int) - (&/T "lux;Real" Real) - (&/T "lux;Char" Char) - (&/T "lux;Text" Text) - (&/T "lux;Symbol" Ident) - (&/T "lux;Tag" Ident) - (&/T "lux;Form" Syntax*List) - (&/T "lux;Tuple" Syntax*List) - (&/T "lux;Record" (&/V "lux;AppT" (&/T List (&/V "lux;TupleT" (&/|list Syntax* Syntax*)))))) + (fAll "lux;Syntax'" "w" + (&/V "lux;VariantT" (&/|list (&/T "lux;BoolS" Bool) + (&/T "lux;IntS" Int) + (&/T "lux;RealS" Real) + (&/T "lux;CharS" Char) + (&/T "lux;TextS" Text) + (&/T "lux;SymbolS" Ident) + (&/T "lux;TagS" Ident) + (&/T "lux;FormS" Syntax*List) + (&/T "lux;TupleS" Syntax*List) + (&/T "lux;RecordS" (&/V "lux;AppT" (&/T List (&/V "lux;TupleT" (&/|list Syntax* Syntax*)))))) )))) (def Syntax @@ -104,13 +116,13 @@ (def ^:private SyntaxList (&/V "lux;AppT" (&/T List Syntax))) (def Either - (fAll "_" "l" + (fAll "lux;Either" "l" (fAll "" "r" (&/V "lux;VariantT" (&/|list (&/T "lux;Left" (&/V "lux;BoundT" "l")) (&/T "lux;Right" (&/V "lux;BoundT" "r"))))))) (def StateE - (fAll "StateE" "s" + (fAll "lux;StateE" "s" (fAll "" "a" (&/V "lux;LambdaT" (&/T (&/V "lux;BoundT" "s") (&/V "lux;AppT" (&/T (&/V "lux;AppT" (&/T Either Text)) @@ -126,10 +138,10 @@ (&/V "lux;RecordT" (&/|list (&/T "lux;writer" (&/V "lux;DataT" "org.objectweb.asm.ClassWriter")) (&/T "lux;loader" (&/V "lux;DataT" "java.lang.ClassLoader")) - (&/T "lux;eval-ctor" Int)))) + (&/T "lux;classes" (&/V "lux;DataT" "clojure.lang.Atom"))))) (def DefData* - (fAll "DefData'" "" + (fAll "lux;DefData'" "" (&/V "lux;VariantT" (&/|list (&/T "lux;TypeD" Unit) (&/T "lux;ValueD" Type) (&/T "lux;MacroD" (&/V "lux;BoundT" "")) @@ -139,32 +151,38 @@ (&/V "lux;VariantT" (&/|list (&/T "lux;Local" Int) (&/T "lux;Global" Ident)))) -(def CompilerState - (&/V "lux;AppT" (&/T (fAll "CompilerState" "" +(def $Module + (fAll "lux;$Module" "Compiler" + (&/V "lux;RecordT" + (&/|list (&/T "lux;module-aliases" (&/V "lux;AppT" (&/T List (&/V "lux;TupleT" (&/|list Text Text))))) + (&/T "lux;defs" (&/V "lux;AppT" (&/T List (&/V "lux;TupleT" + (&/|list Text + (&/V "lux;TupleT" (&/|list Bool + (&/V "lux;AppT" (&/T DefData* + (&/V "lux;LambdaT" (&/T SyntaxList + (&/V "lux;AppT" (&/T (&/V "lux;AppT" (&/T StateE (&/V "lux;BoundT" "Compiler"))) + SyntaxList))))))))))))) + (&/T "lux;imports" (&/V "lux;AppT" (&/T List Text))))))) + +(def $Compiler + (&/V "lux;AppT" (&/T (fAll "lux;Compiler" "" (&/V "lux;RecordT" - (&/|list (&/T "lux;source" (&/V "lux;AppT" (&/T Maybe Reader))) + (&/|list (&/T "lux;source" Reader) (&/T "lux;modules" (&/V "lux;AppT" (&/T List (&/V "lux;TupleT" (&/|list Text - (&/V "lux;AppT" (&/T List (&/V "lux;TupleT" - (&/|list Text - (&/V "lux;TupleT" (&/|list Bool - (&/V "lux;AppT" (&/T DefData* - (&/V "lux;LambdaT" (&/T SyntaxList - (&/V "lux;AppT" (&/T (&/V "lux;AppT" (&/T StateE (&/V "lux;AppT" (&/T (&/V "lux;BoundT" "CompilerState") - (&/V "lux;BoundT" ""))))) - SyntaxList))))))))))))))))) - (&/T "lux;module-aliases" (&/V "lux;AppT" (&/T List $Void))) + (&/V "lux;AppT" (&/T $Module (&/V "lux;AppT" (&/T (&/V "lux;BoundT" "lux;Compiler") (&/V "lux;BoundT" "")))))))))) (&/T "lux;envs" (&/V "lux;AppT" (&/T List (&/V "lux;AppT" (&/T (&/V "lux;AppT" (&/T Env Text)) (&/V "lux;TupleT" (&/|list LuxVar Type))))))) (&/T "lux;types" (&/V "lux;AppT" (&/T (&/V "lux;AppT" (&/T Bindings Int)) Type))) (&/T "lux;host" HostState) - (&/T "lux;seed" Int)))) + (&/T "lux;seed" Int) + (&/T "lux;eval?" Bool)))) $Void))) (def Macro (&/V "lux;LambdaT" (&/T SyntaxList - (&/V "lux;AppT" (&/T (&/V "lux;AppT" (&/T StateE CompilerState)) + (&/V "lux;AppT" (&/T (&/V "lux;AppT" (&/T StateE $Compiler)) SyntaxList))))) (defn bound? [id] @@ -180,39 +198,27 @@ (defn deref [id] (fn [state] - (let [mappings (->> state (&/get$ &/$TYPES) (&/get$ &/$MAPPINGS))] - (if-let [type* (->> mappings (&/|get id))] - (matchv ::M/objects [type*] - [["lux;Some" type]] - (return* state type) - - [["lux;None" _]] - (fail* (str "[Type Error] Unbound type-var: " id))) - (fail* (str "[Type Error] <deref> Unknown type-var: " id)))))) - -(defn set-var* [id type] - (fn [state] - (if-let [tvar (->> state (&/get$ &/$TYPES) (&/get$ &/$MAPPINGS) (&/|get id))] - (return* (&/update$ &/$TYPES (fn [ts] (&/update$ &/$MAPPINGS #(&/|put id (&/V "lux;Some" type) %) - ts)) - state) - nil) - (fail* (str "[Type Error] <set-var> Unknown type-var: " id " | " (->> state (&/get$ &/$TYPES) (&/get$ &/$MAPPINGS) &/|length)))))) + (if-let [type* (->> state (&/get$ &/$TYPES) (&/get$ &/$MAPPINGS) (&/|get id))] + (matchv ::M/objects [type*] + [["lux;Some" type]] + (return* state type) + + [["lux;None" _]] + (fail* (str "[Type Error] Unbound type-var: " id))) + (fail* (str "[Type Error] <deref> Unknown type-var: " id))))) (defn set-var [id type] (fn [state] (if-let [tvar (->> state (&/get$ &/$TYPES) (&/get$ &/$MAPPINGS) (&/|get id))] - (do ;; (prn 'set-var (aget tvar 0)) - (matchv ::M/objects [tvar] - [["lux;Some" bound]] - (fail* (str "[Type Error] Can't rebind type var: " id " | Current type: " (show-type bound))) - - [["lux;None" _]] - (do ;; (prn 'set-var id (show-type type)) - (return* (&/update$ &/$TYPES (fn [ts] (&/update$ &/$MAPPINGS #(&/|put id (&/V "lux;Some" type) %) - ts)) - state) - nil)))) + (matchv ::M/objects [tvar] + [["lux;Some" bound]] + (fail* (str "[Type Error] Can't rebind type var: " id " | Current type: " (show-type bound))) + + [["lux;None" _]] + (return* (&/update$ &/$TYPES (fn [ts] (&/update$ &/$MAPPINGS #(&/|put id (&/V "lux;Some" type) %) + ts)) + state) + nil)) (fail* (str "[Type Error] <set-var> Unknown type-var: " id " | " (->> state (&/get$ &/$TYPES) (&/get$ &/$MAPPINGS) &/|length)))))) ;; [Exports] @@ -221,8 +227,8 @@ (fn [state] (let [id (->> state (&/get$ &/$TYPES) (&/get$ &/$COUNTER))] (return* (&/update$ &/$TYPES #(->> % - (&/update$ &/$COUNTER inc) - (&/update$ &/$MAPPINGS (fn [ms] (&/|put id (&/V "lux;None" nil) ms)))) + (&/update$ &/$COUNTER inc) + (&/update$ &/$MAPPINGS (fn [ms] (&/|put id (&/V "lux;None" nil) ms)))) state) id)))) @@ -238,36 +244,33 @@ (|do [ex existential] (set-var id ex)))] (fn [state] - (&/run-state (|do [mappings* (&/map% (fn [binding] - (|let [[?id ?type] binding] - (if (= id ?id) - (return binding) - (matchv ::M/objects [?type] - [["lux;None" _]] - (return binding) + ((|do [mappings* (&/map% (fn [binding] + (|let [[?id ?type] binding] + (if (.equals ^Object id ?id) + (return binding) + (matchv ::M/objects [?type] + [["lux;None" _]] + (return binding) - [["lux;Some" ?type*]] - (matchv ::M/objects [?type*] - [["lux;VarT" ?id*]] - (if (= id ?id*) - (return (&/T ?id (&/V "lux;None" nil))) - (return binding) - ;; (|do [?type** (clean* id ?type*)] - ;; (return (&/T ?id (&/V "lux;Some" ?type**)))) - ) + [["lux;Some" ?type*]] + (matchv ::M/objects [?type*] + [["lux;VarT" ?id*]] + (if (.equals ^Object id ?id*) + (return (&/T ?id (&/V "lux;None" nil))) + (return binding)) - [_] - (|do [?type** (clean* id ?type*)] - (return (&/T ?id (&/V "lux;Some" ?type**))))) - )))) - (->> state (&/get$ &/$TYPES) (&/get$ &/$MAPPINGS)))] - (fn [state] - (return* (&/update$ &/$TYPES #(->> % - (&/update$ &/$COUNTER dec) - (&/set$ &/$MAPPINGS (&/|remove id mappings*))) - state) - nil))) - state)))) + [_] + (|do [?type** (clean* id ?type*)] + (return (&/T ?id (&/V "lux;Some" ?type**))))) + )))) + (->> state (&/get$ &/$TYPES) (&/get$ &/$MAPPINGS)))] + (fn [state] + (return* (&/update$ &/$TYPES #(->> % + (&/update$ &/$COUNTER dec) + (&/set$ &/$MAPPINGS (&/|remove id mappings*))) + state) + nil))) + state)))) (defn with-var [k] (|do [id create-var @@ -275,23 +278,17 @@ _ (delete-var id)] (return output))) -;; (def delete-vars -;; (|do [vars #(->> % (&/get$ &/$TYPES) (&/get$ &/$MAPPINGS) &/|keys (return* %)) -;; _ (&/map% delete-var vars)] -;; (return nil))) - (defn with-vars [amount k] (|do [=vars (&/map% (constantly create-var) (&/|range amount)) output (k (&/|map #(&/V "lux;VarT" %) =vars)) _ (&/map% delete-var (&/|reverse =vars))] (return output))) -(defn ^:private clean* [?tid type] +(defn clean* [?tid type] (matchv ::M/objects [type] [["lux;VarT" ?id]] - (if (= ?tid ?id) - (&/try-all% (&/|list (deref ?id) - (fail "##5##"))) + (if (.equals ^Object ?tid ?id) + (deref ?id) (return type)) [["lux;LambdaT" [?arg ?return]]] @@ -341,7 +338,6 @@ )) (defn clean [tvar type] - ;; (prn "^^ clean ^^") (matchv ::M/objects [tvar] [["lux;VarT" ?id]] (clean* ?id type) @@ -349,8 +345,25 @@ [_] (fail (str "[Type Error] Not type-var: " (show-type tvar))))) +(defn ^:private unravel-fun [type] + (matchv ::M/objects [type] + [["lux;LambdaT" [?in ?out]]] + (|let [[??out ?args] (unravel-fun ?out)] + (&/T ??out (&/|cons ?in ?args))) + + [_] + (&/T type (&/|list)))) + +(defn ^:private unravel-app [fun-type] + (matchv ::M/objects [fun-type] + [["lux;AppT" [?left ?right]]] + (|let [[?fun-type ?args] (unravel-app ?left)] + (&/T ?fun-type (&/|++ ?args (&/|list ?right)))) + + [_] + (&/T fun-type (&/|list)))) + (defn show-type [^objects type] - ;; (prn 'show-type (aget type 0)) (matchv ::M/objects [type] [["lux;DataT" name]] (str "(^ " name ")") @@ -361,16 +374,18 @@ (str "(, " (->> elems (&/|map show-type) (&/|interpose " ") (&/fold str "")) ")")) [["lux;VariantT" cases]] - (str "(| " (->> cases - (&/|map (fn [kv] - (matchv ::M/objects [kv] - [[k ["Tuple" ["Nil" _]]]] - (str "#" k) + (if (&/|empty? cases) + "(|)" + (str "(| " (->> cases + (&/|map (fn [kv] + (matchv ::M/objects [kv] + [[k ["lux;TupleT" ["lux;Nil" _]]]] + (str "#" k) - [[k v]] - (str "(#" k " " (show-type v) ")")))) - (&/|interpose " ") - (&/fold str "")) ")") + [[k v]] + (str "(#" k " " (show-type v) ")")))) + (&/|interpose " ") + (&/fold str "")) ")")) [["lux;RecordT" fields]] @@ -383,89 +398,83 @@ (&/fold str "")) ")") [["lux;LambdaT" [input output]]] - (str "(-> " (show-type input) " " (show-type output) ")") + (|let [[?out ?ins] (unravel-fun type)] + (str "(-> " (->> ?ins (&/|map show-type) (&/|interpose " ") (&/fold str "")) " " (show-type ?out) ")")) [["lux;VarT" id]] (str "⌈" id "⌋") - [["lux;BoundT" name]] - name - [["lux;ExT" ?id]] (str "⟨" ?id "⟩") - [["lux;AppT" [?lambda ?param]]] - (str "(" (show-type ?lambda) " " (show-type ?param) ")") + [["lux;BoundT" name]] + name + + [["lux;AppT" [_ _]]] + (|let [[?call-fun ?call-args] (unravel-app type)] + (str "(" (show-type ?call-fun) " " (->> ?call-args (&/|map show-type) (&/|interpose " ") (&/fold str "")) ")")) [["lux;AllT" [?env ?name ?arg ?body]]] - (let [[args body] (loop [args (list ?arg) - body* ?body] - (matchv ::M/objects [body*] - [["lux;AllT" [?env* ?name* ?arg* ?body*]]] - (recur (cons ?arg* args) ?body*) + (if (= "" ?name) + (let [[args body] (loop [args (list ?arg) + body* ?body] + (matchv ::M/objects [body*] + [["lux;AllT" [?env* ?name* ?arg* ?body*]]] + (recur (cons ?arg* args) ?body*) - [_] - [args body*]))] - (str "(All " ?name " [" (->> args reverse (interpose " ") (reduce str "")) "] " (show-type body) ")")) - - [_] - (assert false (prn-str 'show-type (aget type 0) (class (aget type 1)))) + [_] + [args body*]))] + (str "(All " ?name " [" (->> args reverse (interpose " ") (reduce str "")) "] " (show-type body) ")")) + ?name) )) (defn type= [x y] - ;; (prn "^^ type= ^^") - (let [output (matchv ::M/objects [x y] - [["lux;DataT" xname] ["lux;DataT" yname]] - (= xname yname) + (or (clojure.lang.Util/identical x y) + (let [output (matchv ::M/objects [x y] + [["lux;DataT" xname] ["lux;DataT" yname]] + (.equals ^Object xname yname) - [["lux;TupleT" xelems] ["lux;TupleT" yelems]] - (&/fold (fn [old xy] - (|let [[x* y*] xy] - (and old - (type= x* y*)))) - true - (&/zip2 xelems yelems)) + [["lux;TupleT" xelems] ["lux;TupleT" yelems]] + (&/fold2 (fn [old x y] + (and old (type= x y))) + true + xelems yelems) - [["lux;VariantT" xcases] ["lux;VariantT" ycases]] - (and (= (&/|length xcases) (&/|length ycases)) - (&/fold (fn [old case] - (and old - (type= (&/|get case xcases) (&/|get case ycases)))) + [["lux;VariantT" xcases] ["lux;VariantT" ycases]] + (&/fold2 (fn [old xcase ycase] + (|let [[xname xtype] xcase + [yname ytype] ycase] + (and old (.equals ^Object xname yname) (type= xtype ytype)))) true - (&/|keys xcases))) + xcases ycases) - [["lux;RecordT" xfields] ["lux;RecordT" yfields]] - (and (= (&/|length xfields) (&/|length yfields)) - (&/fold (fn [old field] - (and old - (type= (&/|get field xfields) (&/|get field yfields)))) + [["lux;RecordT" xslots] ["lux;RecordT" yslots]] + (&/fold2 (fn [old xslot yslot] + (|let [[xname xtype] xslot + [yname ytype] yslot] + (and old (.equals ^Object xname yname) (type= xtype ytype)))) true - (&/|keys xfields))) + xslots yslots) - [["lux;LambdaT" [xinput xoutput]] ["lux;LambdaT" [yinput youtput]]] - (and (type= xinput yinput) - (type= xoutput youtput)) + [["lux;LambdaT" [xinput xoutput]] ["lux;LambdaT" [yinput youtput]]] + (and (type= xinput yinput) + (type= xoutput youtput)) - [["lux;VarT" xid] ["lux;VarT" yid]] - (= xid yid) + [["lux;VarT" xid] ["lux;VarT" yid]] + (.equals ^Object xid yid) - [["lux;BoundT" xname] ["lux;BoundT" yname]] - (= xname yname) + [["lux;BoundT" xname] ["lux;BoundT" yname]] + (.equals ^Object xname yname) - [["lux;ExT" xid] ["lux;ExT" yid]] - (= xid yid) + [["lux;ExT" xid] ["lux;ExT" yid]] + (.equals ^Object xid yid) - [["lux;AppT" [xlambda xparam]] ["lux;AppT" [ylambda yparam]]] - (and (type= xlambda ylambda) - (type= xparam yparam)) - - [["lux;AllT" [xenv xname xarg xbody]] ["lux;AllT" [yenv yname yarg ybody]]] - (do ;; (prn 'TESTING_ALLT - ;; 'NAME [xname yname] (= xname yname) - ;; 'ARG (= xarg yarg) - ;; 'LENGTH [(&/|length xenv) (&/|length yenv)] (= (&/|length xenv) (&/|length yenv))) - (and (= xname yname) - (= xarg yarg) + [["lux;AppT" [xlambda xparam]] ["lux;AppT" [ylambda yparam]]] + (and (type= xlambda ylambda) (type= xparam yparam)) + + [["lux;AllT" [xenv xname xarg xbody]] ["lux;AllT" [yenv yname yarg ybody]]] + (and (.equals ^Object xname yname) + (.equals ^Object xarg yarg) ;; (matchv ::M/objects [xenv yenv] ;; [["lux;None" _] ["lux;None" _]] ;; true @@ -480,14 +489,12 @@ ;; [_ _] ;; false) (type= xbody ybody) - )) + ) - [_ _] - (do ;; (prn 'type= (show-type x) (show-type y)) - false) - )] - ;; (prn 'type= output (show-type x) (show-type y)) - output)) + [_ _] + false + )] + output))) (defn ^:private fp-get [k fixpoints] (|let [[e a] k] @@ -506,10 +513,11 @@ (&/|cons (&/T k v) fixpoints)) (defn ^:private check-error [expected actual] - (str "Type " (show-type expected) " does not subsume type " (show-type actual))) + (str "[Type Checker]\nExpected: " (show-type expected) + "\n\nActual: " (show-type actual) + "\n")) (defn beta-reduce [env type] - ;; (prn 'beta-reduce (aget type 0)) (matchv ::M/objects [type] [["lux;VariantT" ?cases]] (&/V "lux;VariantT" (&/|map (fn [kv] @@ -559,11 +567,9 @@ (return* state type)))) (defn apply-type [type-fn param] - ;; (prn 'apply-type (aget type-fn 0) (aget param 0)) (matchv ::M/objects [type-fn] [["lux;AllT" [local-env local-name local-arg local-def]]] - (let [;; _ (prn 'apply-type/local-env (aget local-env 0) (show-type type-fn)) - local-env* (matchv ::M/objects [local-env] + (let [local-env* (matchv ::M/objects [local-env] [["lux;None" _]] (&/|table) @@ -579,261 +585,257 @@ (apply-type type-fn* param)) [_] - (fail (str "[Type System] Can't apply type function " (show-type type-fn) " to type " (show-type param))))) - -(def init-fixpoints (&/|list)) + (fail (str "[Type System] Not type function:\n" (show-type type-fn) "\n")))) -(defn ^:private check* [fixpoints expected actual] - ;; (prn "^^ check* ^^") - ;; (prn 'check* (aget expected 0) (aget actual 0)) - ;; (prn 'check* (show-type expected) (show-type actual)) - (matchv ::M/objects [expected actual] - [["lux;VarT" ?eid] ["lux;VarT" ?aid]] - (if (= ?eid ?aid) - (return (&/T fixpoints nil)) - (|do [ebound (&/try-all% (&/|list (|do [ebound (&/try-all% (&/|list (deref ?eid) - (fail "##4##")))] - (return (&/V "lux;Some" ebound))) - (return (&/V "lux;None" nil)))) - abound (&/try-all% (&/|list (|do [abound (&/try-all% (&/|list (deref ?aid) - (fail "##3##")))] - (return (&/V "lux;Some" abound))) - (return (&/V "lux;None" nil))))] - (matchv ::M/objects [ebound abound] - [["lux;None" _] ["lux;None" _]] - ;; (|do [_ (set-var ?aid expected)] - ;; (return (&/T fixpoints nil))) - (|do [_ (set-var ?eid actual)] - (return (&/T fixpoints nil))) - - [["lux;Some" etype] ["lux;None" _]] - (check* fixpoints etype actual) +(defn as-obj [class] + (case class + "boolean" "java.lang.Boolean" + "byte" "java.lang.Byte" + "short" "java.lang.Short" + "int" "java.lang.Integer" + "long" "java.lang.Long" + "float" "java.lang.Float" + "double" "java.lang.Double" + "char" "java.lang.Character" + ;; else + class)) - [["lux;None" _] ["lux;Some" atype]] - (check* fixpoints expected atype) +(def ^:private primitive-types #{"boolean" "byte" "short" "int" "long" "float" "double" "char"}) - [["lux;Some" etype] ["lux;Some" atype]] - (check* fixpoints etype atype))) - ) - - [["lux;VarT" ?id] _] - (&/try-all% (&/|list (|do [_ (set-var ?id actual)] - (return (&/T fixpoints nil))) - (|do [bound (&/try-all% (&/|list (deref ?id) - (fail "##1##")))] - (check* fixpoints bound actual)))) - - [_ ["lux;VarT" ?id]] - (&/try-all% (&/|list (|do [_ (set-var ?id expected)] - (return (&/T fixpoints nil))) - (|do [bound (&/try-all% (&/|list (deref ?id) - (fail "##2##")))] - (check* fixpoints expected bound)))) - - [["lux;AppT" [["lux;VarT" ?eid] A1]] ["lux;AppT" [["lux;VarT" ?aid] A2]]] - (|do [_ (check* fixpoints (&/V "lux;VarT" ?eid) (&/V "lux;VarT" ?aid)) - _ (check* fixpoints A1 A2)] - (return (&/T fixpoints nil))) - - ;; [["lux;AppT" [["lux;VarT" ?id] A1]] ["lux;AppT" [F2 A2]]] - ;; (|do [[fixpoints* _] (check* fixpoints (&/V "lux;VarT" ?id) F2) - ;; [fixpoints** _] (check* fixpoints* A1 A2)] - ;; (return (&/T fixpoints** nil))) - [["lux;AppT" [["lux;VarT" ?id] A1]] ["lux;AppT" [F2 A2]]] - (|do [[fixpoints* _] (check* fixpoints (&/V "lux;VarT" ?id) F2) - e* (apply-type F2 A1) - a* (apply-type F2 A2) - [fixpoints** _] (check* fixpoints* e* a*)] - (return (&/T fixpoints** nil))) - - ;; [["lux;AppT" [F1 A1]] ["lux;AppT" [["lux;VarT" ?id] A2]]] - ;; (|do [[fixpoints* _] (check* fixpoints F1 (&/V "lux;VarT" ?id)) - ;; [fixpoints** _] (check* fixpoints* A1 A2)] - ;; (return (&/T fixpoints** nil))) - [["lux;AppT" [F1 A1]] ["lux;AppT" [["lux;VarT" ?id] A2]]] - (|do [[fixpoints* _] (check* fixpoints F1 (&/V "lux;VarT" ?id)) - e* (apply-type F1 A1) - a* (apply-type F1 A2) - [fixpoints** _] (check* fixpoints* e* a*)] - (return (&/T fixpoints** nil))) - - ;; [["lux;AppT" [F1 A1]] ["lux;AppT" [F2 A2]]] - ;; (|do [[fixpoints* _] (check* (fp-put fp-pair true fixpoints) F1 F2) - ;; [fixpoints** _] (check* fixpoints* A1 A2)] - ;; (return (&/T fixpoints** nil))) - - [["lux;AppT" [F A]] _] - (let [fp-pair (&/T expected actual) - ;; _ (prn 'LEFT_APP (&/|length fixpoints)) - _ (when (> (&/|length fixpoints) 40) - (println 'FIXPOINTS (->> (&/|keys fixpoints) - (&/|map (fn [pair] - (|let [[e a] pair] - (str (show-type e) ":+:" - (show-type a))))) - (&/|interpose "\n\n") - (&/fold str ""))) - (assert false))] - (matchv ::M/objects [(fp-get fp-pair fixpoints)] - [["lux;Some" ?]] - (if ? - (return (&/T fixpoints nil)) - (fail (check-error expected actual))) - - [["lux;None" _]] - (|do [expected* (apply-type F A)] - (check* (fp-put fp-pair true fixpoints) expected* actual)))) +(def ^:private init-fixpoints (&/|list)) - [_ ["lux;AppT" [F A]]] - (|do [actual* (apply-type F A)] - (check* fixpoints expected actual*)) - ;; (let [fp-pair (&/T expected actual) - ;; _ (prn 'RIGHT_APP (&/|length fixpoints)) - ;; _ (when (> (&/|length fixpoints) 10) - ;; (println 'FIXPOINTS (->> (&/|keys fixpoints) - ;; (&/|map (fn [pair] - ;; (|let [[e a] pair] - ;; (str (show-type e) ":+:" - ;; (show-type a))))) - ;; (&/|interpose "\n\n") - ;; (&/fold str ""))) - ;; (assert false))] - ;; (matchv ::M/objects [(fp-get fp-pair fixpoints)] - ;; [["lux;Some" ?]] - ;; (if ? - ;; (return (&/T fixpoints nil)) - ;; (fail (check-error expected actual))) +(defn ^:private check* [class-loader fixpoints expected actual] + (if (clojure.lang.Util/identical expected actual) + (return (&/T fixpoints nil)) + (matchv ::M/objects [expected actual] + [["lux;VarT" ?eid] ["lux;VarT" ?aid]] + (if (.equals ^Object ?eid ?aid) + (return (&/T fixpoints nil)) + (|do [ebound (fn [state] + (matchv ::M/objects [((deref ?eid) state)] + [["lux;Right" [state* ebound]]] + (return* state* (&/V "lux;Some" ebound)) - ;; [["lux;None" _]] - ;; (|do [actual* (apply-type F A)] - ;; (check* (fp-put fp-pair true fixpoints) expected actual*)))) + [["lux;Left" _]] + (return* state (&/V "lux;None" nil)))) + abound (fn [state] + (matchv ::M/objects [((deref ?aid) state)] + [["lux;Right" [state* abound]]] + (return* state* (&/V "lux;Some" abound)) - [["lux;AllT" _] _] - (with-var - (fn [$arg] - (|do [expected* (apply-type expected $arg)] - (check* fixpoints expected* actual)))) + [["lux;Left" _]] + (return* state (&/V "lux;None" nil))))] + (matchv ::M/objects [ebound abound] + [["lux;None" _] ["lux;None" _]] + (|do [_ (set-var ?eid actual)] + (return (&/T fixpoints nil))) + + [["lux;Some" etype] ["lux;None" _]] + (check* class-loader fixpoints etype actual) - [_ ["lux;AllT" _]] - (with-var - (fn [$arg] - (|do [actual* (apply-type actual $arg)] - (check* fixpoints expected actual*)))) + [["lux;None" _] ["lux;Some" atype]] + (check* class-loader fixpoints expected atype) - [["lux;DataT" "boolean"] ["lux;DataT" "java.lang.Boolean"]] - (return (&/T fixpoints nil)) + [["lux;Some" etype] ["lux;Some" atype]] + (check* class-loader fixpoints etype atype)))) + + [["lux;VarT" ?id] _] + (fn [state] + (matchv ::M/objects [((set-var ?id actual) state)] + [["lux;Right" [state* _]]] + (return* state* (&/T fixpoints nil)) - [["lux;DataT" "byte"] ["lux;DataT" "java.lang.Byte"]] - (return (&/T fixpoints nil)) - - [["lux;DataT" "short"] ["lux;DataT" "java.lang.Short"]] - (return (&/T fixpoints nil)) + [["lux;Left" _]] + ((|do [bound (deref ?id)] + (check* class-loader fixpoints bound actual)) + state))) + + [_ ["lux;VarT" ?id]] + (fn [state] + (matchv ::M/objects [((set-var ?id expected) state)] + [["lux;Right" [state* _]]] + (return* state* (&/T fixpoints nil)) - [["lux;DataT" "int"] ["lux;DataT" "java.lang.Integer"]] - (return (&/T fixpoints nil)) + [["lux;Left" _]] + ((|do [bound (deref ?id)] + (check* class-loader fixpoints expected bound)) + state))) - [["lux;DataT" "long"] ["lux;DataT" "java.lang.Long"]] - (return (&/T fixpoints nil)) + [["lux;AppT" [["lux;VarT" ?eid] A1]] ["lux;AppT" [["lux;VarT" ?aid] A2]]] + (fn [state] + (matchv ::M/objects [((|do [F1 (deref ?eid)] + (fn [state] + (matchv ::M/objects [((|do [F2 (deref ?aid)] + (check* class-loader fixpoints (&/V "lux;AppT" (&/T F1 A1)) (&/V "lux;AppT" (&/T F2 A2)))) + state)] + [["lux;Right" [state* output]]] + (return* state* output) - [["lux;DataT" "float"] ["lux;DataT" "java.lang.Float"]] - (return (&/T fixpoints nil)) + [["lux;Left" _]] + ((check* class-loader fixpoints (&/V "lux;AppT" (&/T F1 A1)) actual) + state)))) + state)] + [["lux;Right" [state* output]]] + (return* state* output) - [["lux;DataT" "double"] ["lux;DataT" "java.lang.Double"]] - (return (&/T fixpoints nil)) + [["lux;Left" _]] + (matchv ::M/objects [((|do [F2 (deref ?aid)] + (check* class-loader fixpoints expected (&/V "lux;AppT" (&/T F2 A2)))) + state)] + [["lux;Right" [state* output]]] + (return* state* output) - [["lux;DataT" "char"] ["lux;DataT" "java.lang.Character"]] - (return (&/T fixpoints nil)) + [["lux;Left" _]] + ((|do [[fixpoints* _] (check* class-loader fixpoints (&/V "lux;VarT" ?eid) (&/V "lux;VarT" ?aid)) + [fixpoints** _] (check* class-loader fixpoints* A1 A2)] + (return (&/T fixpoints** nil))) + state)))) + ;; (|do [_ (check* class-loader fixpoints (&/V "lux;VarT" ?eid) (&/V "lux;VarT" ?aid)) + ;; _ (check* class-loader fixpoints A1 A2)] + ;; (return (&/T fixpoints nil))) + + [["lux;AppT" [["lux;VarT" ?id] A1]] ["lux;AppT" [F2 A2]]] + (fn [state] + (matchv ::M/objects [((|do [F1 (deref ?id)] + (check* class-loader fixpoints (&/V "lux;AppT" (&/T F1 A1)) actual)) + state)] + [["lux;Right" [state* output]]] + (return* state* output) - [["lux;DataT" "java.lang.Boolean"] ["lux;DataT" "boolean"]] - (return (&/T fixpoints nil)) + [["lux;Left" _]] + ((|do [[fixpoints* _] (check* class-loader fixpoints (&/V "lux;VarT" ?id) F2) + e* (apply-type F2 A1) + a* (apply-type F2 A2) + [fixpoints** _] (check* class-loader fixpoints* e* a*)] + (return (&/T fixpoints** nil))) + state))) + ;; [["lux;AppT" [["lux;VarT" ?id] A1]] ["lux;AppT" [F2 A2]]] + ;; (|do [[fixpoints* _] (check* class-loader fixpoints (&/V "lux;VarT" ?id) F2) + ;; e* (apply-type F2 A1) + ;; a* (apply-type F2 A2) + ;; [fixpoints** _] (check* class-loader fixpoints* e* a*)] + ;; (return (&/T fixpoints** nil))) + + [["lux;AppT" [F1 A1]] ["lux;AppT" [["lux;VarT" ?id] A2]]] + (fn [state] + (matchv ::M/objects [((|do [F2 (deref ?id)] + (check* class-loader fixpoints expected (&/V "lux;AppT" (&/T F2 A2)))) + state)] + [["lux;Right" [state* output]]] + (return* state* output) - [["lux;DataT" "java.lang.Byte"] ["lux;DataT" "byte"]] - (return (&/T fixpoints nil)) + [["lux;Left" _]] + ((|do [[fixpoints* _] (check* class-loader fixpoints F1 (&/V "lux;VarT" ?id)) + e* (apply-type F1 A1) + a* (apply-type F1 A2) + [fixpoints** _] (check* class-loader fixpoints* e* a*)] + (return (&/T fixpoints** nil))) + state))) + ;; [["lux;AppT" [F1 A1]] ["lux;AppT" [["lux;VarT" ?id] A2]]] + ;; (|do [[fixpoints* _] (check* class-loader fixpoints F1 (&/V "lux;VarT" ?id)) + ;; e* (apply-type F1 A1) + ;; a* (apply-type F1 A2) + ;; [fixpoints** _] (check* class-loader fixpoints* e* a*)] + ;; (return (&/T fixpoints** nil))) - [["lux;DataT" "java.lang.Short"] ["lux;DataT" "short"]] - (return (&/T fixpoints nil)) + [["lux;AppT" [F A]] _] + (let [fp-pair (&/T expected actual) + _ (when (> (&/|length fixpoints) 40) + (println 'FIXPOINTS (->> (&/|keys fixpoints) + (&/|map (fn [pair] + (|let [[e a] pair] + (str (show-type e) ":+:" + (show-type a))))) + (&/|interpose "\n\n") + (&/fold str ""))) + (assert false))] + (matchv ::M/objects [(fp-get fp-pair fixpoints)] + [["lux;Some" ?]] + (if ? + (return (&/T fixpoints nil)) + (fail (check-error expected actual))) - [["lux;DataT" "java.lang.Integer"] ["lux;DataT" "int"]] - (return (&/T fixpoints nil)) + [["lux;None" _]] + (|do [expected* (apply-type F A)] + (check* class-loader (fp-put fp-pair true fixpoints) expected* actual)))) - [["lux;DataT" "java.lang.Long"] ["lux;DataT" "long"]] - (return (&/T fixpoints nil)) + [_ ["lux;AppT" [F A]]] + (|do [actual* (apply-type F A)] + (check* class-loader fixpoints expected actual*)) - [["lux;DataT" "java.lang.Float"] ["lux;DataT" "float"]] - (return (&/T fixpoints nil)) + [["lux;AllT" _] _] + (with-var + (fn [$arg] + (|do [expected* (apply-type expected $arg)] + (check* class-loader fixpoints expected* actual)))) - [["lux;DataT" "java.lang.Double"] ["lux;DataT" "double"]] - (return (&/T fixpoints nil)) + [_ ["lux;AllT" _]] + (with-var + (fn [$arg] + (|do [actual* (apply-type actual $arg)] + (check* class-loader fixpoints expected actual*)))) - [["lux;DataT" "java.lang.Character"] ["lux;DataT" "char"]] - (return (&/T fixpoints nil)) + [["lux;DataT" e!name] ["lux;DataT" "null"]] + (if (contains? primitive-types e!name) + (fail (str "[Type Error] Can't use \"null\" with primitive types.")) + (return (&/T fixpoints nil))) - [["lux;DataT" e!name] ["lux;DataT" a!name]] - (if (or (= e!name a!name) - (.isAssignableFrom (Class/forName e!name) (Class/forName a!name))) - (return (&/T fixpoints nil)) - (fail (str "[Type Error] Names don't match: " e!name " & " a!name))) + [["lux;DataT" e!name] ["lux;DataT" a!name]] + (let [e!name (as-obj e!name) + a!name (as-obj a!name)] + (if (or (.equals ^Object e!name a!name) + (.isAssignableFrom (Class/forName e!name true class-loader) (Class/forName a!name true class-loader))) + (return (&/T fixpoints nil)) + (fail (str "[Type Error] Names don't match: " e!name " =/= " a!name)))) - [["lux;LambdaT" [eI eO]] ["lux;LambdaT" [aI aO]]] - (|do [[fixpoints* _] (check* fixpoints aI eI)] - (check* fixpoints* eO aO)) + [["lux;LambdaT" [eI eO]] ["lux;LambdaT" [aI aO]]] + (|do [[fixpoints* _] (check* class-loader fixpoints aI eI)] + (check* class-loader fixpoints* eO aO)) - [["lux;TupleT" e!members] ["lux;TupleT" a!members]] - (if (= (&/|length e!members) (&/|length a!members)) - (|do [fixpoints* (&/fold% (fn [fixp ea] - (|let [[e a] ea] - (do ;; (prn "lux;TupleT" 'ITER (show-type e) (show-type a)) - (|do [[fixp* _] (check* fixp e a)] - (return fixp*))))) - fixpoints - (&/zip2 e!members a!members)) - ;; :let [_ (prn "lux;TupleT" 'DONE)] - ] + [["lux;TupleT" e!members] ["lux;TupleT" a!members]] + (|do [fixpoints* (&/fold2% (fn [fp e a] + (|do [[fp* _] (check* class-loader fp e a)] + (return fp*))) + fixpoints + e!members a!members)] (return (&/T fixpoints* nil))) - (fail "[Type Error] Tuples don't match in size.")) - - [["lux;VariantT" e!cases] ["lux;VariantT" a!cases]] - (if (= (&/|length e!cases) (&/|length a!cases)) - (|do [fixpoints* (&/fold% (fn [fixp slot] - ;; (prn 'VARIANT_CASE slot) - (if-let [e!type (&/|get slot e!cases)] - (if-let [a!type (&/|get slot a!cases)] - (|do [[fixp* _] (check* fixp e!type a!type)] - (return fixp*)) - (fail (check-error expected actual))) - (fail (check-error expected actual)))) - fixpoints - (&/|keys e!cases))] + + [["lux;VariantT" e!cases] ["lux;VariantT" a!cases]] + (|do [fixpoints* (&/fold2% (fn [fp e!case a!case] + (|let [[e!name e!type] e!case + [a!name a!type] a!case] + (if (.equals ^Object e!name a!name) + (|do [[fp* _] (check* class-loader fp e!type a!type)] + (return fp*)) + (fail (check-error expected actual))))) + fixpoints + e!cases a!cases)] (return (&/T fixpoints* nil))) - (fail "[Type Error] Variants don't match in size.")) - [["lux;RecordT" e!fields] ["lux;RecordT" a!fields]] - (if (= (&/|length e!fields) (&/|length a!fields)) - (|do [fixpoints* (&/fold% (fn [fixp slot] - ;; (prn 'RECORD_FIELD slot) - (if-let [e!type (&/|get slot e!fields)] - (if-let [a!type (&/|get slot a!fields)] - (|do [[fixp* _] (check* fixp e!type a!type)] - (return fixp*)) - (fail (check-error expected actual))) - (fail (check-error expected actual)))) - fixpoints - (&/|keys e!fields))] + [["lux;RecordT" e!slots] ["lux;RecordT" a!slots]] + (|do [fixpoints* (&/fold2% (fn [fp e!slot a!slot] + (|let [[e!name e!type] e!slot + [a!name a!type] a!slot] + (if (.equals ^Object e!name a!name) + (|do [[fp* _] (check* class-loader fp e!type a!type)] + (return fp*)) + (fail (check-error expected actual))))) + fixpoints + e!slots a!slots)] (return (&/T fixpoints* nil))) - (fail "[Type Error] Records don't match in size.")) - [["lux;ExT" e!id] ["lux;ExT" a!id]] - (if (= e!id a!id) - (return (&/T fixpoints nil)) - (check-error expected actual)) + [["lux;ExT" e!id] ["lux;ExT" a!id]] + (if (.equals ^Object e!id a!id) + (return (&/T fixpoints nil)) + (fail (check-error expected actual))) - [_ _] - (fail (println-str "[Type Error] Can't type-check: " (show-type expected) (show-type actual))) - )) + [_ _] + (fail (check-error expected actual)) + ))) (defn check [expected actual] - ;; (prn "^^ check ^^") - (|do [_ (check* init-fixpoints expected actual)] + (|do [class-loader &/loader + _ (check* class-loader init-fixpoints expected actual)] (return nil))) (defn apply-lambda [func param] @@ -850,7 +852,7 @@ (clean $var =return)))) [_] - (fail (str "[Type System] Can't apply type " (show-type func) " to type " (show-type param))) + (fail (str "[Type System] Not a function type:\n" (show-type func) "\n")) )) (defn actual-type [type] @@ -859,6 +861,9 @@ (|do [type* (apply-type ?all ?param)] (actual-type type*)) + [["lux;VarT" ?id]] + (deref ?id) + [_] (return type) )) |