diff options
| author | LuxLang | 2015-07-29 20:41:46 -0400 |
|---|---|---|
| committer | LuxLang | 2015-07-29 20:41:46 -0400 |
| commit | 3b0b7de8d898662ba154aa8cbd578d26fb91e62e (patch) | |
| tree | b89d963155f48664913e72457fdd0e200bd14831 | |
| parent | 2aca948eddd42300a936fd449b8ab77333d95146 (diff) | |
| parent | 3bf6cc274a81821243a68b3bd81e88e6a8c2a07a (diff) | |
Merge pull request #4 from LuxLang/v0.2
V0.2
59 files changed, 8141 insertions, 4843 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) - -## (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])] +(_lux_export LuxVar) + +## (deftype (Module Compiler) +## (& #module-aliases (List (, Text Text)) +## #defs (List (, Text (, Bool (DefData' (-> (List Syntax) (StateE Compiler (List Syntax))))))) +## #imports (List Text) +## )) +(_lux_def Module + (#AllT [(#Some #Nil) "lux;Module" "Compiler" + (#RecordT (#Cons [["lux;module-aliases" (#AppT [List (#TupleT (#Cons [Text (#Cons [Text #Nil])]))])] + (#Cons [["lux;defs" (#AppT [List (#TupleT (#Cons [Text + (#Cons [(#TupleT (#Cons [Bool (#Cons [(#AppT [DefData' (#LambdaT [SyntaxList + (#AppT [(#AppT [StateE (#BoundT "Compiler")]) + SyntaxList])])]) + #Nil])])) + #Nil])]))])] + (#Cons [["lux;imports" (#AppT [List Text])] + #Nil])])]))])) +(_lux_export Module) + +## (deftype #rec Compiler +## (& #source Reader +## #modules (List (, Text (Module Compiler))) +## #envs (List (Env Text (, LuxVar Type))) +## #types (Bindings Int Type) +## #host HostState +## #seed Int +## #eval? Bool)) +(_lux_def Compiler + (#AppT [(#AllT [(#Some #Nil) "lux;Compiler" "" + (#RecordT (#Cons [["lux;source" Reader] (#Cons [["lux;modules" (#AppT [List (#TupleT (#Cons [Text - (#Cons [(#AppT [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))))) - -(def' $text - (:' (#LambdaT [Text Syntax]) - (lambda' _ text - (_meta (#Text text))))) - -(def' $symbol - (:' (#LambdaT [Ident Syntax]) - (lambda' _ ident - (_meta (#Symbol ident))))) - -(def' $tag - (:' (#LambdaT [Ident Syntax]) - (lambda' _ ident - (_meta (#Tag ident))))) - -(def' $form - (:' (#LambdaT [(#AppT [List Syntax]) Syntax]) - (lambda' _ tokens - (_meta (#Form tokens))))) - -(def' $tuple - (:' (#LambdaT [(#AppT [List Syntax]) Syntax]) - (lambda' _ tokens - (_meta (#Tuple tokens))))) - -(def' $record - (:' (#LambdaT [(#AppT [List (#TupleT (#Cons [Syntax (#Cons [Syntax #Nil])]))]) Syntax]) - (lambda' _ tokens - (_meta (#Record 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]))) - - _ - (fail "Wrong syntax for let'"))))) -(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 - - _ - (_meta (#Form (#Cons [(_meta (#Symbol ["lux" "lambda_"])) - (#Cons [(_meta (#Tuple 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 - - _ - (_meta (#Form (#Cons [(_meta (#Symbol ["lux" "lambda_"])) - (#Cons [(_meta (#Tuple args')) - (#Cons [body #Nil])])])))) - #Nil])])])]))) - #Nil]))) - - _ - (fail "Wrong syntax for lambda"))))) -(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])]))) - - (#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 [_ (#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 [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]))) - - _ - (fail "Wrong syntax for def") - )))) -(declare-macro' def_) - -(def_ #export (defmacro tokens) +(_lux_def fail + (_lux_: (#AllT [(#Some #Nil) "" "a" + (#LambdaT [Text + (#LambdaT [Compiler + (#AppT [(#AppT [Either Text]) + (#TupleT (#Cons [Compiler + (#Cons [(#BoundT "a") + #Nil])]))])])])]) + (_lux_lambda _ msg + (_lux_lambda _ state + (#Left msg))))) + +(_lux_def text$ + (_lux_: (#LambdaT [Text Syntax]) + (_lux_lambda _ text + (_meta (#TextS text))))) + +(_lux_def symbol$ + (_lux_: (#LambdaT [Ident Syntax]) + (_lux_lambda _ ident + (_meta (#SymbolS ident))))) + +(_lux_def tag$ + (_lux_: (#LambdaT [Ident Syntax]) + (_lux_lambda _ ident + (_meta (#TagS ident))))) + +(_lux_def form$ + (_lux_: (#LambdaT [(#AppT [List Syntax]) Syntax]) + (_lux_lambda _ tokens + (_meta (#FormS tokens))))) + +(_lux_def tuple$ + (_lux_: (#LambdaT [(#AppT [List Syntax]) Syntax]) + (_lux_lambda _ tokens + (_meta (#TupleS tokens))))) + +(_lux_def record$ + (_lux_: (#LambdaT [(#AppT [List (#TupleT (#Cons [Syntax (#Cons [Syntax #Nil])]))]) Syntax]) + (_lux_lambda _ tokens + (_meta (#RecordS tokens))))) + +(_lux_def let' + (_lux_: Macro + (_lux_lambda _ tokens + (_lux_case tokens + (#Cons [lhs (#Cons [rhs (#Cons [body #Nil])])]) + (return (#Cons [(form$ (#Cons [(symbol$ ["" "_lux_case"]) + (#Cons [rhs (#Cons [lhs (#Cons [body #Nil])])])])) + #Nil])) + + _ + (fail "Wrong syntax for let'"))))) +(_lux_declare-macro let') + +(_lux_def lambda' + (_lux_: Macro + (_lux_lambda _ tokens + (_lux_case tokens + (#Cons [(#Meta [_ (#TupleS (#Cons [arg args']))]) (#Cons [body #Nil])]) + (return (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_lambda"])) + (#Cons [(_meta (#SymbolS ["" ""])) + (#Cons [arg + (#Cons [(_lux_case args' + #Nil + body + + _ + (_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "lambda'"])) + (#Cons [(_meta (#TupleS args')) + (#Cons [body #Nil])])])))) + #Nil])])])]))) + #Nil])) + + (#Cons [(#Meta [_ (#SymbolS self)]) (#Cons [(#Meta [_ (#TupleS (#Cons [arg args']))]) (#Cons [body #Nil])])]) + (return (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_lambda"])) + (#Cons [(_meta (#SymbolS self)) + (#Cons [arg + (#Cons [(_lux_case args' + #Nil + body + + _ + (_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "lambda'"])) + (#Cons [(_meta (#TupleS args')) + (#Cons [body #Nil])])])))) + #Nil])])])]))) + #Nil])) + + _ + (fail "Wrong syntax for lambda"))))) +(_lux_declare-macro lambda') + +(_lux_def def' + (_lux_: Macro + (lambda' [tokens] + (_lux_case tokens + (#Cons [(#Meta [_ (#TagS ["" "export"])]) + (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) + (#Cons [type (#Cons [body #Nil])])])]) + (return (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_def"])) + (#Cons [name + (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_:"])) + (#Cons [type + (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "lambda'"])) + (#Cons [name + (#Cons [(_meta (#TupleS args)) + (#Cons [body #Nil])])])]))) + #Nil])])]))) + #Nil])])]))) + (#Cons [(_meta (#FormS (#Cons [(symbol$ ["" "_lux_export"]) (#Cons [name #Nil])]))) + #Nil])])) + + (#Cons [(#Meta [_ (#TagS ["" "export"])]) (#Cons [name (#Cons [type (#Cons [body #Nil])])])]) + (return (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_def"])) + (#Cons [name + (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_:"])) + (#Cons [type + (#Cons [body + #Nil])])]))) + #Nil])])]))) + (#Cons [(_meta (#FormS (#Cons [(symbol$ ["" "_lux_export"]) (#Cons [name #Nil])]))) + #Nil])])) + + (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) + (#Cons [type (#Cons [body #Nil])])]) + (return (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_def"])) + (#Cons [name + (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_:"])) + (#Cons [type + (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "lambda'"])) + (#Cons [name + (#Cons [(_meta (#TupleS args)) + (#Cons [body #Nil])])])]))) + #Nil])])]))) + #Nil])])]))) + #Nil])) + + (#Cons [name (#Cons [type (#Cons [body #Nil])])]) + (return (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_def"])) + (#Cons [name + (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_:"])) + (#Cons [type + (#Cons [body + #Nil])])]))) + #Nil])])]))) + #Nil])) + + _ + (fail "Wrong syntax for def") + )))) +(_lux_declare-macro def') + +(def' (defmacro tokens) Macro - (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])]))) - - (#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])]))) - - _ - (fail "Wrong syntax for defmacro"))) -(declare-macro' defmacro) + (_lux_case tokens + (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) (#Cons [body #Nil])]) + (return (#Cons [(form$ (#Cons [(symbol$ ["lux" "def'"]) + (#Cons [(form$ (#Cons [name args])) + (#Cons [(symbol$ ["lux" "Macro"]) + (#Cons [body + #Nil])]) + ])])) + (#Cons [(form$ (#Cons [(symbol$ ["" "_lux_declare-macro"]) (#Cons [name #Nil])])) + #Nil])])) + + (#Cons [(#Meta [_ (#TagS ["" "export"])]) (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) (#Cons [body #Nil])])]) + (return (#Cons [(form$ (#Cons [(symbol$ ["lux" "def'"]) + (#Cons [(tag$ ["" "export"]) + (#Cons [(form$ (#Cons [name args])) + (#Cons [(symbol$ ["lux" "Macro"]) + (#Cons [body + #Nil])]) + ])])])) + (#Cons [(form$ (#Cons [(symbol$ ["" "_lux_declare-macro"]) (#Cons [name #Nil])])) + #Nil])])) + + _ + (fail "Wrong syntax for defmacro"))) +(_lux_declare-macro defmacro) (defmacro #export (comment tokens) - (return (:' 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]))) - - (#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]))) - - _ - (fail "Wrong syntax for ->'"))) + (_lux_case tokens + (#Cons [input (#Cons [output #Nil])]) + (return (#Cons [(_meta (#FormS (#Cons [(_meta (#TagS ["lux" "LambdaT"])) + (#Cons [(_meta (#TupleS (#Cons [input (#Cons [output #Nil])]))) + #Nil])]))) + #Nil])) + + (#Cons [input (#Cons [output others])]) + (return (#Cons [(_meta (#FormS (#Cons [(_meta (#TagS ["lux" "LambdaT"])) + (#Cons [(_meta (#TupleS (#Cons [input + (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "->'"])) + (#Cons [output others])]))) + #Nil])]))) + #Nil])]))) + #Nil])) + + _ + (fail "Wrong syntax for ->'"))) (defmacro (All' tokens) - (case' tokens - (#Cons [(#Meta [_ (#Tuple #Nil)]) - (#Cons [body #Nil])]) - (return (:' SyntaxList - (#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]))) - - _ - (fail "Wrong syntax for All'"))) + (_lux_case tokens + (#Cons [(#Meta [_ (#TupleS #Nil)]) + (#Cons [body #Nil])]) + (return (#Cons [body + #Nil])) + + (#Cons [(#Meta [_ (#TupleS (#Cons [(#Meta [_ (#SymbolS ["" arg-name])]) other-args]))]) + (#Cons [body #Nil])]) + (return (#Cons [(_meta (#FormS (#Cons [(_meta (#TagS ["lux" "AllT"])) + (#Cons [(_meta (#TupleS (#Cons [(_meta (#TagS ["lux" "None"])) + (#Cons [(_meta (#TextS "")) + (#Cons [(_meta (#TextS arg-name)) + (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "All'"])) + (#Cons [(_meta (#TupleS other-args)) + (#Cons [body + #Nil])])]))) + #Nil])])])]))) + #Nil])]))) + #Nil])) + + _ + (fail "Wrong syntax for All'"))) (defmacro (B' tokens) - (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]))) - - _ - (fail "Wrong syntax for B'"))) + (_lux_case tokens + (#Cons [(#Meta [_ (#SymbolS ["" bound-name])]) + #Nil]) + (return (#Cons [(_meta (#FormS (#Cons [(_meta (#TagS ["lux" "BoundT"])) + (#Cons [(_meta (#TextS bound-name)) + #Nil])]))) + #Nil])) + + _ + (fail "Wrong syntax for B'"))) (defmacro ($' tokens) - (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]))) - - _ - (fail "Wrong syntax for $'"))) - -(def_ #export (fold f init xs) + (_lux_case tokens + (#Cons [x #Nil]) + (return tokens) + + (#Cons [x (#Cons [y xs])]) + (return (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "$'"])) + (#Cons [(_meta (#FormS (#Cons [(_meta (#TagS ["lux" "AppT"])) + (#Cons [(_meta (#TupleS (#Cons [x (#Cons [y #Nil])]))) + #Nil])]))) + xs])]))) + #Nil])) + + _ + (fail "Wrong syntax for $'"))) + +(def' (foldL f init xs) (All' [a b] (->' (->' (B' a) (B' b) (B' a)) (B' a) ($' List (B' b)) (B' a))) - (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)) - -(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 #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)))) - - _ - (fail "Wrong syntax for list&"))) + (foldL (lambda' [tail head] (#Cons [head tail])) + #Nil + list)) + +(defmacro (list xs) + (return (#Cons [(foldL (lambda' [tail head] + (_meta (#FormS (#Cons [(_meta (#TagS ["lux" "Cons"])) + (#Cons [(_meta (#TupleS (#Cons [head (#Cons [tail #Nil])]))) + #Nil])])))) + (_meta (#TagS ["lux" "Nil"])) + (reverse xs)) + #Nil]))) + +(defmacro (list& xs) + (_lux_case (reverse xs) + (#Cons [last init]) + (return (list (foldL (lambda' [tail head] + (_meta (#FormS (list (_meta (#TagS ["lux" "Cons"])) + (_meta (#TupleS (list head tail))))))) + last + init))) + + _ + (fail "Wrong syntax for list&"))) (defmacro #export (lambda tokens) - (let' [name tokens'] (:' (#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")))) + +(defmacro (def'' tokens) + (_lux_case tokens + (#Cons [(#Meta [_ (#TagS ["" "export"])]) + (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) + (#Cons [type (#Cons [body #Nil])])])]) + (return (list (form$ (list (symbol$ ["" "_lux_def"]) + name + (form$ (list (symbol$ ["" "_lux_:"]) + type + (form$ (list (symbol$ ["lux" "lambda"]) + name + (tuple$ args) + body)))))) + (form$ (list (symbol$ ["" "_lux_export"]) name)))) + + (#Cons [(#Meta [_ (#TagS ["" "export"])]) (#Cons [name (#Cons [type (#Cons [body #Nil])])])]) + (return (list (form$ (list (symbol$ ["" "_lux_def"]) + name + (form$ (list (symbol$ ["" "_lux_:"]) + type + body)))) + (form$ (list (symbol$ ["" "_lux_export"]) name)))) + + (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) + (#Cons [type (#Cons [body #Nil])])]) + (return (list (form$ (list (symbol$ ["" "_lux_def"]) + name + (form$ (list (symbol$ ["" "_lux_:"]) + type + (form$ (list (symbol$ ["lux" "lambda"]) + name + (tuple$ args) + body)))))))) + + (#Cons [name (#Cons [type (#Cons [body #Nil])])]) + (return (list (form$ (list (symbol$ ["" "_lux_def"]) + name + (form$ (list (symbol$ ["" "_lux_:"]) type body)))))) - _ - (fail "Wrong syntax for 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))))) - - (#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 [_ (#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 [name (#Cons [type (#Cons [body #Nil])])]) - (return (:' SyntaxList - (list ($form (list ($symbol ["" "def'"]) - name - ($form (list ($symbol ["" ":'"]) type body))))))) - - _ - (fail "Wrong syntax for def") - )) - -(def__ (as-pairs xs) + _ + (fail "Wrong syntax for def") + )) + +(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)))))) - - _ - (fail "Wrong syntax for let"))) - -(def__ #export (map f xs) + (_lux_case tokens + (#Cons [(#Meta [_ (#TupleS bindings)]) (#Cons [body #Nil])]) + (return (list (foldL (_lux_: (->' Syntax (#TupleT (list Syntax Syntax)) + Syntax) + (lambda [body binding] + (_lux_case binding + [label value] + (form$ (list (symbol$ ["" "_lux_case"]) value label body))))) + body + (reverse (as-pairs bindings))))) + + _ + (fail "Wrong syntax for let"))) + +(def'' (map f xs) (All' [a b] (->' (->' (B' a) (B' b)) ($' List (B' a)) ($' List (B' b)))) - (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 $"))) - -(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 - - _ - ($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')))))) - - 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))))) - - (#Meta [_ (#Int value)]) - (wrap-meta ($form (list ($tag ["lux" "Int"]) (_meta (#Int value))))) - - (#Meta [_ (#Real value)]) - (wrap-meta ($form (list ($tag ["lux" "Real"]) (_meta (#Real value))))) - - (#Meta [_ (#Char value)]) - (wrap-meta ($form (list ($tag ["lux" "Char"]) (_meta (#Char value))))) - - (#Meta [_ (#Text value)]) - (wrap-meta ($form (list ($tag ["lux" "Text"]) (_meta (#Text value))))) - - (#Meta [_ (#Tag [module name])]) - (let [module' (case' module - "" - subst - - _ - module)] - (wrap-meta ($form (list ($tag ["lux" "Tag"]) ($tuple (list ($text module') ($text name))))))) - - (#Meta [_ (#Symbol [module name])]) - (let [module' (case' module - "" - subst - - _ - module)] - (wrap-meta ($form (list ($tag ["lux" "Symbol"]) ($tuple (list ($text module') ($text name))))))) - - (#Meta [_ (#Tuple elems)]) - (splice (untemplate subst) ($tag ["lux" "Tuple"]) elems) - - (#Meta [_ (#Form (#Cons [(#Meta [_ (#Symbol ["" "~"])]) (#Cons [unquoted #Nil])]))]) - unquoted - - (#Meta [_ (#Form elems)]) - (splice (untemplate subst) ($tag ["lux" "Form"]) elems) - - (#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))))) - )) + (_lux_case tokens + (#Cons [op (#Cons [init args])]) + (return (list (foldL (lambda [a1 a2] (form$ (list op a1 a2))) + init + args))) + + _ + (fail "Wrong syntax for $"))) + +(def'' (splice replace? untemplate tag elems) + (->' Bool (->' Syntax Syntax) Syntax ($' List Syntax) Syntax) + (_lux_case replace? + true + (_lux_case (any? spliced? elems) + true + (let [elems' (map (lambda [elem] + (_lux_case elem + (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS ["" "~@"])]) (#Cons [spliced #Nil])]))]) + spliced + + _ + (form$ (list (symbol$ ["" "_lux_:"]) + (form$ (list (tag$ ["lux" "AppT"]) (tuple$ (list (symbol$ ["lux" "List"]) (symbol$ ["lux" "Syntax"]))))) + (form$ (list (tag$ ["lux" "Cons"]) (tuple$ (list (untemplate elem) + (tag$ ["lux" "Nil"]))))))))) + elems)] + (wrap-meta (form$ (list tag + (form$ (list& (symbol$ ["lux" "$"]) + (symbol$ ["lux" "list:++"]) + elems')))))) + + false + (wrap-meta (form$ (list tag (untemplate-list (map untemplate elems)))))) + false + (wrap-meta (form$ (list tag (untemplate-list (map untemplate elems))))))) + +(def'' (untemplate replace? subst token) + (->' Bool Text Syntax Syntax) + (_lux_case (_lux_: (#TupleT (list Bool Syntax)) [replace? token]) + [_ (#Meta [_ (#BoolS value)])] + (wrap-meta (form$ (list (tag$ ["lux" "BoolS"]) (_meta (#BoolS value))))) + + [_ (#Meta [_ (#IntS value)])] + (wrap-meta (form$ (list (tag$ ["lux" "IntS"]) (_meta (#IntS value))))) + + [_ (#Meta [_ (#RealS value)])] + (wrap-meta (form$ (list (tag$ ["lux" "RealS"]) (_meta (#RealS value))))) + + [_ (#Meta [_ (#CharS value)])] + (wrap-meta (form$ (list (tag$ ["lux" "CharS"]) (_meta (#CharS value))))) + + [_ (#Meta [_ (#TextS value)])] + (wrap-meta (form$ (list (tag$ ["lux" "TextS"]) (_meta (#TextS value))))) + + [_ (#Meta [_ (#TagS [module name])])] + (let [module' (_lux_case module + "" + subst + + _ + module)] + (wrap-meta (form$ (list (tag$ ["lux" "TagS"]) (tuple$ (list (text$ module') (text$ name))))))) + + [_ (#Meta [_ (#SymbolS [module name])])] + (let [module' (_lux_case module + "" + subst + + _ + module)] + (wrap-meta (form$ (list (tag$ ["lux" "SymbolS"]) (tuple$ (list (text$ module') (text$ name))))))) + + [_ (#Meta [_ (#TupleS elems)])] + (splice replace? (untemplate replace? subst) (tag$ ["lux" "TupleS"]) elems) + + [true (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS ["" "~"])]) (#Cons [unquoted #Nil])]))])] + unquoted + + [_ (#Meta [meta (#FormS elems)])] + (let [(#Meta [_ form']) (splice replace? (untemplate replace? subst) (tag$ ["lux" "FormS"]) elems)] + (#Meta [meta form'])) + + [_ (#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))) - - _ - (`' ((~ app) (~ acc)))))) - init - apps)))) - - _ - (fail "Wrong syntax for |>"))) + (_lux_case tokens + (#Cons [init apps]) + (return (list (foldL (lambda [acc app] + (_lux_case app + (#Meta [_ (#TupleS parts)]) + (tuple$ (list:++ parts (list acc))) + + (#Meta [_ (#FormS parts)]) + (form$ (list:++ parts (list acc))) + + _ + (`' ((~ app) (~ acc))))) + init + apps))) + + _ + (fail "Wrong syntax for |>"))) (defmacro #export (if tokens) - (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'))) - - _ - (`' (;bind (lambda' (~ ($symbol ["" ""])) - (~ var) - (~ body')) - (~ value))))))) - body - (reverse (as-pairs bindings)))] - (return (:' SyntaxList - (list (`' (case' (~ monad) - {#;return ;return #;bind ;bind} - (~ body'))))))) - - _ - (fail "Wrong syntax for do"))) - -(def__ (map% m f xs) + (_lux_case var + (#Meta [_ (#TagS ["" "let"])]) + (`' (;let (~ value) (~ body'))) + + _ + (`' (;bind (_lux_lambda (~ (symbol$ ["" ""])) + (~ var) + (~ body')) + (~ value))))))) + body + (reverse (as-pairs bindings)))] + (return (list (`' (_lux_case (~ monad) + {#;return ;return #;bind ;bind} + (~ body')))))) + + _ + (fail "Wrong syntax for do"))) + +(def'' (map% m f xs) ## (All [m a b] ## (-> (Monad m) (-> a (m b)) (List a) (m (List b)))) (All' [m a b] @@ -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])))) - ))) - -(def__ #export (. f g) + (_lux_case xs + #Nil + (;return #Nil) + + (#Cons [x xs']) + (do m + [y (f x) + ys (map% m f xs')] + (;return (#Cons [y ys]))) + ))) + +(def'' #export (. f g) (All' [a b c] (-> (-> (B' b) (B' c)) (-> (B' a) (B' b)) (-> (B' a) (B' c)))) (lambda [x] (f (g x)))) -(def__ (get-ident x) +(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 - - (#Cons [x xs']) - (list:++ (f x) (join-map f xs')))) + (_lux_case xs + #Nil + #Nil -(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)) + (#Cons [x xs']) + (list:++ (f x) (join-map f xs')))) + +(defmacro #export (do-template tokens) + (_lux_case tokens + (#Cons [(#Meta [_ (#TupleS bindings)]) (#Cons [(#Meta [_ (#TupleS templates)]) data])]) + (_lux_case (_lux_: (, ($' Maybe ($' List Text)) ($' Maybe ($' List ($' List Syntax)))) + [(map% Maybe/Monad get-ident bindings) + (map% Maybe/Monad tuple->list data)]) + [(#Some bindings') (#Some data')] + (let [apply (_lux_: (-> RepEnv ($' List Syntax)) + (lambda [env] (map (apply-template env) templates)))] + (|> data' + (join-map (. apply (make-env bindings'))) + return)) - _ - (fail "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'] - - _ - ["" 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")) + (let [[self-ident tokens'] (_lux_: (, Text SyntaxList) + (_lux_case tokens + (#Cons [(#Meta [_ (#SymbolS ["" self-ident])]) tokens']) + [self-ident tokens'] + + _ + ["" tokens]))] + (_lux_case tokens' + (#Cons [(#Meta [_ (#TupleS args)]) (#Cons [body #Nil])]) + (_lux_case (map% Maybe/Monad get-ident args) + (#Some idents) + (_lux_case idents + #Nil + (return (list body)) + + (#Cons [harg targs]) + (let [replacements (map (_lux_: (-> Text (, Text Syntax)) + (lambda [ident] [ident (`' (#;BoundT (~ (text$ ident))))])) + (list& self-ident idents)) + body' (foldL (lambda [body' arg'] + (`' (#;AllT [#;None "" (~ (text$ arg')) (~ body')]))) + (replace-syntax replacements body) + (reverse targs))] + ## (#;Some #;Nil) + (return (list (`' (#;AllT [#;None (~ (text$ self-ident)) (~ (text$ harg)) (~ body')])))))) + + #None + (fail "'All' arguments must be symbols.")) + + _ + (fail "Wrong syntax for All")) )) -(def__ (get k plist) +(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!") - - (#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))))))))) + (_lux_case state + {#source source #modules modules + #envs envs #types types #host host + #seed seed #eval? eval?} + (_lux_case (reverse envs) + #Nil + (#Left "Can't get the module name without a module!") + + (#Cons [{#name module-name #inner-closures _ #locals _ #closure _} _]) + (#Right [state module-name])))) + +(def'' (find-macro' modules current-module module name) + (-> ($' List (, Text ($' Module Compiler))) Text Text Text ($' Maybe Macro)) - (do Maybe:Monad - [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)) - - [_ (#AliasD [r-module r-name])] - (find-macro' modules current-module r-module r-name) - - _ - #None))) - -(def__ #export (find-macro ident) + (do Maybe/Monad + [$module (get module modules) + gdef (let [{#module-aliases _ #defs bindings #imports _} (_lux_: ($' Module Compiler) $module)] + (get name bindings))] + (_lux_case (_lux_: (, Bool ($' DefData' Macro)) gdef) + [exported? (#MacroD macro')] + (if exported? + (#Some macro') + (if (text:= module current-module) + (#Some macro') + #None)) + + [_ (#AliasD [r-module r-name])] + (find-macro' modules current-module r-module r-name) + + _ + #None))) + +(def'' (find-macro ident) (-> Ident ($' Lux ($' Maybe Macro))) - (do Lux:Monad + (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)]))))))) - -(def__ (list:join xs) + (lambda [state] + (_lux_case state + {#source source #modules modules + #envs envs #types types #host host + #seed seed #eval? eval?} + (#Right [state (find-macro' modules current-module module name)])))))) + +(def'' (list:join xs) (All [a] (-> ($' List ($' List a)) ($' List a))) - (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))) (;,)])))) - - (#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 |")))) + (do Lux/Monad + [pairs (map% Lux/Monad + (_lux_: (-> Syntax ($' Lux Syntax)) + (lambda [token] + (_lux_case token + (#Meta [_ (#TagS ident)]) + (do Lux/Monad + [ident (normalize ident)] + (;return (`' [(~ (text$ (ident->text ident))) (;,)]))) + + (#Meta [_ (#FormS (#Cons [(#Meta [_ (#TagS ident)]) (#Cons [value #Nil])]))]) + (do Lux/Monad + [ident (normalize ident)] + (;return (`' [(~ (text$ (ident->text ident))) (~ value)]))) + + _ + (fail "Wrong syntax for |")))) tokens)] - (;return (:' 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) + (_lux_case xs + #Nil + xs - (#Meta [_ (#Char value)]) - ($ text:++ "#\"" (->text value) "\"") + (#Cons [x #Nil]) + xs - (#Meta [_ (#Text value)]) - value + (#Cons [x xs']) + (list& x sep (interpose sep xs')))) - (#Meta [_ (#Symbol ident)]) - (ident->text ident) +(def'' (macro-expand syntax) + (-> Syntax ($' Lux ($' List Syntax))) + (_lux_case syntax + (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS macro-name)]) args]))]) + (do Lux/Monad + [macro-name' (normalize macro-name) + ?macro (find-macro macro-name')] + (_lux_case ?macro + (#Some macro) + (do Lux/Monad + [expansion (macro args) + expansion' (map% Lux/Monad macro-expand expansion)] + (;return (list:join expansion'))) + + #None + (do Lux/Monad + [parts' (map% Lux/Monad macro-expand (list& (symbol$ macro-name) args))] + (;return (list (form$ (list:join parts'))))))) + + (#Meta [_ (#FormS (#Cons [harg targs]))]) + (do Lux/Monad + [harg+ (macro-expand harg) + targs+ (map% Lux/Monad macro-expand targs)] + (;return (list (form$ (list:++ harg+ (list:join targs+)))))) + + (#Meta [_ (#TupleS members)]) + (do Lux/Monad + [members' (map% Lux/Monad macro-expand members)] + (;return (list (tuple$ (list:join members'))))) - (#Meta [_ (#Tag ident)]) - (text:++ "#" (ident->text ident)) + _ + (return (list syntax)))) - (#Meta [_ (#Tuple members)]) - ($ text:++ "[" (|> members (map syntax:show) (interpose " ") (fold text:++ "")) "]") +(def'' (walk-type type) + (-> Syntax Syntax) + (_lux_case type + (#Meta [_ (#FormS (#Cons [(#Meta [_ (#TagS tag)]) parts]))]) + (form$ (#Cons [(tag$ tag) (map walk-type parts)])) - (#Meta [_ (#Form members)]) - ($ text:++ "(" (|> members (map syntax:show) (interpose " ") (fold text:++ "")) ")") + (#Meta [_ (#TupleS members)]) + (tuple$ (map walk-type members)) - (#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:++ "")) "}") - )) + (#Meta [_ (#FormS (#Cons [type-fn args]))]) + (foldL (lambda [type-fn arg] (`' (#;AppT [(~ type-fn) (~ arg)]))) + (walk-type type-fn) + (map walk-type args)) + + _ + type)) + +(defmacro #export (type tokens) + (_lux_case tokens + (#Cons [type #Nil]) + (do Lux/Monad + [type+ (macro-expand type)] + (_lux_case type+ + (#Cons [type' #Nil]) + (;return (list (walk-type type'))) + + _ + (fail "The expansion of the type-syntax had to yield a single element."))) -(def__ #export (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')))))))) - - (#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 [_ (#Tuple members)]) - (do Lux:Monad - [members' (map% Lux:Monad macro-expand members)] - (;return (:' SyntaxList (list ($tuple (list:join members')))))) - - _ - (return (:' SyntaxList (list syntax))))) - -(def__ (walk-type type) - (-> Syntax Syntax) - (case' type - (#Meta [_ (#Form (#Cons [(#Meta [_ (#Tag tag)]) parts]))]) - ($form (#Cons [($tag tag) (map walk-type parts)])) - - (#Meta [_ (#Tuple 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)) - -(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."))) - - _ - (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'] - - _ - [false tokens])) - parts (: (Maybe (, Syntax (List Syntax) Syntax)) - (case' tokens' - (#Cons [(#Meta [_ (#Symbol name)]) (#Cons [type #Nil])]) - (#Some [($symbol name) #Nil type]) - - (#Cons [(#Meta [_ (#Form (#Cons [(#Meta [_ (#Symbol name)]) args]))]) (#Cons [type #Nil])]) - (#Some [($symbol name) args 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 - - _ - (`' (;All (~ name) [(~@ args)] (~ type)))))] - (return (: (List Syntax) - (list& (`' (def' (~ name) (;type` (~ type')))) - with-export)))) + (_lux_case tokens + (#Cons [(#Meta [_ (#TagS ["" "export"])]) tokens']) + [true tokens'] - #None - (fail "Wrong syntax for deftype")) - )) + _ + [false tokens])) + [rec? tokens'] (: (, Bool (List Syntax)) + (_lux_case tokens' + (#Cons [(#Meta [_ (#TagS ["" "rec"])]) tokens']) + [true tokens'] + + _ + [false tokens'])) + parts (: (Maybe (, Text (List Syntax) Syntax)) + (_lux_case tokens' + (#Cons [(#Meta [_ (#SymbolS ["" name])]) (#Cons [type #Nil])]) + (#Some [name #Nil type]) + + (#Cons [(#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS ["" name])]) args]))]) (#Cons [type #Nil])]) + (#Some [name args type]) + + _ + #None))] + (_lux_case parts + (#Some [name args type]) + (let [with-export (: (List Syntax) + (if export? + (list (`' (_lux_export (~ (symbol$ ["" name]))))) + #Nil)) + type' (: (Maybe Syntax) + (if rec? + (if (empty? args) + (let [g!param (symbol$ ["" ""]) + prime-name (symbol$ ["" (text:++ name "'")]) + type+ (replace-syntax (list [name (`' ((~ prime-name) (~ g!param)))]) type)] + (#Some (`' ((;All (~ prime-name) [(~ g!param)] (~ type+)) + ;Void)))) + #None) + (_lux_case args + #Nil + (#Some type) -(deftype #export (IO a) - (-> (,) a)) + _ + (#Some (`' (;All (~ (symbol$ ["" name])) [(~@ args)] (~ type)))))))] + (_lux_case type' + (#Some type'') + (return (list& (`' (_lux_def (~ (symbol$ ["" name])) (;type (~ type'')))) + with-export)) -(defmacro #export (io tokens) - (case' tokens - (#Cons [value #Nil]) - (let [blank ($symbol ["" ""])] - (return (: (List Syntax) - (list (`' (lambda' (~ blank) (~ blank) (~ value))))))) + #None + (fail "Wrong syntax for deftype"))) - _ - (fail "Wrong syntax for io"))) + #None + (fail "Wrong syntax for deftype")) + )) +## (defmacro #export (deftype tokens) +## (let [[export? tokens'] (: (, Bool (List Syntax)) +## (_lux_case (:! (List Syntax) tokens) +## (#Cons [(#Meta [_ (#TagS ["" "export"])]) tokens']) +## [true (:! (List Syntax) tokens')] + +## _ +## [false (:! (List Syntax) tokens)])) +## parts (: (Maybe (, Syntax (List Syntax) Syntax)) +## (_lux_case tokens' +## (#Cons [(#Meta [_ (#SymbolS name)]) (#Cons [type #Nil])]) +## (#Some [(symbol$ name) #Nil type]) + +## (#Cons [(#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS name)]) args]))]) (#Cons [type #Nil])]) +## (#Some [(symbol$ name) args type]) + +## _ +## #None))] +## (_lux_case parts +## (#Some [name args type]) +## (let [with-export (: (List Syntax) +## (if export? +## (list (`' (_lux_export (~ name)))) +## #Nil)) +## type' (: Syntax +## (_lux_case args +## #Nil +## type + +## _ +## (`' (;All (~ name) [(~@ args)] (~ type)))))] +## (return (list& (`' (_lux_def (~ name) (;type (~ type')))) +## with-export))) + +## #None +## (fail "Wrong syntax for deftype")) +## )) (defmacro #export (exec tokens) - (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))))) - - _ - (fail "Wrong syntax for exec"))) + (_lux_case (reverse tokens) + (#Cons [value actions]) + (let [dummy (symbol$ ["" ""])] + (return (list (foldL (lambda [post pre] (`' (_lux_case (~ pre) (~ dummy) (~ post)))) + value + actions)))) + + _ + (fail "Wrong syntax for exec"))) (defmacro #export (def tokens) (let [[export? tokens'] (: (, Bool (List Syntax)) - (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]) + (_lux_case tokens' + (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) (#Cons [type (#Cons [body #Nil])])]) + (#Some [name args (#Some type) body]) + + (#Cons [name (#Cons [type (#Cons [body #Nil])])]) + (#Some [name #Nil (#Some type) body]) + + (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) (#Cons [body #Nil])]) + (#Some [name args #None body]) + + (#Cons [name (#Cons [body #Nil])]) + (#Some [name #Nil #None body]) + + _ + #None))] + (_lux_case parts + (#Some [name args ?type body]) + (let [body' (: Syntax + (_lux_case args + #Nil + body + + _ + (`' (;lambda (~ name) [(~@ args)] (~ body))))) + body'' (: Syntax + (_lux_case ?type + (#Some type) + (`' (: (~ type) (~ body'))) - (#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 - - _ - (`' (;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")))) + #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)))) - - _ - (;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)) - )))))) - - _ - (fail "Wrong syntax for case"))) + (_lux_case tokens + (#Cons [value branches]) + (do Lux/Monad + [expansions (map% Lux/Monad + (: (-> (, Syntax Syntax) (Lux (List (, Syntax Syntax)))) + (lambda expander [branch] + (let [[pattern body] branch] + (_lux_case pattern + (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS macro-name)]) macro-args]))]) + (do Lux/Monad + [expansion (macro-expand (form$ (list& (symbol$ macro-name) body macro-args))) + expansions (map% Lux/Monad expander (as-pairs expansion))] + (;return (list:join expansions))) + + _ + (;return (list branch)))))) + (as-pairs branches))] + (;return (list (`' (_lux_case (~ value) + (~@ (|> expansions list:join (map rejoin-pair) list:join))))))) + + _ + (fail "Wrong syntax for case"))) (defmacro #export (\ tokens) (case tokens (#Cons [body (#Cons [pattern #Nil])]) - (do Lux:Monad + (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))) - - _ - (`' (;All (~ name) [(~@ args)] (;sig (~@ sigs))))))] - (return (: (List Syntax) - (list& (`' (def' (~ name) (~ sigs'))) - (if export? - (list (`' (export' (~ name)))) - #Nil))))) + (let [sigs' (: Syntax + (case args + #Nil + (`' (;sig (~@ sigs))) + + _ + (`' (;All (~ name) [(~@ args)] (;sig (~@ sigs))))))] + (return (list& (`' (_lux_def (~ name) (~ sigs'))) + (if export? + (list (`' (_lux_export (~ name)))) + #Nil)))) #None (fail "Wrong syntax for defsig")))) (defmacro #export (struct tokens) - (do Lux:Monad - [tokens' (map% Lux:Monad macro-expand-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))) - - _ - (`' (;lambda (~ name) [(~@ args)] (;struct (~@ defs))))))] - (return (: (List Syntax) - (list& (`' (def (~ name) (~ type) (~ defs'))) - (if export? - (list (`' (export' (~ name)))) - #Nil))))) - - #None - (fail "Wrong syntax for defsig")))) - -(defsig #export (Eq a) - (: (-> a a Bool) - =)) + (let [defs' (: Syntax + (case args + #Nil + (`' (;struct (~@ defs))) -(do-template [<name> <type> <test>] - [(defstruct #export <name> (Eq <type>) - (def (= x y) - (<test> x y)))] + _ + (`' (;lambda (~ name) [(~@ args)] (;struct (~@ defs))))))] + (return (list& (`' (def (~ name) (~ type) (~ defs'))) + (if export? + (list (`' (_lux_export (~ name)))) + #Nil)))) - [Int:Eq Int jvm-leq] - [Real:Eq Real jvm-deq]) + #None + (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."]) - -(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))))] - - [Int:Ord Int jvm-llt jvm-lgt jvm-leq] - [Real:Ord Real jvm-dlt jvm-dgt jvm-deq]) - -(defmacro #export (alias-lux tokens state) + [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'])) + + (\ (#Meta [_ (#FormS (list& (#Meta [_ (#TagS ["" "only"])]) defs))])) + (do Lux/Monad + [defs' (extract-defs defs)] + (return (: (, Referrals (List Syntax)) [(#Only defs') tokens']))) + + (\ (#Meta [_ (#FormS (list& (#Meta [_ (#TagS ["" "exclude"])]) defs))])) + (do Lux/Monad + [defs' (extract-defs defs)] + (return (: (, Referrals (List Syntax)) [(#Exclude defs') tokens']))) + + _ + (fail "Incorrect syntax for referral.")) + + _ + (return (: (, Referrals (List Syntax)) [#Nothing tokens])))) + +(def (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 #export (println x) - (-> Text (,)) - (print (text:++ x "\n"))) +(def (substring2 idx1 idx2 text) + (-> Int Int Text Text) + (_jvm_invokevirtual "java.lang.String" "substring" ["int" "int"] + text [(_jvm_l2i idx1) (_jvm_l2i idx2)])) + +(def (split-module-contexts module) + (-> Text (List Text)) + (#Cons [module (let [idx (last-index-of "/" module)] + (if (i< idx 0) + #Nil + (split-module-contexts (substring2 0 idx module))))])) + +(def (split-module module) + (-> Text (List Text)) + (let [idx (index-of "/" module)] + (if (i< idx 0) + (#Cons [module #Nil]) + (#Cons [(substring2 0 idx module) + (split-module (substring1 (inc idx) module))])))) + +(def (@ idx xs) + (All [a] + (-> Int (List a) (Maybe a))) + (case xs + #Nil + #None + + (#Cons [x xs']) + (if (i= idx 0) + (#Some x) + (@ (dec idx) xs') + ))) -(def #export (some f 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')) - - (#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))))])) - - _ - (#Left "Can only \"use\" records.")))))) + (#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)))) + +(defmacro #export (cond tokens) + (if (i= 0 (i% (length tokens) 2)) + (fail "cond requires an even number of arguments.") + (case (reverse tokens) + (\ (list& else branches')) + (return (list (foldL (: (-> Syntax (, Syntax Syntax) Syntax) + (lambda [else branch] + (let [[right left] branch] + (` (if (~ left) (~ right) (~ else)))))) + else + (as-pairs branches')))) + + _ + (fail "Wrong syntax for cond")))) + +(defmacro #export (get@ tokens) + (case tokens + (\ (list (#Meta [_ (#TagS slot')]) record)) + (case record + (#Meta [_ (#SymbolS name)]) + (do Lux/Monad + [type (find-var-type name) + g!blank (gensym "") + g!output (gensym "")] + (case (resolve-struct-type type) + (#Some (#RecordT slots)) + (do Lux/Monad + [slot (normalize slot')] + (let [[s-prefix s-name] (: Ident slot) + pattern (record$ (map (: (-> (, Text Type) (, Syntax Syntax)) + (lambda [slot] + (let [[r-slot-name r-type] slot + [r-prefix r-name] (split-slot r-slot-name)] + [(tag$ [r-prefix r-name]) (if (and (text:= s-prefix r-prefix) + (text:= s-name r-name)) + g!output + g!blank)]))) + slots))] + (return (list (` (_lux_case (~ record) (~ pattern) (~ g!output))))))) + + _ + (fail "get@ can only use records."))) + _ - (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."))) + + _ + (fail "Wrong syntax for open"))) + +(def (foldL% M f x ys) + (All [m a b] + (-> (Monad m) (-> a b (m a)) a (List b) + (m a))) + (case ys + (#Cons [y ys']) + (do M + [x' (f x y)] + (foldL% M f x' ys')) + + #Nil + ((get@ #return M) x))) + +(defmacro #export (:: tokens) + (case tokens + (\ (list& start parts)) + (do Lux/Monad + [output (foldL% Lux/Monad + (: (-> Syntax Syntax (Lux Syntax)) + (lambda [so-far part] + (case part + (#Meta [_ (#SymbolS slot)]) + (return (` (get@ (~ (tag$ slot)) (~ so-far)))) + + (\ (#Meta [_ (#FormS (list& (#Meta [_ (#SymbolS slot)]) args))])) + (return (` ((get@ (~ (tag$ slot)) (~ so-far)) + (~@ args)))) + + _ + (fail "Wrong syntax for ::")))) + start parts)] + (return (list output))) + + _ + (fail "Wrong syntax for ::"))) + +(defmacro #export (set@ tokens) + (case tokens + (\ (list (#Meta [_ (#TagS slot')]) value record)) + (case record + (#Meta [_ (#SymbolS name)]) + (do Lux/Monad + [type (find-var-type name)] + (case (resolve-struct-type type) + (#Some (#RecordT slots)) + (do Lux/Monad + [pattern' (map% Lux/Monad + (: (-> (, Text Type) (Lux (, Text Syntax))) + (lambda [slot] + (let [[r-slot-name r-type] slot] + (do Lux/Monad + [g!slot (gensym "")] + (return [r-slot-name g!slot]))))) + slots) + slot (normalize slot')] + (let [[s-prefix s-name] (: Ident slot) + pattern (record$ (map (: (-> (, Text Syntax) (, Syntax Syntax)) + (lambda [slot] + (let [[r-slot-name r-var] slot] + [(tag$ (split-slot r-slot-name)) r-var]))) + pattern')) + output (record$ (map (: (-> (, Text Syntax) (, Syntax Syntax)) + (lambda [slot] + (let [[r-slot-name r-var] slot + [r-prefix r-name] (split-slot r-slot-name)] + [(tag$ [r-prefix r-name]) (if (and (text:= s-prefix r-prefix) + (text:= s-name r-name)) + value + r-var)]))) + pattern'))] + (return (list (` (_lux_case (~ record) (~ pattern) (~ output))))))) + + _ + (fail "set@ can only use records."))) + + _ + (do Lux/Monad + [_record (gensym "")] + (return (list (` (let [(~ _record) (~ record)] + (set@ (~ (tag$ slot')) (~ value) (~ _record)))))))) + + _ + (fail "Wrong syntax for set@"))) + +(defmacro #export (update@ tokens) + (case tokens + (\ (list (#Meta [_ (#TagS slot')]) fun record)) + (case record + (#Meta [_ (#SymbolS name)]) + (do Lux/Monad + [type (find-var-type name)] + (case (resolve-struct-type type) + (#Some (#RecordT slots)) + (do Lux/Monad + [pattern' (map% Lux/Monad + (: (-> (, Text Type) (Lux (, Text Syntax))) + (lambda [slot] + (let [[r-slot-name r-type] slot] + (do Lux/Monad + [g!slot (gensym "")] + (return [r-slot-name g!slot]))))) + slots) + slot (normalize slot')] + (let [[s-prefix s-name] (: Ident slot) + pattern (record$ (map (: (-> (, Text Syntax) (, Syntax Syntax)) + (lambda [slot] + (let [[r-slot-name r-var] slot] + [(tag$ (split-slot r-slot-name)) r-var]))) + pattern')) + output (record$ (map (: (-> (, Text Syntax) (, Syntax Syntax)) + (lambda [slot] + (let [[r-slot-name r-var] slot + [r-prefix r-name] (split-slot r-slot-name)] + [(tag$ [r-prefix r-name]) (if (and (text:= s-prefix r-prefix) + (text:= s-name r-name)) + (` ((~ fun) (~ r-var))) + r-var)]))) + pattern'))] + (return (list (` (_lux_case (~ record) (~ pattern) (~ output))))))) + + _ + (fail "update@ can only use records."))) + + _ + (do Lux/Monad + [_record (gensym "")] + (return (list (` (let [(~ _record) (~ record)] + (update@ (~ (tag$ slot')) (~ fun) (~ _record)))))))) + + _ + (fail "Wrong syntax for update@"))) + +(defmacro #export (\template tokens) + (case tokens + (\ (list (#Meta [_ (#TupleS data)]) + (#Meta [_ (#TupleS bindings)]) + (#Meta [_ (#TupleS templates)]))) + (case (: (Maybe (List Syntax)) + (do Maybe/Monad + [bindings' (map% Maybe/Monad get-ident bindings) + data' (map% Maybe/Monad tuple->list data)] + (let [apply (: (-> RepEnv (List Syntax)) + (lambda [env] (map (apply-template env) templates)))] + (|> data' + (join-map (. apply (make-env bindings'))) + ;return)))) + (#Some output) + (return output) + + #None + (fail "Wrong syntax for \\template")) + _ - (#Left "Wrong syntax for defsig"))) - -## (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 (get@ tokens) -## (let [output (case' tokens -## (#Cons [tag (#Cons [record #Nil])]) -## (` (get@' (~ tag) (~ record))) - -## (#Cons [tag #Nil]) -## (` (lambda [record] (get@' (~ tag) record))))] -## (return (list output)))) - -## (defmacro (set@ tokens) -## (let [output (case' tokens -## (#Cons [tag (#Cons [value (#Cons [record #Nil])])]) -## (` (set@' (~ tag) (~ value) (~ record))) - -## (#Cons [tag (#Cons [value #Nil])]) -## (` (lambda [record] (set@' (~ tag) (~ value) record))) - -## (#Cons [tag #Nil]) -## (` (lambda [value record] (set@' (~ tag) value record))))] -## (return (list 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_))) - -## (#Cons [tag (#Cons [func #Nil])]) -## (` (lambda [record] -## (` (set@' (~ tag) ((~ func) (get@' (~ tag) record)) record)))) - -## (#Cons [tag #Nil]) -## (` (lambda [func record] -## (set@' (~ tag) (func (get@' (~ tag) record)) record))))] -## (return (list output)))) - -## (do-template [<name> <member> <type>] -## (def (<name> pair) -## (All [a b] (-> (, a b) <type>)) -## (case pair -## [f s] -## <member>)) - -## [first f a] -## [second s b]) + (fail "Wrong syntax for \\template"))) + +(def #export complement + (All [a] (-> (-> a Bool) (-> a Bool))) + (. not)) + +## (defmacro #export (loop tokens) +## (case tokens +## (\ (list bindings body)) +## (let [pairs (as-pairs bindings) +## vars (map first pairs) +## inits (map second pairs)] +## (if (every? symbol? inits) +## (do Lux/Monad +## [inits' (map% Maybe/Monad get-ident inits) +## init-types (map% Maybe/Monad find-var-type inits')] +## (return (list (` ((lambda (~ (#SymbolS ["" "recur"])) [(~@ vars)] +## (~ body)) +## (~@ inits)))))) +## (do Lux/Monad +## [aliases (map% Maybe/Monad (lambda [_] (gensym "")) inits)] +## (return (list (` (let [(~@ (interleave aliases inits))] +## (loop [(~@ (interleave vars aliases))] +## (~ body))))))))) + +## _ +## (fail "Wrong syntax for loop"))) diff --git a/source/lux/codata/stream.lux b/source/lux/codata/stream.lux new file mode 100644 index 000000000..1d6dd1b50 --- /dev/null +++ b/source/lux/codata/stream.lux @@ -0,0 +1,133 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## The use and distribution terms for this software are covered by the +## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +## which can be found in the file epl-v10.html at the root of this distribution. +## By using this software in any fashion, you are agreeing to be bound by +## the terms of this license. +## You must not remove this notice, or any other, from this software. + +(;import lux + (lux (control (lazy #as L #refer #all) + (functor #as F #refer #all) + (monad #as M #refer #all) + (comonad #as CM #refer #all)) + (meta lux + macro + syntax) + (data (list #as l #refer (#only list list& List/Monad))))) + +## [Types] +(deftype #export (Stream a) + (Lazy (, a (Stream a)))) + +## [Utils] +(def (cycle' x xs init full) + (All [a] + (-> a (List a) a (List a) (Stream a))) + (case xs + #;Nil (cycle' init full init full) + (#;Cons [y xs']) (... [x (cycle' y xs' init full)]))) + +## [Functions] +(def #export (iterate f x) + (All [a] + (-> (-> a a) a (Stream a))) + (... [x (iterate f (f x))])) + +(def #export (repeat x) + (All [a] + (-> a (Stream a))) + (... [x (repeat x)])) + +(def #export (cycle xs) + (All [a] + (-> (List a) (Maybe (Stream a)))) + (case xs + #;Nil #;None + (#;Cons [x xs']) (#;Some (cycle' x xs' x xs')))) + +(do-template [<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))) - -(defn ^:private _meta [token] - (&/V "lux;Meta" (&/T (&/T "" -1 -1) token))) - -(defn ^:private aba1 [analyse eval! exo-type token] + [["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+) + + [["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 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)))) + ;; 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;Int" ?value]]]] - (|do [_ (&type/check exo-type &type/Int)] - (return (&/|list (&/T (&/V "int" ?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;Real" ?value]]]] - (|do [_ (&type/check exo-type &type/Real)] - (return (&/|list (&/T (&/V "real" ?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;Char" ?value]]]] - (|do [_ (&type/check exo-type &type/Char)] - (return (&/|list (&/T (&/V "char" ?value) exo-type)))) + ;; 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;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;Text" ?value]]]] - (|do [_ (&type/check exo-type &type/Text)] - (return (&/|list (&/T (&/V "text" ?value) exo-type)))) + ;; 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) + + [_] + (fail ""))) - [["lux;Meta" [meta ["lux;Tuple" ?elems]]]] - (&&lux/analyse-tuple analyse exo-type ?elems) +(defn ^:private aba6 [analyse eval! compile-module exo-type token] + (matchv ::M/objects [token] + ;; 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;Record" ?elems]]]] - (&&lux/analyse-record analyse exo-type ?elems) + [["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;Tag" ?ident]]]] - (&&lux/analyse-variant analyse exo-type ?ident (_meta (&/V "lux;Tuple" (|list)))) - - [["lux;Meta" [meta ["lux;Symbol" [_ "jvm-null"]]]]] - (return (&/|list (&/T (&/V "jvm-null" nil) (&/V "lux;DataT" "null")))) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_d2l"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] + (&&host/analyse-jvm-d2l analyse exo-type ?value) - [_] - (fail "") - )) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_f2d"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] + (&&host/analyse-jvm-f2d analyse exo-type ?value) -(defn ^:private aba2 [analyse eval! exo-type token] - (matchv ::M/objects [token] - [["lux;Meta" [meta ["lux;Symbol" ?ident]]]] - (&&lux/analyse-symbol analyse exo-type ?ident) + [["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" [_ "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_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" [_ "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;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_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" [_ "import'"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;Text" ?path]]] - ["lux;Nil" _]]]]]]]]] - (&&lux/analyse-import analyse ?path) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_i2c"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] + (&&host/analyse-jvm-i2c 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_i2d"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] + (&&host/analyse-jvm-i2d 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_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" [_ "export'"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" ["" ?ident]]]] - ["lux;Nil" _]]]]]]]]] - (&&lux/analyse-export analyse ?ident) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_i2l"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] + (&&host/analyse-jvm-i2l analyse exo-type ?value) - [_] - (fail ""))) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_i2s"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] + (&&host/analyse-jvm-i2s 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_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-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_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-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_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-idiv"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] - (&&host/analyse-jvm-idiv 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-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_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-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_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-ilt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] - (&&host/analyse-jvm-ilt 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-igt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] - (&&host/analyse-jvm-igt 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) - ;; 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) + [["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-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_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-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_lushr"]]]] ["lux;Cons" [?x ["lux;Cons" [?y ["lux;Nil" _]]]]]]]]] + (&&host/analyse-jvm-lushr analyse exo-type ?x ?y) + + [_] + (aba7 analyse eval! compile-module exo-type token))) - [["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) +(defn ^:private aba5 [analyse eval! compile-module exo-type token] + (matchv ::M/objects [token] + ;; 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;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;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;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;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;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) + + [["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;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;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;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-lrem"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] - (&&host/analyse-jvm-lrem 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-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_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-llt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] - (&&host/analyse-jvm-llt 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-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_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 aba4 [analyse eval! exo-type token] +(defn ^:private aba4 [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;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-fsub"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] - (&&host/analyse-jvm-fsub analyse ?x ?y) + [["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-fmul"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] - (&&host/analyse-jvm-fmul analyse ?x ?y) + [["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-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_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-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_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-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_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-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_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-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_fgt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + (&&host/analyse-jvm-fgt analyse exo-type ?x ?y) ;; 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_dadd"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + (&&host/analyse-jvm-dadd analyse exo-type ?x ?y) - [["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_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-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_dmul"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + (&&host/analyse-jvm-dmul analyse exo-type ?x ?y) - [["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_ddiv"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + (&&host/analyse-jvm-ddiv analyse exo-type ?x ?y) - [["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) + [["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-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_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-dlt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] - (&&host/analyse-jvm-dlt analyse ?x ?y) + [["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-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_dgt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + (&&host/analyse-jvm-dgt analyse exo-type ?x ?y) [_] - (fail ""))) + (aba5 analyse eval! compile-module exo-type token))) -(defn ^:private aba5 [analyse eval! exo-type token] +(defn ^:private aba3 [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) - - [["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;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;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;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;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;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;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)) + ;; 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-throw"]]]] - ["lux;Cons" [?ex - ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-throw analyse ?ex) + [["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) - ;; 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_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-monitorexit"]]]] - ["lux;Cons" [?monitor - ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-monitorexit analyse ?monitor) + [["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) - [_] - (fail ""))) + [["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) -(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_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-d2i"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-d2i 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-d2l"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-d2l 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-f2d"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-f2d 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-f2i"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-f2i 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) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-f2l"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-f2l analyse ?value) + ;; 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-i2b"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-i2b analyse ?value) + [["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-i2c"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-i2c analyse ?value) + [["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-i2d"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-i2d analyse ?value) + [["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-i2f"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-i2f analyse ?value) + [["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-i2l"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-i2l analyse ?value) + [["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-i2s"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-i2s analyse ?value) + [["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-l2d"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-l2d analyse ?value) + [["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) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-l2f"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-l2f analyse ?value) + [_] + (aba4 analyse eval! compile-module exo-type token))) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-l2i"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-l2i analyse ?value) +(defn ^:private aba2 [analyse eval! compile-module exo-type token] + (matchv ::M/objects [token] + [["lux;SymbolS" ?ident]] + (&&lux/analyse-symbol analyse exo-type ?ident) - ;; 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) + [["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-ior"]]]] ["lux;Cons" [?x ["lux;Cons" [?y ["lux;Nil" _]]]]]]]]]]] - (&&host/analyse-jvm-ior analyse ?x ?y) + [["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) - [["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" [_ "_lux_import"]]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?path]]] + ["lux;Nil" _]]]]]]] + (&&lux/analyse-import analyse compile-module ?path) - [["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" [_ "_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-lxor"]]]] ["lux;Cons" [?x ["lux;Cons" [?y ["lux;Nil" _]]]]]]]]]]] - (&&host/analyse-jvm-lxor analyse ?x ?y) + [["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) - [["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" [_ "_lux_export"]]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ["" ?ident]]]] + ["lux;Nil" _]]]]]]] + (&&lux/analyse-export analyse ?ident) - [["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" [_ "_lux_alias"]]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?alias]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?module]]] + ["lux;Nil" _]]]]]]]]] + (&&lux/analyse-alias analyse ?alias ?module) + + [_] + (aba3 analyse eval! compile-module exo-type token))) - [["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) +(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)))) - [_] - (fail ""))) + [["lux;IntS" ?value]] + (|do [_ (&type/check exo-type &type/Int)] + (return (&/|list (&/T (&/V "int" ?value) exo-type)))) -(defn ^:private aba7 [analyse eval! 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;RealS" ?value]] + (|do [_ (&type/check exo-type &type/Real)] + (return (&/|list (&/T (&/V "real" ?value) exo-type)))) - [["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;CharS" ?value]] + (|do [_ (&type/check exo-type &type/Char)] + (return (&/|list (&/T (&/V "char" ?value) exo-type)))) - [["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;TextS" ?value]] + (|do [_ (&type/check exo-type &type/Text)] + (return (&/|list (&/T (&/V "text" ?value) exo-type)))) - ;; 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;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;TupleS" ?elems]] + (&&lux/analyse-tuple analyse exo-type ?elems) - ;; 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) - - [_] - (fail ""))) + [["lux;RecordS" ?elems]] + (&&lux/analyse-record analyse exo-type ?elems) -(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;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) - - [_] - (matchv ::M/objects [((aba4 analyse eval! exo-type token) state)] - [["lux;Right" [state* output]]] - (return* state* output) - - [_] - (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) - - [_] - (matchv ::M/objects [((aba7 analyse eval! exo-type token) state)] - [["lux;Right" [state* output]]] - (return* state* output) - - [_] - (fail* (str "[Analyser Error] Unmatched token: " (&/show-ast token)))))))))))) - -(defn ^:private analyse-ast [eval! exo-type token] - ;; (prn 'analyse-ast (aget token 0)) + [["lux;Left" ""]] + (fail* (add-loc meta (str "[Analyser Error] Unrecognized token: " (&/show-ast token)))) + + [["lux;Left" msg]] + (fail* (add-loc meta msg)) + )) + + ;; [_] + ;; (assert false (aget token 0)) + )) + +(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))) + + [_ _] + (return (&/T ?output-term ?output-type))) + )))) + +(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))) - - [["lux;Bool" ?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;Real" ?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;Text" ?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))))) + (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;BoolS" ?value]] + (|do [_ (&type/check value-type &type/Bool) + =kont kont] + (return (&/T (&/V "BoolTestAC" ?value) =kont))) + + [["lux;IntS" ?value]] + (|do [_ (&type/check value-type &type/Int) + =kont kont] + (return (&/T (&/V "IntTestAC" ?value) =kont))) + + [["lux;RealS" ?value]] + (|do [_ (&type/check value-type &type/Real) + =kont kont] + (return (&/T (&/V "RealTestAC" ?value) =kont))) + + [["lux;CharS" ?value]] + (|do [_ (&type/check value-type &type/Char) + =kont kont] + (return (&/T (&/V "CharTestAC" ?value) =kont))) + + [["lux;TextS" ?value]] + (|do [_ (&type/check value-type &type/Text) + =kont kont] + (return (&/T (&/V "TextTestAC" ?value) =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 (str "[Pattern-matching Error] Tuples require tuple-types: " (&type/show-type value-type*)))))) + + [["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 (&/|list) =kont))) - (&/|reverse (&/zip2 ?member-types ?members)))] - (return (&/T (&/V "TupleTestAC" =tests) =kont)))) + (return (&/T (&/|table) =kont))) + (&/|reverse ?slots))] + (return (&/T (&/V "RecordTestAC" =tests) =kont)))) [_] - (fail "[Analyser Error] Tuple requires tuple-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)))) - - [_] - (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."))) - - [["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;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))) - )))) + (fail "[Pattern-matching Error] Record requires record-type."))) + + [["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;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-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-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-putfield [analyse ?class ?field ?object ?value] - (|do [=class (&host/full-class-name ?class) - =type (&host/lookup-static-field =class ?field) - =object (&&/analyse-1 analyse ?object) - =value (&&/analyse-1 analyse ?value)] - (return (&/|list (&/T (&/V "jvm-putfield" (&/T =class ?field =object =value)) =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-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-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 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 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 =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-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-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-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 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 {})))))) - -(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]]))) + =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)) + + [_] + (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] Wrong syntax for method."))) + (&/enumerate ?methods))] + (return (&/|list (&/V "jvm-class" (&/T ?name ?super-class =interfaces =fields =methods)))))) + +(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 "[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)))))) - -(defn analyse-jvm-try [analyse ?body [?catches ?finally]] - (|do [=body (&&/analyse-1 analyse ?body) + (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))))) - -(defn analyse-jvm-throw [analyse ?ex] - (|do [=ex (&&/analyse-1 analyse ?ex)] + =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 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))))))) - -(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))))))) +(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))))) + + 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) - - [["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;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;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) - - [_] - (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))) - )))) + (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;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" _]]]] + (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;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) + + [_] + (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**))) - )))) - - [["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*)) - - [_] - (fail (str "[Analyser Error] Can't apply a non-function: " (&type/show-type ?fun-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 [[=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)))) + + ;; [["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 "")))) - - ;; :else - ;; nil)] - ] - (&/flat-map% (partial analyse exo-type) macro-expansion)) + (&/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) - - [_] - (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))))))) + (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 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) - - [["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) - - [["text" ?value]] - (&&lux/compile-text compile-expression ?type ?value) - - [["tuple" ?elems]] - (&&lux/compile-tuple compile-expression ?type ?elems) - - [["record" ?elems]] - (&&lux/compile-record compile-expression ?type ?elems) - - [["lux;Local" ?idx]] - (&&lux/compile-local compile-expression ?type ?idx) - - [["captured" [?scope ?captured-id ?source]]] - (&&lux/compile-captured compile-expression ?type ?scope ?captured-id ?source) - - [["lux;Global" [?owner-class ?name]]] - (&&lux/compile-global compile-expression ?type ?owner-class ?name) - - [["apply" [?fn ?arg]]] - (&&lux/compile-apply compile-expression ?type ?fn ?arg) - - [["variant" [?tag ?members]]] - (&&lux/compile-variant compile-expression ?type ?tag ?members) - - [["case" [?value ?match]]] - (&&case/compile-case compile-expression ?type ?value ?match) - - [["lambda" [?scope ?env ?body]]] - (&&lambda/compile-lambda compile-expression ?scope ?env ?body) - - ;; 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-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-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) - - [["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-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) - - [["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-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) - - [["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-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-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-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-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-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) + (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) + + [["text" ?value]] + (&&lux/compile-text compile-expression ?type ?value) + + [["tuple" ?elems]] + (&&lux/compile-tuple compile-expression ?type ?elems) + + [["record" ?elems]] + (&&lux/compile-record compile-expression ?type ?elems) + + [["lux;Local" ?idx]] + (&&lux/compile-local compile-expression ?type ?idx) + + [["captured" [?scope ?captured-id ?source]]] + (&&lux/compile-captured compile-expression ?type ?scope ?captured-id ?source) + + [["lux;Global" [?owner-class ?name]]] + (&&lux/compile-global compile-expression ?type ?owner-class ?name) + + [["apply" [?fn ?args]]] + (&&lux/compile-apply compile-expression ?type ?fn ?args) + + [["variant" [?tag ?members]]] + (&&lux/compile-variant compile-expression ?type ?tag ?members) + + [["case" [?value ?match]]] + (&&case/compile-case compile-expression ?type ?value ?match) + + [["lambda" [?scope ?env ?body]]] + (&&lambda/compile-lambda compile-expression ?scope ?env ?body) + + [["ann" [?value-ex ?type-ex]]] + (&&lux/compile-ann compile-expression ?type ?value-ex ?type-ex) + + ;; Characters + [["jvm-ceq" [?x ?y]]] + (&&host/compile-jvm-ceq compile-expression ?type ?x ?y) + + [["jvm-clt" [?x ?y]]] + (&&host/compile-jvm-clt 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-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-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) + + [["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-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) + + [["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-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) + + [["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-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-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-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-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-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-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))) - -(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))))))) + (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))))))) + ))) + +(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-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-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" &&/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 ^: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-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 ?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 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-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)))) - - 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 <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 ) (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) - - [["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**)))) - ) - - [_] - (|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 [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 (.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)))) (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) - - [[k v]] - (str "(#" k " " (show-type v) ")")))) - (&/|interpose " ") - (&/fold str "")) ")") + (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 "")) ")")) [["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*) - - [_] - [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)))) + (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) ")")) + ?name) )) (defn type= [x y] - ;; (prn "^^ type= ^^") - (let [output (matchv ::M/objects [x y] - [["lux;DataT" xname] ["lux;DataT" yname]] - (= 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;VariantT" xcases] ["lux;VariantT" ycases]] - (and (= (&/|length xcases) (&/|length ycases)) - (&/fold (fn [old case] - (and old - (type= (&/|get case xcases) (&/|get case ycases)))) + (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]] + (&/fold2 (fn [old x y] + (and old (type= x y))) + true + xelems yelems) + + [["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))) - - [["lux;LambdaT" [xinput xoutput]] ["lux;LambdaT" [yinput youtput]]] - (and (type= xinput yinput) - (type= xoutput youtput)) - - [["lux;VarT" xid] ["lux;VarT" yid]] - (= xid yid) - - [["lux;BoundT" xname] ["lux;BoundT" yname]] - (= xname yname) - - [["lux;ExT" xid] ["lux;ExT" yid]] - (= 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) + xslots yslots) + + [["lux;LambdaT" [xinput xoutput]] ["lux;LambdaT" [yinput youtput]]] + (and (type= xinput yinput) + (type= xoutput youtput)) + + [["lux;VarT" xid] ["lux;VarT" yid]] + (.equals ^Object xid yid) + + [["lux;BoundT" xname] ["lux;BoundT" yname]] + (.equals ^Object xname yname) + + [["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]]] + (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)) - -(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) - - [["lux;None" _] ["lux;Some" atype]] - (check* fixpoints expected atype) - - [["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)))) - - [_ ["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))) - - ;; [["lux;None" _]] - ;; (|do [actual* (apply-type F A)] - ;; (check* (fp-put fp-pair true fixpoints) expected actual*)))) - - [["lux;AllT" _] _] - (with-var - (fn [$arg] - (|do [expected* (apply-type expected $arg)] - (check* fixpoints expected* actual)))) - - [_ ["lux;AllT" _]] - (with-var - (fn [$arg] - (|do [actual* (apply-type actual $arg)] - (check* fixpoints expected actual*)))) - - [["lux;DataT" "boolean"] ["lux;DataT" "java.lang.Boolean"]] - (return (&/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;DataT" "int"] ["lux;DataT" "java.lang.Integer"]] - (return (&/T fixpoints nil)) - - [["lux;DataT" "long"] ["lux;DataT" "java.lang.Long"]] - (return (&/T fixpoints nil)) - - [["lux;DataT" "float"] ["lux;DataT" "java.lang.Float"]] - (return (&/T fixpoints nil)) - - [["lux;DataT" "double"] ["lux;DataT" "java.lang.Double"]] - (return (&/T fixpoints nil)) - - [["lux;DataT" "char"] ["lux;DataT" "java.lang.Character"]] - (return (&/T fixpoints nil)) - - [["lux;DataT" "java.lang.Boolean"] ["lux;DataT" "boolean"]] - (return (&/T fixpoints nil)) - - [["lux;DataT" "java.lang.Byte"] ["lux;DataT" "byte"]] - (return (&/T fixpoints nil)) - - [["lux;DataT" "java.lang.Short"] ["lux;DataT" "short"]] - (return (&/T fixpoints nil)) - - [["lux;DataT" "java.lang.Integer"] ["lux;DataT" "int"]] - (return (&/T fixpoints nil)) - - [["lux;DataT" "java.lang.Long"] ["lux;DataT" "long"]] - (return (&/T fixpoints nil)) - - [["lux;DataT" "java.lang.Float"] ["lux;DataT" "float"]] - (return (&/T fixpoints nil)) - - [["lux;DataT" "java.lang.Double"] ["lux;DataT" "double"]] - (return (&/T fixpoints nil)) - - [["lux;DataT" "java.lang.Character"] ["lux;DataT" "char"]] + (fail (str "[Type System] Not type function:\n" (show-type type-fn) "\n")))) + +(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)) + +(def ^:private primitive-types #{"boolean" "byte" "short" "int" "long" "float" "double" "char"}) + +(def ^:private init-fixpoints (&/|list)) + +(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;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;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;None" _] ["lux;Some" atype]] + (check* class-loader fixpoints expected atype) + + [["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;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;Left" _]] + ((|do [bound (deref ?id)] + (check* class-loader fixpoints expected bound)) + state))) + + [["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;Left" _]] + ((check* class-loader fixpoints (&/V "lux;AppT" (&/T F1 A1)) actual) + state)))) + state)] + [["lux;Right" [state* output]]] + (return* state* output) + + [["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;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;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;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;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" 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;LambdaT" [eI eO]] ["lux;LambdaT" [aI aO]]] - (|do [[fixpoints* _] (check* fixpoints aI eI)] - (check* 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;None" _]] + (|do [expected* (apply-type F A)] + (check* class-loader (fp-put fp-pair true fixpoints) expected* actual)))) + + [_ ["lux;AppT" [F A]]] + (|do [actual* (apply-type F A)] + (check* class-loader fixpoints expected actual*)) + + [["lux;AllT" _] _] + (with-var + (fn [$arg] + (|do [expected* (apply-type expected $arg)] + (check* class-loader fixpoints expected* actual)))) + + [_ ["lux;AllT" _]] + (with-var + (fn [$arg] + (|do [actual* (apply-type actual $arg)] + (check* class-loader fixpoints expected actual*)))) + + [["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]] + (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* class-loader fixpoints aI eI)] + (check* class-loader fixpoints* eO aO)) + + [["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) )) |