diff options
Diffstat (limited to '')
43 files changed, 38 insertions, 6599 deletions
diff --git a/project.clj b/project.clj index 64b4141c2..7cc66da22 100644 --- a/project.clj +++ b/project.clj @@ -5,7 +5,6 @@ :url "https://www.mozilla.org/en-US/MPL/2.0/"} :dependencies [[org.clojure/clojure "1.6.0"] [org.clojure/core.match "0.2.1"] - [org.ow2.asm/asm-all "5.0.3"] - [org.apache.commons/commons-compress "1.10"]] + [org.ow2.asm/asm-all "5.0.3"]] :warn-on-reflection true :main lux) diff --git a/source/lux.lux b/source/lux.lux deleted file mode 100644 index 4d1c3fdef..000000000 --- a/source/lux.lux +++ /dev/null @@ -1,3303 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -## If a copy of the MPL was not distributed with this file, -## You can obtain one at http://mozilla.org/MPL/2.0/. - -## First things first, must define functions -(_jvm_interface "Function" [] [] - ("apply" ["public" "abstract"] [] [] ["java.lang.Object"] "java.lang.Object")) - -## Basic types -(_lux_def Bool (10 ["lux" "Bool"] - (0 "java.lang.Boolean" (0)))) -(_lux_export Bool) - -(_lux_def Int (10 ["lux" "Int"] - (0 "java.lang.Long" (0)))) -(_lux_export Int) - -(_lux_def Real (10 ["lux" "Real"] - (0 "java.lang.Double" (0)))) -(_lux_export Real) - -(_lux_def Char (10 ["lux" "Char"] - (0 "java.lang.Character" (0)))) -(_lux_export Char) - -(_lux_def Text (10 ["lux" "Text"] - (0 "java.lang.String" (0)))) -(_lux_export Text) - -(_lux_def Unit (10 ["lux" "Unit"] - (2 (0)))) -(_lux_export Unit) - -(_lux_def Void (10 ["lux" "Void"] - (1 (0)))) -(_lux_export Void) - -(_lux_def Ident (10 ["lux" "Ident"] - (2 (1 Text (1 Text (0)))))) -(_lux_export Ident) - -## (deftype (List a) -## (| #Nil -## (#Cons a (List a)))) -(_lux_def List - (10 ["lux" "List"] - (7 (0) - (1 (1 ## "lux;Nil" - (2 (0)) - (1 ## "lux;Cons" - (2 (1 (4 1) - (1 (9 (4 0) (4 1)) - (0)))) - (0))))))) -(_lux_export List) -(_lux_declare-tags [#Nil #Cons] List) - -## (deftype (Maybe a) -## (| #None -## (1 a))) -(_lux_def Maybe - (10 ["lux" "Maybe"] - (7 (0) - (1 (1 ## "lux;None" - (2 (0)) - (1 ## "lux;Some" - (4 1) - (0))))))) -(_lux_export Maybe) -(_lux_declare-tags [#None #Some] Maybe) - -## (deftype #rec Type -## (| (#DataT (, Text (List Type))) -## (#VariantT (List Type)) -## (#TupleT (List Type)) -## (#LambdaT Type Type) -## (#BoundT Int) -## (#VarT Int) -## (#ExT Int) -## (#UnivQ (List Type) Type) -## (#ExQ (List Type) Type) -## (#AppT Type Type) -## (#NamedT Ident Type) -## )) -(_lux_def Type - (10 ["lux" "Type"] - (_lux_case (9 (4 0) (4 1)) - Type - (_lux_case (9 List Type) - TypeList - (9 (7 (0) - (1 (1 ## "lux;DataT" - (2 (1 Text (1 TypeList (0)))) - (1 ## "lux;VariantT" - TypeList - (1 ## "lux;TupleT" - TypeList - (1 ## "lux;LambdaT" - (2 (1 Type (1 Type (0)))) - (1 ## "lux;BoundT" - Int - (1 ## "lux;VarT" - Int - (1 ## "lux;ExT" - Int - (1 ## "lux;UnivQ" - (2 (1 TypeList (1 Type (0)))) - (1 ## "lux;ExQ" - (2 (1 TypeList (1 Type (0)))) - (1 ## "lux;AppT" - (2 (1 Type (1 Type (0)))) - (1 ## "lux;NamedT" - (2 (1 Ident (1 Type (0)))) - (0)))))))))))))) - Void))))) -(_lux_export Type) -(_lux_declare-tags [#DataT #VariantT #TupleT #LambdaT #BoundT #VarT #ExT #UnivQ #ExQ #AppT #NamedT] Type) - -## (deftype (Bindings k v) -## (& #counter Int -## #mappings (List (, k v)))) -(_lux_def Bindings - (#NamedT ["lux" "Bindings"] - (#UnivQ #Nil - (#UnivQ #Nil - (#TupleT (#Cons ## "lux;counter" - Int - (#Cons ## "lux;mappings" - (#AppT List - (#TupleT (#Cons (#BoundT 3) - (#Cons (#BoundT 1) - #Nil)))) - #Nil))))))) -(_lux_export Bindings) -(_lux_declare-tags [#counter #mappings] Bindings) - -## (deftype (Env k v) -## (& #name Text -## #inner-closures Int -## #locals (Bindings k v) -## #closure (Bindings k v))) -(_lux_def Env - (#NamedT ["lux" "Env"] - (#UnivQ #Nil - (#UnivQ #Nil - (#TupleT (#Cons ## "lux;name" - Text - (#Cons ## "lux;inner-closures" - Int - (#Cons ## "lux;locals" - (#AppT (#AppT Bindings (#BoundT 3)) - (#BoundT 1)) - (#Cons ## "lux;closure" - (#AppT (#AppT Bindings (#BoundT 3)) - (#BoundT 1)) - #Nil))))))))) -(_lux_export Env) -(_lux_declare-tags [#name #inner-closures #locals #closure] Env) - -## (deftype Cursor -## (& #module Text -## #line Int -## #column Int)) -(_lux_def Cursor - (#NamedT ["lux" "Cursor"] - (#TupleT (#Cons Text (#Cons Int (#Cons Int #Nil)))))) -(_lux_export Cursor) -(_lux_declare-tags [#module #line #column] Cursor) - -## (deftype (Meta m v) -## (& #meta m -## #datum v)) -(_lux_def Meta - (#NamedT ["lux" "Meta"] - (#UnivQ #Nil - (#UnivQ #Nil - (#TupleT (#Cons (#BoundT 3) - (#Cons (#BoundT 1) - #Nil))))))) -(_lux_export Meta) -(_lux_declare-tags [#meta #datum] Meta) - -## (deftype (AST' w) -## (| (#BoolS Bool) -## (#IntS Int) -## (#RealS Real) -## (#CharS Char) -## (#TextS Text) -## (#SymbolS Text Text) -## (#TagS Text Text) -## (#FormS (List (w (AST' w)))) -## (#TupleS (List (w (AST' w)))) -## (#RecordS (List (, (w (AST' w)) (w (AST' w))))))) -(_lux_def AST' - (#NamedT ["lux" "AST'"] - (_lux_case (#AppT (#BoundT 1) - (#AppT (#BoundT 0) - (#BoundT 1))) - AST - (_lux_case (#AppT [List AST]) - ASTList - (#UnivQ #Nil - (#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" - ASTList - (#Cons ## "lux;TupleS" - ASTList - (#Cons ## "lux;RecordS" - (#AppT List (#TupleT (#Cons AST (#Cons AST #Nil)))) - #Nil) - ))))))))) - )))))) -(_lux_export AST') -(_lux_declare-tags [#BoolS #IntS #RealS #CharS #TextS #SymbolS #TagS #FormS #TupleS #RecordS] AST') - -## (deftype AST -## (Meta Cursor (AST' (Meta Cursor)))) -(_lux_def AST - (#NamedT ["lux" "AST"] - (_lux_case (#AppT Meta Cursor) - w - (#AppT w (#AppT AST' w))))) -(_lux_export AST) - -(_lux_def ASTList (#AppT List AST)) - -## (deftype (Either l r) -## (| (#Left l) -## (#Right r))) -(_lux_def Either - (#NamedT ["lux" "Either"] - (#UnivQ #Nil - (#UnivQ #Nil - (#VariantT (#Cons ## "lux;Left" - (#BoundT 3) - (#Cons ## "lux;Right" - (#BoundT 1) - #Nil))))))) -(_lux_export Either) -(_lux_declare-tags [#Left #Right] Either) - -## (deftype (StateE s a) -## (-> s (Either Text (, s a)))) -(_lux_def StateE - (#UnivQ #Nil - (#UnivQ #Nil - (#LambdaT (#BoundT 3) - (#AppT (#AppT Either Text) - (#TupleT (#Cons (#BoundT 3) - (#Cons (#BoundT 1) - #Nil)))))))) - -## (deftype Source -## (List (Meta Cursor Text))) -(_lux_def Source - (#NamedT ["lux" "Source"] - (#AppT [List - (#AppT [(#AppT [Meta Cursor]) - Text])]))) -(_lux_export Source) - -## (deftype (DefData' m) -## (| (#TypeD Type) -## (#ValueD (, Type Unit)) -## (#MacroD m) -## (#AliasD Ident))) -(_lux_def DefData' - (#NamedT ["lux" "DefData'"] - (#UnivQ #Nil - (#VariantT (#Cons ## "lux;ValueD" - (#TupleT (#Cons Type (#Cons Unit #Nil))) - (#Cons ## "lux;TypeD" - Type - (#Cons ## "lux;MacroD" - (#BoundT 1) - (#Cons ## "lux;AliasD" - Ident - #Nil)))))))) -(_lux_export DefData') - -(_lux_def Analysis - (#NamedT ["lux" "Analysis"] - Void)) -(_lux_export Analysis) - -## (deftype (Module Compiler) -## (& #module-aliases (List (, Text Text)) -## #defs (List (, Text (, Bool (DefData' (-> (List AST) (StateE Compiler (List AST))))))) -## #imports (List Text) -## #tags (List (, Text (, Int (List Ident) Type))) -## #types (List (, Text (, (List Ident) Type))) -## )) -(_lux_def Module - (#NamedT ["lux" "Module"] - (#UnivQ #Nil - (#TupleT (#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 ASTList - (#AppT (#AppT StateE (#BoundT 1)) - ASTList))) - #Nil))) - #Nil)))) - (#Cons ## "lux;imports" - (#AppT List Text) - (#Cons ## "lux;tags" - (#AppT List - (#TupleT (#Cons Text - (#Cons (#TupleT (#Cons Int - (#Cons (#AppT List Ident) - (#Cons Type - #Nil)))) - #Nil)))) - (#Cons ## "lux;types" - (#AppT List - (#TupleT (#Cons Text - (#Cons (#TupleT (#Cons (#AppT List Ident) - (#Cons Type - #Nil))) - #Nil)))) - #Nil))))))))) -(_lux_export Module) -(_lux_declare-tags [#module-aliases #defs #imports #tags #types] Module) - -## (deftype #rec Compiler -## (& #source Source -## #cursor Cursor -## #modules (List (, Text (Module Compiler))) -## #envs (List (Env Text (Meta (, Type Cursor) Analysis))) -## #type-vars (Bindings Int Type) -## #expected Type -## #seed Int -## #eval? Bool -## #host Void -## )) -(_lux_def Compiler - (#NamedT ["lux" "Compiler"] - (#AppT (#UnivQ #Nil - (#TupleT (#Cons ## "lux;source" - Source - (#Cons ## "lux;cursor" - Cursor - (#Cons ## "lux;modules" - (#AppT List (#TupleT (#Cons Text - (#Cons (#AppT Module (#AppT (#BoundT 0) (#BoundT 1))) - #Nil)))) - (#Cons ## "lux;envs" - (#AppT List (#AppT (#AppT Env Text) - (#AppT (#AppT Meta - (#TupleT (#Cons Type (#Cons Cursor #Nil)))) - Analysis))) - (#Cons ## "lux;type-vars" - (#AppT (#AppT Bindings Int) Type) - (#Cons ## "lux;expected" - Type - (#Cons ## "lux;seed" - Int - (#Cons ## "lux;eval?" - Bool - (#Cons ## "lux;host" - Void - #Nil))))))))))) - Void))) -(_lux_export Compiler) -(_lux_declare-tags [#source #cursor #modules #envs #type-vars #expected #seed #eval? #host] Compiler) - -## (deftype Macro -## (-> (List AST) (StateE Compiler (List AST)))) -(_lux_def Macro - (#NamedT ["lux" "Macro"] - (#LambdaT ASTList - (#AppT (#AppT StateE Compiler) - ASTList)))) -(_lux_export Macro) - -(_lux_def DefData - (#NamedT ["lux" "DefData"] - (#AppT DefData' Macro))) -(_lux_export DefData) -(_lux_declare-tags [#ValueD #TypeD #MacroD #AliasD] DefData) - -(_lux_def Definition - (#NamedT ["lux" "Definition"] - (#AppT (#AppT Meta Bool) DefData))) -(_lux_export Definition) - -## Base functions & macros -## (def _cursor -## Cursor -## ["" -1 -1]) -(_lux_def _cursor - (_lux_: Cursor ["" -1 -1])) - -## (def (_meta data) -## (-> (AST' (Meta Cursor)) AST) -## [["" -1 -1] data]) -(_lux_def _meta - (_lux_: (#LambdaT (#AppT AST' - (#AppT Meta Cursor)) - AST) - (_lux_lambda _ data - [_cursor data]))) - -## (def (return x) -## (All [a] -## (-> a Compiler -## (Either Text (, Compiler a)))) -## ...) -(_lux_def return - (_lux_: (#UnivQ #Nil - (#LambdaT (#BoundT 1) - (#LambdaT Compiler - (#AppT (#AppT Either Text) - (#TupleT (#Cons Compiler - (#Cons (#BoundT 1) - #Nil))))))) - (_lux_lambda _ val - (_lux_lambda _ state - (#Right state val))))) - -## (def (fail msg) -## (All [a] -## (-> Text Compiler -## (Either Text (, Compiler a)))) -## ...) -(_lux_def fail - (_lux_: (#UnivQ #Nil - (#LambdaT Text - (#LambdaT Compiler - (#AppT (#AppT Either Text) - (#TupleT (#Cons Compiler - (#Cons (#BoundT 1) - #Nil))))))) - (_lux_lambda _ msg - (_lux_lambda _ state - (#Left msg))))) - -(_lux_def bool$ - (_lux_: (#LambdaT Bool AST) - (_lux_lambda _ value - (_meta (#BoolS value))))) - -(_lux_def int$ - (_lux_: (#LambdaT Int AST) - (_lux_lambda _ value - (_meta (#IntS value))))) - -(_lux_def real$ - (_lux_: (#LambdaT Real AST) - (_lux_lambda _ value - (_meta (#RealS value))))) - -(_lux_def char$ - (_lux_: (#LambdaT Char AST) - (_lux_lambda _ value - (_meta (#CharS value))))) - -(_lux_def text$ - (_lux_: (#LambdaT Text AST) - (_lux_lambda _ text - (_meta (#TextS text))))) - -(_lux_def symbol$ - (_lux_: (#LambdaT Ident AST) - (_lux_lambda _ ident - (_meta (#SymbolS ident))))) - -(_lux_def tag$ - (_lux_: (#LambdaT Ident AST) - (_lux_lambda _ ident - (_meta (#TagS ident))))) - -(_lux_def form$ - (_lux_: (#LambdaT (#AppT List AST) AST) - (_lux_lambda _ tokens - (_meta (#FormS tokens))))) - -(_lux_def tuple$ - (_lux_: (#LambdaT (#AppT List AST) AST) - (_lux_lambda _ tokens - (_meta (#TupleS tokens))))) - -(_lux_def record$ - (_lux_: (#LambdaT (#AppT List (#TupleT (#Cons AST (#Cons AST #Nil)))) AST) - (_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 [_ (#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 [_ (#SymbolS "" self)] (#Cons [_ (#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 [[_ (#TagS ["" "export"])] - (#Cons [[_ (#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 [[_ (#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 [[_ (#FormS (#Cons [name args]))] - (#Cons [type (#Cons [body #Nil])])]) - (return (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_def"])) - (#Cons [name - (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_:"])) - (#Cons [type - (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "lambda''"])) - (#Cons [name - (#Cons [(_meta (#TupleS args)) - (#Cons [body #Nil])])])]))) - #Nil])])]))) - #Nil])])]))) - #Nil])) - - (#Cons [name (#Cons [type (#Cons [body #Nil])])]) - (return (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_def"])) - (#Cons [name - (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_:"])) - (#Cons [type - (#Cons [body - #Nil])])]))) - #Nil])])]))) - #Nil])) - - _ - (fail "Wrong syntax for def''")) - ))) -(_lux_declare-macro def'') - -(def'' (defmacro' tokens) - Macro - (_lux_case tokens - (#Cons [[_ (#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 [[_ (#TagS ["" "export"])] (#Cons [[_ (#FormS (#Cons [name args]))] (#Cons [body #Nil])])]) - (return (#Cons [(form$ (#Cons [(symbol$ ["lux" "def''"]) - (#Cons [(tag$ ["" "export"]) - (#Cons [(form$ (#Cons [name args])) - (#Cons [(symbol$ ["lux" "Macro"]) - (#Cons [body - #Nil])]) - ])])])) - (#Cons [(form$ (#Cons [(symbol$ ["" "_lux_declare-macro"]) (#Cons [name #Nil])])) - #Nil])])) - - _ - (fail "Wrong syntax for defmacro'"))) -(_lux_declare-macro defmacro') - -(defmacro' #export (comment tokens) - (return #Nil)) - -(defmacro' ($' tokens) - (_lux_case tokens - (#Cons x #Nil) - (return tokens) - - (#Cons x (#Cons y xs)) - (return (#Cons (form$ (#Cons (symbol$ ["lux" "$'"]) - (#Cons (form$ (#Cons (tag$ ["lux" "AppT"]) - (#Cons x (#Cons y #Nil)))) - xs))) - #Nil)) - - _ - (fail "Wrong syntax for $'"))) - -(def'' (map f xs) - (#UnivQ #Nil - (#UnivQ #Nil - (#LambdaT (#LambdaT (#BoundT 3) (#BoundT 1)) - (#LambdaT ($' List (#BoundT 3)) - ($' List (#BoundT 1)))))) - (_lux_case xs - #Nil - #Nil - - (#Cons x xs') - (#Cons (f x) (map f xs')))) - -(def'' RepEnv - Type - ($' List (#TupleT (#Cons Text (#Cons AST #Nil))))) - -(def'' (make-env xs ys) - (#LambdaT ($' List Text) (#LambdaT ($' List AST) RepEnv)) - (_lux_case [xs ys] - [(#Cons x xs') (#Cons y ys')] - (#Cons [x y] (make-env xs' ys')) - - _ - #Nil)) - -(def'' (text:= x y) - (#LambdaT Text (#LambdaT Text Bool)) - (_jvm_invokevirtual "java.lang.Object" "equals" ["java.lang.Object"] - x [y])) - -(def'' (get-rep key env) - (#LambdaT Text (#LambdaT RepEnv ($' Maybe AST))) - (_lux_case env - #Nil - #None - - (#Cons [k v] env') - (_lux_case (text:= k key) - true - (#Some v) - - false - (get-rep key env')))) - -(def'' (replace-syntax reps syntax) - (#LambdaT RepEnv (#LambdaT AST AST)) - (_lux_case syntax - [_ (#SymbolS "" name)] - (_lux_case (get-rep name reps) - (#Some replacement) - replacement - - #None - syntax) - - [meta (#FormS parts)] - [meta (#FormS (map (replace-syntax reps) parts))] - - [meta (#TupleS members)] - [meta (#TupleS (map (replace-syntax reps) members))] - - [meta (#RecordS slots)] - [meta (#RecordS (map (_lux_: (#LambdaT (#TupleT (#Cons AST (#Cons AST #Nil))) (#TupleT (#Cons AST (#Cons AST #Nil)))) - (lambda'' [slot] - (_lux_case slot - [k v] - [(replace-syntax reps k) (replace-syntax reps v)]))) - slots))] - - _ - syntax) - ) - -(def'' (update-bounds ast) - (#LambdaT AST AST) - (_lux_case ast - [_ (#BoolS value)] - (bool$ value) - - [_ (#IntS value)] - (int$ value) - - [_ (#RealS value)] - (real$ value) - - [_ (#CharS value)] - (char$ value) - - [_ (#TextS value)] - (text$ value) - - [_ (#SymbolS value)] - (symbol$ value) - - [_ (#TagS value)] - (tag$ value) - - [_ (#TupleS members)] - (tuple$ (map update-bounds members)) - - [_ (#RecordS pairs)] - (record$ (map (_lux_: (#LambdaT (#TupleT (#Cons AST (#Cons AST #Nil))) (#TupleT (#Cons AST (#Cons AST #Nil)))) - (lambda'' [pair] - (let'' [name val] pair - [name (update-bounds val)]))) - pairs)) - - [_ (#FormS (#Cons [_ (#TagS "lux" "BoundT")] (#Cons [_ (#IntS idx)] #Nil)))] - (form$ (#Cons (tag$ ["lux" "BoundT"]) (#Cons (int$ (_jvm_ladd 2 idx)) #Nil))) - - [_ (#FormS members)] - (form$ (map update-bounds members))) - ) - -(def'' (parse-univq-args args next) - ## (All [a] (-> (List AST) (-> (List Text) (Lux a)) (Lux a))) - (#UnivQ #Nil (#LambdaT ($' List AST) - (#LambdaT (#LambdaT ($' List Text) (#AppT (#AppT StateE Compiler) (#BoundT 1))) - (#AppT (#AppT StateE Compiler) (#BoundT 1))))) - (_lux_case args - #Nil - (next #Nil) - - (#Cons [_ (#SymbolS "" arg-name)] args') - (parse-univq-args args' (lambda'' [names] (next (#Cons arg-name names)))) - - _ - (fail "Expected symbol."))) - -(def'' (make-bound idx) - (#LambdaT Int AST) - (form$ (#Cons (tag$ ["lux" "BoundT"]) (#Cons (int$ idx) #Nil)))) - -(def'' (foldL f init xs) - ## (All [a b] (-> (-> a b a) a (List b) a)) - (#UnivQ #Nil (#UnivQ #Nil (#LambdaT (#LambdaT (#BoundT 3) - (#LambdaT (#BoundT 1) - (#BoundT 3))) - (#LambdaT (#BoundT 3) - (#LambdaT ($' List (#BoundT 1)) - (#BoundT 3)))))) - (_lux_case xs - #Nil - init - - (#Cons x xs') - (foldL f (f init x) xs'))) - -(defmacro' #export (All tokens) - (let'' [self-name tokens] (_lux_case tokens - (#Cons [_ (#SymbolS "" self-name)] tokens) - [self-name tokens] - - _ - ["" tokens]) - (_lux_case tokens - (#Cons [_ (#TupleS args)] (#Cons body #Nil)) - (parse-univq-args args - (lambda'' [names] - (let'' body' (foldL (_lux_: (#LambdaT AST (#LambdaT Text AST)) - (lambda'' [body' name'] - (form$ (#Cons (tag$ ["lux" "UnivQ"]) - (#Cons (tag$ ["lux" "Nil"]) - (#Cons (replace-syntax (#Cons [name' (make-bound 1)] #Nil) - (update-bounds body')) #Nil)))))) - (replace-syntax (#Cons [self-name (make-bound -2)] #Nil) - body) - names) - (return (#Cons body' #Nil))))) - - _ - (fail "Wrong syntax for All")) - )) - -(defmacro' #export (Ex tokens) - (let'' [self-name tokens] (_lux_case tokens - (#Cons [_ (#SymbolS "" self-name)] tokens) - [self-name tokens] - - _ - ["" tokens]) - (_lux_case tokens - (#Cons [_ (#TupleS args)] (#Cons body #Nil)) - (parse-univq-args args - (lambda'' [names] - (let'' body' (foldL (_lux_: (#LambdaT AST (#LambdaT Text AST)) - (lambda'' [body' name'] - (form$ (#Cons (tag$ ["lux" "ExQ"]) - (#Cons (tag$ ["lux" "Nil"]) - (#Cons (replace-syntax (#Cons [name' (make-bound 1)] #Nil) - (update-bounds body')) #Nil)))))) - (replace-syntax (#Cons [self-name (make-bound -2)] #Nil) - body) - names) - (return (#Cons body' #Nil))))) - - _ - (fail "Wrong syntax for Ex")) - )) - -(def'' (reverse list) - (All [a] (#LambdaT ($' List a) ($' List a))) - (foldL (lambda'' [tail head] (#Cons head tail)) - #Nil - list)) - -(defmacro' #export (-> tokens) - (_lux_case (reverse tokens) - (#Cons output inputs) - (return (#Cons (foldL (_lux_: (#LambdaT AST (#LambdaT AST AST)) - (lambda'' [o i] (form$ (#Cons (tag$ ["lux" "LambdaT"]) (#Cons i (#Cons o #Nil)))))) - output - inputs) - #Nil)) - - _ - (fail "Wrong syntax for ->"))) - -(defmacro' (@list xs) - (return (#Cons (foldL (lambda'' [tail head] - (form$ (#Cons (tag$ ["lux" "Cons"]) - (#Cons (tuple$ (#Cons [head (#Cons [tail #Nil])])) - #Nil)))) - (tag$ ["lux" "Nil"]) - (reverse xs)) - #Nil))) - -(defmacro' (@list& xs) - (_lux_case (reverse xs) - (#Cons last init) - (return (@list (foldL (lambda'' [tail head] - (form$ (@list (tag$ ["lux" "Cons"]) - (tuple$ (@list head tail))))) - last - init))) - - _ - (fail "Wrong syntax for @list&"))) - -(defmacro' #export (, tokens) - (return (@list (form$ (@list (tag$ ["lux" "TupleT"]) - (foldL (lambda'' [tail head] (form$ (@list (tag$ ["lux" "Cons"]) head tail))) - (tag$ ["lux" "Nil"]) - (reverse tokens))))))) - -(defmacro' (lambda' tokens) - (let'' [name tokens'] (_lux_case tokens - (#Cons [[_ (#SymbolS ["" name])] tokens']) - [name tokens'] - - _ - ["" tokens]) - (_lux_case tokens' - (#Cons [[_ (#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 [[_ (#TagS ["" "export"])] - (#Cons [[_ (#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 [[_ (#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 [[_ (#FormS (#Cons [name args]))] - (#Cons [type (#Cons [body #Nil])])]) - (return (@list (form$ (@list (symbol$ ["" "_lux_def"]) - name - (form$ (@list (symbol$ ["" "_lux_:"]) - type - (form$ (@list (symbol$ ["lux" "lambda'"]) - name - (tuple$ args) - body)))))))) - - (#Cons [name (#Cons [type (#Cons [body #Nil])])]) - (return (@list (form$ (@list (symbol$ ["" "_lux_def"]) - name - (form$ (@list (symbol$ ["" "_lux_:"]) type body)))))) - - _ - (fail "Wrong syntax for def'") - )) - -(def''' (as-pairs xs) - (All [a] (-> ($' List a) ($' List (, a a)))) - (_lux_case xs - (#Cons x (#Cons y xs')) - (#Cons [x y] (as-pairs xs')) - - _ - #Nil)) - -(defmacro' (let' tokens) - (_lux_case tokens - (#Cons [[_ (#TupleS bindings)] (#Cons [body #Nil])]) - (return (@list (foldL (_lux_: (-> AST (, AST AST) - AST) - (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''' (any? p xs) - (All [a] - (-> (-> a Bool) ($' List a) Bool)) - (_lux_case xs - #Nil - false - - (#Cons x xs') - (_lux_case (p x) - true true - false (any? p xs')))) - -(def''' (spliced? token) - (-> AST Bool) - (_lux_case token - [_ (#FormS (#Cons [[_ (#SymbolS ["" "~@"])] (#Cons [_ #Nil])]))] - true - - _ - false)) - -(def''' (wrap-meta content) - (-> AST AST) - (tuple$ (@list (tuple$ (@list (text$ "") (int$ -1) (int$ -1))) - content))) - -(def''' (untemplate-list tokens) - (-> ($' List AST) AST) - (_lux_case tokens - #Nil - (_meta (#TagS ["lux" "Nil"])) - - (#Cons [token tokens']) - (_meta (#FormS (@list (_meta (#TagS ["lux" "Cons"])) token (untemplate-list tokens')))))) - -(def''' (list:++ xs ys) - (All [a] (-> ($' List a) ($' List a) ($' List a))) - (_lux_case xs - (#Cons x xs') - (#Cons x (list:++ xs' ys)) - - #Nil - ys)) - -(def''' #export (splice-helper xs ys) - (-> ($' List AST) ($' List AST) ($' List AST)) - (_lux_case xs - (#Cons x xs') - (#Cons x (splice-helper xs' ys)) - - #Nil - ys)) - -(defmacro' #export ($ tokens) - (_lux_case tokens - (#Cons op (#Cons init args)) - (return (@list (foldL (lambda' [a1 a2] (form$ (@list op a1 a2))) - init - args))) - - _ - (fail "Wrong syntax for $"))) - -## (deftype (Lux a) -## (-> Compiler (Either Text (, Compiler a)))) -(def''' #export Lux - Type - (#NamedT ["lux" "Lux"] - (All [a] - (-> Compiler ($' Either Text (, Compiler a)))))) - -## (defsig (Monad m) -## (: (All [a] (-> a (m a))) -## return) -## (: (All [a b] (-> (-> a (m b)) (m a) (m b))) -## bind)) -(def''' Monad - Type - (#NamedT ["lux" "Monad"] - (All [m] - (, (All [a] (-> a ($' m a))) - (All [a b] (-> (-> a ($' m b)) - ($' m a) - ($' m b))))))) -(_lux_declare-tags [#return #bind] Monad) - -(def''' Maybe/Monad - ($' Monad Maybe) - {#return - (lambda' return [x] - (#Some x)) - - #bind - (lambda' [f ma] - (_lux_case ma - #None #None - (#Some a) (f a)))}) - -(def''' Lux/Monad - ($' Monad Lux) - {#return - (lambda' [x] - (lambda' [state] - (#Right state x))) - - #bind - (lambda' [f ma] - (lambda' [state] - (_lux_case (ma state) - (#Left msg) - (#Left msg) - - (#Right state' a) - (f a state'))))}) - -(defmacro' (do tokens) - (_lux_case tokens - (#Cons monad (#Cons [_ (#TupleS bindings)] (#Cons body #Nil))) - (let' [g!wrap (symbol$ ["" "wrap"]) - g!bind (symbol$ ["" "12bind34"]) - body' (foldL (_lux_: (-> AST (, AST AST) AST) - (lambda' [body' binding] - (let' [[var value] binding] - (_lux_case var - [_ (#TagS "" "let")] - (form$ (@list (symbol$ ["lux" "let'"]) value body')) - - _ - (form$ (@list g!bind - (form$ (@list (symbol$ ["" "_lux_lambda"]) (symbol$ ["" ""]) var body')) - value)))))) - body - (reverse (as-pairs bindings)))] - (return (@list (form$ (@list (symbol$ ["" "_lux_case"]) - monad - (record$ (@list [(tag$ ["lux" "return"]) g!wrap] [(tag$ ["lux" "bind"]) g!bind])) - body'))))) - - _ - (fail "Wrong syntax for do"))) - -(def''' (map% m f xs) - ## (All [m a b] - ## (-> (Monad m) (-> a (m b)) (List a) (m (List b)))) - (All [m a b] - (-> ($' Monad m) - (-> a ($' m b)) - ($' List a) - ($' m ($' List b)))) - (let' [{#;return wrap #;bind _} m] - (_lux_case xs - #Nil - (wrap #Nil) - - (#Cons x xs') - (do m - [y (f x) - ys (map% m f xs')] - (wrap (#Cons y ys))) - ))) - -(defmacro' #export (if tokens) - (_lux_case tokens - (#Cons test (#Cons then (#Cons else #Nil))) - (return (@list (form$ (@list (symbol$ ["" "_lux_case"]) test - (bool$ true) then - (bool$ false) else)))) - - _ - (fail "Wrong syntax for if"))) - -(def''' (get k plist) - (All [a] - (-> Text ($' List (, Text a)) ($' Maybe a))) - (_lux_case plist - (#Cons [[k' v] plist']) - (if (text:= k k') - (#Some v) - (get k plist')) - - #Nil - #None)) - -(def''' (put k v dict) - (All [a] - (-> Text a ($' List (, Text a)) ($' List (, Text a)))) - (_lux_case dict - #Nil - (@list [k v]) - - (#Cons [[k' v'] dict']) - (if (text:= k k') - (#Cons [[k' v] dict']) - (#Cons [[k' v'] (put k v dict')])))) - -(def''' (text:++ x y) - (-> Text Text Text) - (_jvm_invokevirtual "java.lang.String" "concat" ["java.lang.String"] - x [y])) - -(def''' (ident->text ident) - (-> Ident Text) - (let' [[module name] ident] - ($ text:++ module ";" name))) - -(def''' (resolve-global-symbol ident state) - (-> Ident ($' Lux Ident)) - (let' [[module name] ident - {#source source #modules modules - #envs envs #type-vars types #host host - #seed seed #eval? eval? #expected expected - #cursor cursor} state] - (_lux_case (get module modules) - (#Some {#module-aliases _ #defs defs #imports _ #tags tags #types types}) - (_lux_case (get name defs) - (#Some [_ def-data]) - (_lux_case def-data - (#AliasD real-name) - (#Right [state real-name]) - - _ - (#Right [state ident])) - - #None - (#Left ($ text:++ "Unknown definition: " (ident->text ident)))) - - #None - (#Left ($ text:++ "Unknown module: " module " @ " (ident->text ident)))))) - -(def''' (splice replace? untemplate tag elems) - (-> Bool (-> AST ($' Lux AST)) AST ($' List AST) ($' Lux AST)) - (_lux_case replace? - true - (_lux_case (any? spliced? elems) - true - (do Lux/Monad - [elems' (_lux_: ($' Lux ($' List AST)) - (map% Lux/Monad - (_lux_: (-> AST ($' Lux AST)) - (lambda' [elem] - (_lux_case elem - [_ (#FormS (#Cons [[_ (#SymbolS ["" "~@"])] (#Cons [spliced #Nil])]))] - (wrap spliced) - - _ - (do Lux/Monad - [=elem (untemplate elem)] - (wrap (form$ (@list (symbol$ ["" "_lux_:"]) - (form$ (@list (tag$ ["lux" "AppT"]) (tuple$ (@list (symbol$ ["lux" "List"]) (symbol$ ["lux" "AST"]))))) - (form$ (@list (tag$ ["lux" "Cons"]) (tuple$ (@list =elem (tag$ ["lux" "Nil"])))))))))))) - elems))] - (wrap (wrap-meta (form$ (@list tag - (form$ (@list& (symbol$ ["lux" "$"]) - (symbol$ ["lux" "splice-helper"]) - elems'))))))) - - false - (do Lux/Monad - [=elems (map% Lux/Monad untemplate elems)] - (wrap (wrap-meta (form$ (@list tag (untemplate-list =elems))))))) - false - (do Lux/Monad - [=elems (map% Lux/Monad untemplate elems)] - (wrap (wrap-meta (form$ (@list tag (untemplate-list =elems)))))))) - -(def''' (untemplate replace? subst token) - (-> Bool Text AST ($' Lux AST)) - (_lux_case [replace? token] - [_ [_ (#BoolS value)]] - (return (wrap-meta (form$ (@list (tag$ ["lux" "BoolS"]) (bool$ value))))) - - [_ [_ (#IntS value)]] - (return (wrap-meta (form$ (@list (tag$ ["lux" "IntS"]) (int$ value))))) - - [_ [_ (#RealS value)]] - (return (wrap-meta (form$ (@list (tag$ ["lux" "RealS"]) (real$ value))))) - - [_ [_ (#CharS value)]] - (return (wrap-meta (form$ (@list (tag$ ["lux" "CharS"]) (char$ value))))) - - [_ [_ (#TextS value)]] - (return (wrap-meta (form$ (@list (tag$ ["lux" "TextS"]) (text$ value))))) - - [_ [_ (#TagS [module name])]] - (let' [module' (_lux_case module - "" - subst - - _ - module)] - (return (wrap-meta (form$ (@list (tag$ ["lux" "TagS"]) (tuple$ (@list (text$ module') (text$ name)))))))) - - [true [_ (#SymbolS [module name])]] - (do Lux/Monad - [real-name (_lux_case module - "" - (resolve-global-symbol [subst name]) - - _ - (wrap [module name])) - #let [[module name] real-name]] - (return (wrap-meta (form$ (@list (tag$ ["lux" "SymbolS"]) (tuple$ (@list (text$ module) (text$ name)))))))) - - [false [_ (#SymbolS [module name])]] - (return (wrap-meta (form$ (@list (tag$ ["lux" "SymbolS"]) (tuple$ (@list (text$ module) (text$ name))))))) - - [_ [_ (#TupleS elems)]] - (splice replace? (untemplate replace? subst) (tag$ ["lux" "TupleS"]) elems) - - [true [_ (#FormS (#Cons [[_ (#SymbolS ["" "~"])] (#Cons [unquoted #Nil])]))]] - (return unquoted) - - [_ [meta (#FormS elems)]] - (do Lux/Monad - [output (splice replace? (untemplate replace? subst) (tag$ ["lux" "FormS"]) elems) - #let [[_ form'] output]] - (return [meta form'])) - - [_ [_ (#RecordS fields)]] - (do Lux/Monad - [=fields (map% Lux/Monad - (_lux_: (-> (, AST AST) ($' Lux AST)) - (lambda' [kv] - (let' [[k v] kv] - (do Lux/Monad - [=k (untemplate replace? subst k) - =v (untemplate replace? subst v)] - (wrap (tuple$ (@list =k =v))))))) - fields)] - (wrap (wrap-meta (form$ (@list (tag$ ["lux" "RecordS"]) (untemplate-list =fields)))))) - )) - -(defmacro' #export (^ tokens) - (_lux_case tokens - (#Cons [_ (#SymbolS "" class-name)] #Nil) - (return (@list (form$ (@list (tag$ ["lux" "DataT"]) (text$ class-name) (tag$ ["lux" "Nil"]))))) - - (#Cons [_ (#SymbolS "" class-name)] params) - (return (@list (form$ (@list (tag$ ["lux" "DataT"]) (text$ class-name) (untemplate-list params))))) - - _ - (fail "Wrong syntax for ^"))) - -(def'' (get-module-name state) - ($' Lux Text) - (_lux_case state - {#source source #modules modules - #envs envs #type-vars types #host host - #seed seed #eval? eval? #expected expected - #cursor cursor} - (_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])))) - -(defmacro' #export (` tokens) - (_lux_case tokens - (#Cons template #Nil) - (do Lux/Monad - [current-module get-module-name - =template (untemplate true current-module template)] - (wrap (@list (form$ (@list (symbol$ ["" "_lux_:"]) (symbol$ ["lux" "AST"]) =template))))) - - _ - (fail "Wrong syntax for `"))) - -(defmacro' #export (' tokens) - (_lux_case tokens - (#Cons template #Nil) - (do Lux/Monad - [=template (untemplate false "" template)] - (wrap (@list (form$ (@list (symbol$ ["" "_lux_:"]) (symbol$ ["lux" "AST"]) =template))))) - - _ - (fail "Wrong syntax for '"))) - -(defmacro' #export (|> tokens) - (_lux_case tokens - (#Cons [init apps]) - (return (@list (foldL (_lux_: (-> AST AST AST) - (lambda' [acc app] - (_lux_case app - [_ (#TupleS parts)] - (tuple$ (list:++ parts (@list acc))) - - [_ (#FormS parts)] - (form$ (list:++ parts (@list acc))) - - _ - (` ((~ app) (~ acc)))))) - init - apps))) - - _ - (fail "Wrong syntax for |>"))) - -(def''' (. f g) - (All [a b c] - (-> (-> b c) (-> a b) (-> a c))) - (lambda' [x] - (f (g x)))) - -(def''' (get-ident x) - (-> AST ($' Maybe Ident)) - (_lux_case x - [_ (#SymbolS sname)] - (#Some sname) - - _ - #None)) - -(def''' (get-tag x) - (-> AST ($' Maybe Ident)) - (_lux_case x - [_ (#TagS sname)] - (#Some sname) - - _ - #None)) - -(def''' (get-name x) - (-> AST ($' Maybe Text)) - (_lux_case x - [_ (#SymbolS "" sname)] - (#Some sname) - - _ - #None)) - -(def''' (tuple->list tuple) - (-> AST ($' Maybe ($' List AST))) - (_lux_case tuple - [_ (#TupleS members)] - (#Some members) - - _ - #None)) - -(def''' (apply-template env template) - (-> RepEnv AST AST) - (_lux_case template - [_ (#SymbolS "" sname)] - (_lux_case (get-rep sname env) - (#Some subst) - subst - - _ - template) - - [_ (#TupleS elems)] - (tuple$ (map (apply-template env) elems)) - - [_ (#FormS elems)] - (form$ (map (apply-template env) elems)) - - [_ (#RecordS members)] - (record$ (map (_lux_: (-> (, AST AST) (, AST AST)) - (lambda' [kv] - (let' [[slot value] kv] - [(apply-template env slot) (apply-template env value)]))) - members)) - - _ - template)) - -(def''' (join-map f xs) - (All [a b] - (-> (-> a ($' List b)) ($' List a) ($' List b))) - (_lux_case xs - #Nil - #Nil - - (#Cons [x xs']) - (list:++ (f x) (join-map f xs')))) - -(defmacro' #export (do-template tokens) - (_lux_case tokens - (#Cons [[_ (#TupleS bindings)] (#Cons [[_ (#TupleS templates)] data])]) - (_lux_case [(map% Maybe/Monad get-name bindings) - (map% Maybe/Monad tuple->list data)] - [(#Some bindings') (#Some data')] - (let' [apply (_lux_: (-> RepEnv ($' List AST)) - (lambda' [env] (map (apply-template env) templates)))] - (|> data' - (join-map (. apply (make-env bindings'))) - return)) - - _ - (fail "Wrong syntax for do-template")) - - _ - (fail "Wrong syntax for do-template"))) - -(do-template [<name> <cmp> <type>] - [(def''' (<name> x y) - (-> <type> <type> Bool) - (<cmp> x y))] - - [i= _jvm_leq Int] - [i> _jvm_lgt Int] - [i< _jvm_llt Int] - ) - -(do-template [<name> <cmp> <eq> <type>] - [(def''' (<name> x y) - (-> <type> <type> Bool) - (if (<cmp> x y) - true - (<eq> x y)))] - - [i>= i> i= Int] - [i<= i< i= Int] - ) - -(do-template [<name> <cmp> <type>] - [(def''' (<name> x y) - (-> <type> <type> <type>) - (<cmp> x y))] - - [i+ _jvm_ladd Int] - [i- _jvm_lsub Int] - [i* _jvm_lmul Int] - [i/ _jvm_ldiv Int] - [i% _jvm_lrem Int] - ) - -(def''' (multiple? div n) - (-> Int Int Bool) - (i= 0 (i% n div))) - -(def''' (length list) - (All [a] (-> ($' List a) Int)) - (foldL (lambda' [acc _] (_jvm_ladd 1 acc)) 0 list)) - -(def''' #export (not x) - (-> Bool Bool) - (if x false true)) - -(def''' (->text x) - (-> (^ java.lang.Object) Text) - (_jvm_invokevirtual "java.lang.Object" "toString" [] x [])) - -(def''' (find-macro' modules current-module module name) - (-> ($' List (, Text ($' Module Compiler))) - Text Text Text - ($' Maybe Macro)) - (do Maybe/Monad - [$module (get module modules) - gdef (let' [{#module-aliases _ #defs bindings #imports _ #tags tags #types types} (_lux_: ($' Module Compiler) $module)] - (get name bindings))] - (_lux_case (_lux_: Definition 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''' (normalize ident) - (-> Ident ($' Lux Ident)) - (_lux_case ident - ["" name] - (do Lux/Monad - [module-name get-module-name] - (wrap [module-name name])) - - _ - (return ident))) - -(def''' (find-macro ident) - (-> Ident ($' Lux ($' Maybe Macro))) - (do Lux/Monad - [current-module get-module-name] - (let' [[module name] ident] - (lambda' [state] - (_lux_case state - {#source source #modules modules - #envs envs #type-vars types #host host - #seed seed #eval? eval? #expected expected - #cursor cursor} - (#Right state (find-macro' modules current-module module name))))))) - -(def''' (macro? ident) - (-> Ident ($' Lux Bool)) - (do Lux/Monad - [ident (normalize ident) - output (find-macro ident)] - (wrap (_lux_case output - (#Some _) true - #None false)))) - -(def''' (list:join xs) - (All [a] - (-> ($' List ($' List a)) ($' List a))) - (foldL list:++ #Nil xs)) - -(def''' (interpose sep xs) - (All [a] - (-> a ($' List a) ($' List a))) - (_lux_case xs - #Nil - xs - - (#Cons [x #Nil]) - xs - - (#Cons [x xs']) - (@list& x sep (interpose sep xs')))) - -(def''' (macro-expand token) - (-> AST ($' Lux ($' List AST))) - (_lux_case token - [_ (#FormS (#Cons [_ (#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)] - (wrap (list:join expansion'))) - - #None - (return (@list token)))) - - _ - (return (@list token)))) - -(def''' (macro-expand-all syntax) - (-> AST ($' Lux ($' List AST))) - (_lux_case syntax - [_ (#FormS (#Cons [_ (#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-all expansion)] - (wrap (list:join expansion'))) - - #None - (do Lux/Monad - [args' (map% Lux/Monad macro-expand-all args)] - (wrap (@list (form$ (#Cons (symbol$ macro-name) (list:join args')))))))) - - [_ (#FormS members)] - (do Lux/Monad - [members' (map% Lux/Monad macro-expand-all members)] - (wrap (@list (form$ (list:join members'))))) - - [_ (#TupleS members)] - (do Lux/Monad - [members' (map% Lux/Monad macro-expand-all members)] - (wrap (@list (tuple$ (list:join members'))))) - - _ - (return (@list syntax)))) - -(def''' (walk-type type) - (-> AST AST) - (_lux_case type - [_ (#FormS (#Cons [[_ (#TagS tag)] parts]))] - (form$ (#Cons [(tag$ tag) (map walk-type parts)])) - - [_ (#TupleS members)] - (tuple$ (map walk-type members)) - - [_ (#FormS (#Cons [type-fn args]))] - (foldL (_lux_: (-> AST AST AST) - (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-all type)] - (_lux_case type+ - (#Cons type' #Nil) - (wrap (@list (walk-type type'))) - - _ - (fail "The expansion of the type-syntax had to yield a single element."))) - - _ - (fail "Wrong syntax for @type"))) - -(defmacro' #export (: tokens) - (_lux_case tokens - (#Cons type (#Cons value #Nil)) - (return (@list (` (;_lux_: (@type (~ type)) (~ value))))) - - _ - (fail "Wrong syntax for :"))) - -(defmacro' #export (:! tokens) - (_lux_case tokens - (#Cons type (#Cons value #Nil)) - (return (@list (` (;_lux_:! (@type (~ type)) (~ value))))) - - _ - (fail "Wrong syntax for :!"))) - -(def''' (empty? xs) - (All [a] (-> ($' List a) Bool)) - (_lux_case xs - #Nil true - _ false)) - -(do-template [<name> <type> <value>] - [(def''' (<name> xy) - (All [a b] (-> (, a b) <type>)) - (let' [[x y] xy] <value>))] - - [first a x] - [second b y]) - -(def''' (unfold-type-def type) - (-> AST ($' Lux (, AST ($' Maybe ($' List AST))))) - (_lux_case type - [_ (#FormS (#Cons [_ (#SymbolS "" "|")] cases))] - (do Lux/Monad - [members (map% Lux/Monad - (: (-> AST ($' Lux (, Text AST))) - (lambda' [case] - (_lux_case case - [_ (#TagS "" member-name)] - (return [member-name (` Unit)]) - - [_ (#FormS (#Cons [_ (#TagS "" member-name)] (#Cons member-type #Nil)))] - (return [member-name member-type]) - - _ - (fail "Wrong syntax for variant case.")))) - cases)] - (return [(` (#;VariantT (~ (untemplate-list (map second members))))) - (#Some (|> members - (map first) - (map (: (-> Text AST) - (lambda' [name] (tag$ ["" name]))))))])) - - [_ (#FormS (#Cons [_ (#SymbolS "" "&")] pairs))] - (do Lux/Monad - [members (map% Lux/Monad - (: (-> (, AST AST) ($' Lux (, Text AST))) - (lambda' [pair] - (_lux_case pair - [[_ (#TagS "" member-name)] member-type] - (return [member-name member-type]) - - _ - (fail "Wrong syntax for variant case.")))) - (as-pairs pairs))] - (return [(` (#TupleT (~ (untemplate-list (map second members))))) - (#Some (|> members - (map first) - (map (: (-> Text AST) - (lambda' [name] (tag$ ["" name]))))))])) - - _ - (return [type #None]))) - -(def''' (gensym prefix state) - (-> Text ($' Lux AST)) - (_lux_case state - {#source source #modules modules - #envs envs #type-vars types #host host - #seed seed #eval? eval? #expected expected - #cursor cursor} - (#Right {#source source #modules modules - #envs envs #type-vars types #host host - #seed (i+ 1 seed) #eval? eval? #expected expected - #cursor cursor} - (symbol$ ["" ($ text:++ "__gensym__" prefix (->text seed))])))) - -(defmacro' #export (Rec tokens) - (_lux_case tokens - (#Cons [_ (#SymbolS "" name)] (#Cons body #Nil)) - (let' [body' (replace-syntax (@list [name (` (#AppT (~ (make-bound 0)) (~ (make-bound 1))))]) body)] - (return (@list (` (#AppT (#UnivQ #Nil (~ body')) Void))))) - - _ - (fail "Wrong syntax for Rec"))) - -(defmacro' #export (deftype tokens) - (let' [[export? tokens'] (_lux_case tokens - (#Cons [_ (#TagS "" "export")] tokens') - [true tokens'] - - _ - [false tokens]) - [rec? tokens'] (_lux_case tokens' - (#Cons [_ (#TagS "" "rec")] tokens') - [true tokens'] - - _ - [false tokens']) - parts (: (Maybe (, Text (List AST) AST)) - (_lux_case tokens' - (#Cons [_ (#SymbolS "" name)] (#Cons type #Nil)) - (#Some name #Nil type) - - (#Cons [_ (#FormS (#Cons [_ (#SymbolS "" name)] args))] (#Cons type #Nil)) - (#Some name args type) - - _ - #None))] - (_lux_case parts - (#Some name args type) - (do Lux/Monad - [type+tags?? (unfold-type-def type) - module-name get-module-name] - (let' [type-name (symbol$ ["" name]) - [type tags??] type+tags?? - with-export (: (List AST) - (if export? - (@list (` (;_lux_export (~ type-name)))) - #Nil)) - with-tags (: (List AST) - (_lux_case tags?? - (#Some tags) - (@list (` (;_lux_declare-tags [(~@ tags)] (~ type-name)))) - - _ - (@list))) - type' (: (Maybe AST) - (if rec? - (if (empty? args) - (let' [g!param (symbol$ ["" ""]) - prime-name (symbol$ ["" (text:++ name "'")]) - type+ (replace-syntax (@list [name (` ((~ prime-name) (~ g!param)))]) type)] - (#Some (` ((All (~ prime-name) [(~ g!param)] (~ type+)) - Void)))) - #None) - (_lux_case args - #Nil - (#Some type) - - _ - (#Some (` (All (~ type-name) [(~@ args)] (~ type)))))))] - (_lux_case type' - (#Some type'') - (return (@list& (` (;_lux_def (~ type-name) (@type (#;NamedT [(~ (text$ module-name)) - (~ (text$ name))] - (~ type''))))) - (list:++ with-export with-tags))) - - #None - (fail "Wrong syntax for deftype")))) - - #None - (fail "Wrong syntax for deftype")) - )) - -(defmacro' #export (exec tokens) - (_lux_case (reverse tokens) - (#Cons value actions) - (let' [dummy (symbol$ ["" ""])] - (return (@list (foldL (_lux_: (-> AST AST AST) - (lambda' [post pre] (` (;_lux_case (~ pre) (~ dummy) (~ post))))) - value - actions)))) - - _ - (fail "Wrong syntax for exec"))) - -(defmacro' (def' tokens) - (let' [[export? tokens'] (_lux_case tokens - (#Cons [_ (#TagS "" "export")] tokens') - [true tokens'] - - _ - [false tokens]) - parts (: (Maybe (, AST (List AST) (Maybe AST) AST)) - (_lux_case tokens' - (#Cons [_ (#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 [_ (#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' (_lux_case args - #Nil - body - - _ - (` (lambda' (~ name) [(~@ args)] (~ body)))) - body'' (_lux_case ?type - (#Some type) - (` (: (~ type) (~ body'))) - - #None - body')] - (return (@list& (` (;_lux_def (~ name) (~ body''))) - (if export? - (@list (` (;_lux_export (~ name)))) - #Nil)))) - - #None - (fail "Wrong syntax for def'")))) - -(def' (rejoin-pair pair) - (-> (, AST AST) (List AST)) - (let' [[left right] pair] - (@list left right))) - -(defmacro' #export (case tokens) - (_lux_case tokens - (#Cons value branches) - (if (multiple? 2 (length branches)) - (do Lux/Monad - [expansions (map% Lux/Monad - (: (-> (, AST AST) (Lux (List (, AST AST)))) - (lambda' expander [branch] - (let' [[pattern body] branch] - (_lux_case pattern - [_ (#FormS (#Cons [_ (#SymbolS macro-name)] macro-args))] - (do Lux/Monad - [??? (macro? macro-name)] - (if ??? - (do Lux/Monad - [expansion (macro-expand (form$ (@list& (symbol$ macro-name) body macro-args))) - expansions (map% Lux/Monad expander (as-pairs expansion))] - (wrap (list:join expansions))) - (wrap (@list branch)))) - - _ - (wrap (@list branch)))))) - (as-pairs branches))] - (wrap (@list (` (;_lux_case (~ value) - (~@ (|> expansions list:join (map rejoin-pair) list:join))))))) - (fail "case expects an even number of tokens")) - - _ - (fail "Wrong syntax for case"))) - -(defmacro' #export (\ tokens) - (case tokens - (#Cons body (#Cons pattern #Nil)) - (do Lux/Monad - [module-name get-module-name - pattern+ (macro-expand-all pattern)] - (case pattern+ - (#Cons pattern' #Nil) - (wrap (@list pattern' body)) - - _ - (fail "\\ can only expand to 1 pattern."))) - - _ - (fail "Wrong syntax for \\"))) - -(defmacro' #export (\or tokens) - (case tokens - (#Cons body patterns) - (case patterns - #Nil - (fail "\\or can't have 0 patterns") - - _ - (do Lux/Monad - [patterns' (map% Lux/Monad macro-expand-all patterns)] - (wrap (list:join (map (lambda' [pattern] (@list pattern body)) - (list:join patterns')))))) - - _ - (fail "Wrong syntax for \\or"))) - -(def' (symbol? ast) - (-> AST Bool) - (case ast - [_ (#SymbolS _)] - true - - _ - false)) - -(defmacro' #export (let tokens) - (case tokens - (\ (@list [_ (#TupleS bindings)] body)) - (if (multiple? 2 (length bindings)) - (|> bindings as-pairs reverse - (foldL (: (-> AST (, AST AST) AST) - (lambda' [body' lr] - (let' [[l r] lr] - (if (symbol? l) - (` (;_lux_case (~ r) (~ l) (~ body'))) - (` (case (~ r) (~ l) (~ body'))))))) - body) - @list - return) - (fail "let requires an even number of parts")) - - _ - (fail "Wrong syntax for let"))) - -(defmacro' #export (lambda tokens) - (case (: (Maybe (, Ident AST (List AST) AST)) - (case tokens - (\ (@list [_ (#TupleS (#Cons head tail))] body)) - (#Some ["" ""] head tail body) - - (\ (@list [_ (#SymbolS ["" name])] [_ (#TupleS (#Cons head tail))] body)) - (#Some ["" name] head tail body) - - _ - #None)) - (#Some ident head tail body) - (let [g!blank (symbol$ ["" ""]) - g!name (symbol$ ident) - body+ (foldL (: (-> AST AST AST) - (lambda' [body' arg] - (if (symbol? arg) - (` (;_lux_lambda (~ g!blank) (~ arg) (~ body'))) - (` (;_lux_lambda (~ g!blank) (~ g!blank) - (case (~ g!blank) (~ arg) (~ body'))))))) - body - (reverse tail))] - (return (@list (if (symbol? head) - (` (;_lux_lambda (~ g!name) (~ head) (~ body+))) - (` (;_lux_lambda (~ g!name) (~ g!blank) (case (~ g!blank) (~ head) (~ body+)))))))) - - #None - (fail "Wrong syntax for lambda"))) - -(defmacro' #export (def tokens) - (let [[export? tokens'] (case tokens - (#Cons [_ (#TagS "" "export")] tokens') - [true tokens'] - - _ - [false tokens]) - parts (: (Maybe (, AST (List AST) (Maybe AST) AST)) - (case tokens' - (\ (@list [_ (#FormS (#Cons name args))] type body)) - (#Some name args (#Some type) body) - - (\ (@list name type body)) - (#Some name #Nil (#Some type) body) - - (\ (@list [_ (#FormS (#Cons name args))] body)) - (#Some name args #None body) - - (\ (@list name body)) - (#Some name #Nil #None body) - - _ - #None))] - (case parts - (#Some name args ?type body) - (let [body (case args - #Nil - body - - _ - (` (lambda (~ name) [(~@ args)] (~ body)))) - body (case ?type - (#Some type) - (` (: (~ type) (~ body))) - - #None - body)] - (return (@list& (` (;_lux_def (~ name) (~ body))) - (if export? - (@list (` (;_lux_export (~ name)))) - (@list))))) - - #None - (fail "Wrong syntax for def")))) - -(defmacro' #export (defmacro tokens) - (let [[exported? tokens] (case tokens - (\ (@list& [_ (#TagS ["" "export"])] tokens')) - [true tokens'] - - _ - [false tokens]) - name+args+body?? (: (Maybe (, Ident (List AST) AST)) - (case tokens - (\ (@list [_ (#;FormS (@list& [_ (#SymbolS name)] args))] body)) - (#Some [name args body]) - - (\ (@list [_ (#;SymbolS name)] body)) - (#Some [name #Nil body]) - - _ - #None))] - (case name+args+body?? - (#Some [name args body]) - (let [name (symbol$ name) - decls (: (List AST) - (list:++ (if exported? (@list (` (;_lux_export (~ name)))) #;Nil) - (@list (` (;;_lux_declare-macro (~ name)))))) - def-sig (case args - #;Nil name - _ (` ((~ name) (~@ args))))] - (return (@list& (` (;;def (~ def-sig) ;;Macro (~ body))) - decls))) - - - #None - (fail "Wrong syntax for defmacro")))) - -(defmacro #export (defsig tokens) - (let [[export? tokens'] (case tokens - (\ (@list& [_ (#TagS "" "export")] tokens')) - [true tokens'] - - _ - [false tokens]) - ?parts (: (Maybe (, Ident (List AST) (List AST))) - (case tokens' - (\ (@list& [_ (#FormS (@list& [_ (#SymbolS name)] args))] sigs)) - (#Some name args sigs) - - (\ (@list& [_ (#SymbolS name)] sigs)) - (#Some name #Nil sigs) - - _ - #None))] - (case ?parts - (#Some name args sigs) - (do Lux/Monad - [name+ (normalize name) - sigs' (map% Lux/Monad macro-expand sigs) - members (map% Lux/Monad - (: (-> AST (Lux (, Text AST))) - (lambda [token] - (case token - (\ [_ (#FormS (@list [_ (#SymbolS _ "_lux_:")] type [_ (#SymbolS ["" name])]))]) - (wrap [name type]) - - _ - (fail "Signatures require typed members!")))) - (list:join sigs')) - #let [[_module _name] name+ - def-name (symbol$ name) - tags (: (List AST) (map (. (: (-> Text AST) (lambda [n] (tag$ ["" n]))) first) members)) - types (map second members) - sig-type (` (#TupleT (~ (untemplate-list types)))) - sig-decl (` (;_lux_declare-tags [(~@ tags)] (~ def-name))) - sig+ (case args - #Nil - sig-type - - _ - (` (#NamedT [(~ (text$ _module)) (~ (text$ _name))] (;All (~ def-name) [(~@ args)] (~ sig-type)))))]] - (return (@list& (` (;_lux_def (~ def-name) (~ sig+))) - sig-decl - (if export? - (@list (` (;_lux_export (~ def-name)))) - #Nil)))) - - #None - (fail "Wrong syntax for defsig")))) - -(def (some f xs) - (All [a b] - (-> (-> a (Maybe b)) (List a) (Maybe b))) - (case xs - #Nil - #None - - (#Cons x xs') - (case (f x) - #None - (some f xs') - - (#Some y) - (#Some y)))) - -(def (last-index-of part text) - (-> Text Text Int) - (_jvm_i2l (_jvm_invokevirtual "java.lang.String" "lastIndexOf" ["java.lang.String"] - text [part]))) - -(def (index-of part text) - (-> Text Text Int) - (_jvm_i2l (_jvm_invokevirtual "java.lang.String" "indexOf" ["java.lang.String"] - text [part]))) - -(def (substring1 idx text) - (-> Int Text Text) - (_jvm_invokevirtual "java.lang.String" "substring" ["int"] - text [(_jvm_l2i idx)])) - -(def (substring2 idx1 idx2 text) - (-> Int Int Text Text) - (_jvm_invokevirtual "java.lang.String" "substring" ["int" "int"] - text [(_jvm_l2i idx1) (_jvm_l2i idx2)])) - -(def (split-module-contexts module) - (-> Text (List Text)) - (#Cons module (let [idx (last-index-of "/" module)] - (if (i< idx 0) - #Nil - (split-module-contexts (substring2 0 idx module)))))) - -(def (split-module module) - (-> Text (List Text)) - (let [idx (index-of "/" module)] - (if (i< idx 0) - (#Cons module #Nil) - (#Cons (substring2 0 idx module) - (split-module (substring1 (i+ 1 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) - (@ (i- idx 1) xs') - ))) - -(def (beta-reduce env type) - (-> (List Type) Type Type) - (case type - (#VariantT ?cases) - (#VariantT (map (beta-reduce env) ?cases)) - - (#TupleT ?members) - (#TupleT (map (beta-reduce env) ?members)) - - (#AppT ?type-fn ?type-arg) - (#AppT (beta-reduce env ?type-fn) (beta-reduce env ?type-arg)) - - (#UnivQ ?local-env ?local-def) - (case ?local-env - #Nil - (#UnivQ env ?local-def) - - _ - type) - - (#ExQ ?local-env ?local-def) - (case ?local-env - #Nil - (#ExQ env ?local-def) - - _ - type) - - (#LambdaT ?input ?output) - (#LambdaT (beta-reduce env ?input) (beta-reduce env ?output)) - - (#BoundT idx) - (case (@ idx env) - (#Some bound) - bound - - _ - type) - - (#NamedT name type) - (beta-reduce env type) - - _ - type - )) - -(def (apply-type type-fn param) - (-> Type Type (Maybe Type)) - (case type-fn - (#UnivQ env body) - (#Some (beta-reduce (@list& type-fn param env) body)) - - (#AppT F A) - (do Maybe/Monad - [type-fn* (apply-type F A)] - (apply-type type-fn* param)) - - (#NamedT name type) - (apply-type type param) - - _ - #None)) - -(def (resolve-struct-type type) - (-> Type (Maybe (List Type))) - (case type - (#TupleT slots) - (#Some slots) - - (#AppT fun arg) - (do Maybe/Monad - [output (apply-type fun arg)] - (resolve-struct-type output)) - - (#UnivQ _ body) - (resolve-struct-type body) - - (#ExQ _ body) - (resolve-struct-type body) - - (#NamedT name type) - (resolve-struct-type type) - - _ - #None)) - -(def (find-module name) - (-> Text (Lux (Module Compiler))) - (lambda [state] - (let [{#source source #modules modules - #envs envs #type-vars types #host host - #seed seed #eval? eval? #expected expected - #cursor cursor} state] - (case (get name modules) - (#Some module) - (#Right state module) - - _ - (#Left ($ text:++ "Unknown module: " name)))))) - -(def get-current-module - (Lux (Module Compiler)) - (do Lux/Monad - [module-name get-module-name] - (find-module module-name))) - -(def (resolve-tag [module name]) - (-> Ident (Lux (, Int (List Ident) Type))) - (do Lux/Monad - [=module (find-module module) - #let [{#module-aliases _ #defs bindings #imports _ #tags tags-table #types types} =module]] - (case (get name tags-table) - (#Some output) - (return output) - - _ - (fail (text:++ "Unknown tag: " (ident->text [module name])))))) - -(def (resolve-type-tags type) - (-> Type (Lux (Maybe (, (List Ident) (List Type))))) - (case type - (#AppT fun arg) - (resolve-type-tags fun) - - (#UnivQ env body) - (resolve-type-tags body) - - (#ExQ env body) - (resolve-type-tags body) - - (#NamedT [module name] _) - (do Lux/Monad - [=module (find-module module) - #let [{#module-aliases _ #defs bindings #imports _ #tags tags #types types} =module]] - (case (get name types) - (#Some [tags (#NamedT _ _type)]) - (case (resolve-struct-type _type) - (#Some members) - (return (#Some [tags members])) - - _ - (return #None)) - - _ - (return #None))) - - _ - (return #None))) - -(def expected-type - (Lux Type) - (lambda [state] - (let [{#source source #modules modules - #envs envs #type-vars types #host host - #seed seed #eval? eval? #expected expected - #cursor cursor} state] - (#Right state expected)))) - -(defmacro #export (struct tokens) - (do Lux/Monad - [tokens' (map% Lux/Monad macro-expand tokens) - struct-type expected-type - tags+type (resolve-type-tags struct-type) - tags (: (Lux (List Ident)) - (case tags+type - (#Some [tags _]) - (return tags) - - _ - (fail "No tags available for type."))) - #let [tag-mappings (: (List (, Text AST)) - (map (lambda [tag] [(second tag) (tag$ tag)]) - tags))] - members (map% Lux/Monad - (: (-> AST (Lux (, AST AST))) - (lambda [token] - (case token - (\ [_ (#FormS (@list [_ (#SymbolS _ "_lux_def")] [_ (#SymbolS "" tag-name)] value))]) - (case (get tag-name tag-mappings) - (#Some tag) - (wrap [tag value]) - - _ - (fail (text:++ "Unknown structure member: " tag-name))) - - _ - (fail "Invalid structure member.")))) - (list:join tokens'))] - (wrap (@list (record$ members))))) - -(defmacro #export (defstruct tokens) - (let [[export? tokens'] (case tokens - (\ (@list& [_ (#TagS "" "export")] tokens')) - [true tokens'] - - _ - [false tokens]) - ?parts (: (Maybe (, AST (List AST) AST (List AST))) - (case tokens' - (\ (@list& [_ (#FormS (@list& name args))] type defs)) - (#Some name args type defs) - - (\ (@list& name type defs)) - (#Some name #Nil type defs) - - _ - #None))] - (case ?parts - (#Some name args type defs) - (let [defs' (case args - #Nil - (` (struct (~@ defs))) - - _ - (` (lambda (~ name) [(~@ args)] (;struct (~@ defs)))))] - (return (@list& (` (def (~ name) (~ type) (~ defs'))) - (if export? - (@list (` (;_lux_export (~ name)))) - #Nil)))) - - #None - (fail "Wrong syntax for defstruct")))) - -(def #export (id x) - (All [a] (-> a a)) - x) - -(do-template [<name> <form> <message>] - [(defmacro #export (<name> tokens) - (case (reverse tokens) - (\ (@list& last init)) - (return (@list (foldL (: (-> AST AST AST) - (lambda [post pre] (` <form>))) - last - init))) - - _ - (fail <message>)))] - - [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 Importation - (, Text (Maybe Text) Referrals (Maybe Openings))) - -(def (extract-defs defs) - (-> (List AST) (Lux (List Text))) - (map% Lux/Monad - (: (-> AST (Lux Text)) - (lambda [def] - (case def - [_ (#SymbolS "" name)] - (return name) - - _ - (fail "only/exclude requires symbols.")))) - defs)) - -(def (parse-alias tokens) - (-> (List AST) (Lux (, (Maybe Text) (List AST)))) - (case tokens - (\ (@list& [_ (#TagS "" "as")] [_ (#SymbolS "" alias)] tokens')) - (return [(#Some alias) tokens']) - - _ - (return [#None tokens]))) - -(def (parse-referrals tokens) - (-> (List AST) (Lux (, Referrals (List AST)))) - (case tokens - (\ (@list& [_ (#TagS "" "refer")] referral tokens')) - (case referral - [_ (#TagS "" "all")] - (return [#All tokens']) - - (\ [_ (#FormS (@list& [_ (#TagS "" "only")] defs))]) - (do Lux/Monad - [defs' (extract-defs defs)] - (return [(#Only defs') tokens'])) - - (\ [_ (#FormS (@list& [_ (#TagS "" "exclude")] defs))]) - (do Lux/Monad - [defs' (extract-defs defs)] - (return [(#Exclude defs') tokens'])) - - _ - (fail "Incorrect syntax for referral.")) - - _ - (return [#Nothing tokens]))) - -(def (extract-symbol syntax) - (-> AST (Lux Ident)) - (case syntax - [_ (#SymbolS ident)] - (return ident) - - _ - (fail "Not a symbol."))) - -(def (parse-openings tokens) - (-> (List AST) (Lux (, (Maybe Openings) (List AST)))) - (case tokens - (\ (@list& [_ (#TagS "" "open")] [_ (#FormS (@list& [_ (#TextS prefix)] structs))] tokens')) - (do Lux/Monad - [structs' (map% Lux/Monad extract-symbol structs)] - (return [(#Some prefix structs') tokens'])) - - _ - (return [#None tokens]))) - -(def (decorate-imports super-name tokens) - (-> Text (List AST) (Lux (List AST))) - (map% Lux/Monad - (: (-> AST (Lux AST)) - (lambda [token] - (case token - [_ (#SymbolS "" sub-name)] - (return (symbol$ ["" ($ text:++ super-name "/" sub-name)])) - - (\ [_ (#FormS (@list& [_ (#SymbolS "" sub-name)] parts))]) - (return (form$ (@list& (symbol$ ["" ($ text:++ super-name "/" sub-name)]) parts))) - - _ - (fail "Wrong import syntax.")))) - tokens)) - -(def (parse-imports imports) - (-> (List AST) (Lux (List Importation))) - (do Lux/Monad - [imports' (map% Lux/Monad - (: (-> AST (Lux (List Importation))) - (lambda [token] - (case token - [_ (#SymbolS "" m-name)] - (wrap (@list [m-name #None #All #None])) - - (\ [_ (#FormS (@list& [_ (#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)] - (wrap (case [referral alias openings] - [#Nothing #None #None] sub-imports - _ (@list& [m-name alias referral openings] sub-imports)))) - - _ - (fail "Wrong syntax for import")))) - imports)] - (wrap (list:join imports')))) - -(def (module-exists? module state) - (-> Text (Lux Bool)) - (case state - {#source source #modules modules - #envs envs #type-vars types #host host - #seed seed #eval? eval? #expected expected - #cursor cursor} - (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 #type-vars types #host host - #seed seed #eval? eval? #expected expected - #cursor cursor} - (case (get module modules) - (#Some =module) - (let [to-alias (map (: (-> (, Text Definition) - (List Text)) - (lambda [gdef] - (let [[name [export? _]] gdef] - (if export? - (@list name) - (@list))))) - (let [{#module-aliases _ #defs defs #imports _ #tags tags #types types} =module] - defs))] - (#Right state (list:join to-alias))) - - #None - (#Left ($ text:++ "Unknown module: " module))) - )) - -(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)) - -(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) - (-> Text Compiler (Maybe Type)) - (case state - {#source source #modules modules - #envs envs #type-vars types #host host - #seed seed #eval? eval? #expected expected - #cursor cursor} - (some (: (-> (Env Text (Meta (, Type Cursor) Analysis)) (Maybe Type)) - (lambda [env] - (case env - {#name _ #inner-closures _ #locals {#counter _ #mappings locals} #closure {#counter _ #mappings closure}} - (try-both (some (: (-> (, Text (Meta (, Type Cursor) Analysis)) (Maybe Type)) - (lambda [[bname [[type _] _]]] - (if (text:= name 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 #type-vars types #host host - #seed seed #eval? eval? #expected expected - #cursor cursor} state] - (case (get v-prefix modules) - #None - #None - - (#Some {#defs defs #module-aliases _ #imports _ #tags tags #types types}) - (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-var-type ident) - (-> Ident (Lux Type)) - (do Lux/Monad - [#let [[module name] ident] - current-module get-module-name] - (lambda [state] - (if (text:= "" module) - (case (find-in-env name state) - (#Some struct-type) - (#Right state struct-type) - - _ - (case (find-in-defs [current-module name] state) - (#Some struct-type) - (#Right state struct-type) - - _ - (let [{#source source #modules modules - #envs envs #type-vars types #host host - #seed seed #eval? eval? #expected expected - #cursor cursor} state] - (#Left ($ text:++ "Unknown var: " (ident->text ident)))))) - (case (find-in-defs ident state) - (#Some struct-type) - (#Right state struct-type) - - _ - (let [{#source source #modules modules - #envs envs #type-vars types #host host - #seed seed #eval? eval? #expected expected - #cursor cursor} state] - (#Left ($ text:++ "Unknown var: " (ident->text ident)))))) - ))) - -(def (zip2 xs ys) - (All [a b] (-> (List a) (List b) (List (, a b)))) - (case xs - (#Cons x xs') - (case ys - (#Cons y ys') - (@list& [x y] (zip2 xs' ys')) - - _ - (@list)) - - _ - (@list))) - -(def (use-field [module name] type) - (-> Ident Type (Lux (, AST AST))) - (do Lux/Monad - [output (resolve-type-tags type) - pattern (: (Lux AST) - (case output - (#Some [tags members]) - (do Lux/Monad - [slots (map% Lux/Monad - (: (-> (, Ident Type) (Lux (, AST AST))) - (lambda [[sname stype]] (use-field sname stype))) - (zip2 tags members))] - (return (record$ slots))) - - #None - (return (symbol$ ["" name]))))] - (return [(tag$ [module name]) pattern]))) - -(defmacro #export (using tokens) - (case tokens - (\ (@list struct body)) - (case struct - [_ (#SymbolS name)] - (do Lux/Monad - [struct-type (find-var-type name) - output (resolve-type-tags struct-type)] - (case output - (#Some [tags members]) - (do Lux/Monad - [slots (map% Lux/Monad (: (-> (, Ident Type) (Lux (, AST AST))) - (lambda [[sname stype]] (use-field sname stype))) - (zip2 tags members)) - #let [pattern (record$ slots)]] - (return (@list (` (;_lux_case (~ struct) (~ pattern) (~ body)))))) - - _ - (fail "Can only \"use\" records."))) - - [_ (#TupleS members)] - (return (@list (foldL (: (-> AST AST AST) - (lambda [body' struct'] (` (;;using (~ struct') (~ body'))))) - body - members))) - - _ - (let [dummy (symbol$ ["" ""])] - (return (@list (` (;_lux_case (~ struct) - (~ dummy) - (;;using (~ dummy) - (~ body)))))))) - - _ - (fail "Wrong syntax for using"))) - -(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 (: (-> AST (, AST AST) AST) - (lambda [else branch] - (let [[right left] branch] - (` (if (~ left) (~ right) (~ else)))))) - else - (as-pairs branches')))) - - _ - (fail "Wrong syntax for cond")))) - -(def (enumerate' idx xs) - (All [a] (-> Int (List a) (List (, Int a)))) - (case xs - (#Cons x xs') - (#Cons [idx x] (enumerate' (i+ 1 idx) xs')) - - #Nil - #Nil)) - -(def (enumerate xs) - (All [a] (-> (List a) (List (, Int a)))) - (enumerate' 0 xs)) - -(defmacro #export (get@ tokens) - (case tokens - (\ (@list [_ (#TagS slot')] record)) - (do Lux/Monad - [slot (normalize slot') - output (resolve-tag slot) - #let [[idx tags type] output] - g!_ (gensym "_") - g!output (gensym "")] - (case (resolve-struct-type type) - (#Some members) - (let [pattern (record$ (map (: (-> (, Ident (, Int Type)) (, AST AST)) - (lambda [[[r-prefix r-name] [r-idx r-type]]] - [(tag$ [r-prefix r-name]) (if (i= idx r-idx) - g!output - g!_)])) - (zip2 tags (enumerate members))))] - (return (@list (` (;_lux_case (~ record) (~ pattern) (~ g!output)))))) - - _ - (fail "get@ can only use records."))) - - _ - (fail "Wrong syntax for get@"))) - -(def (open-field prefix [module name] source type) - (-> Text Ident AST Type (Lux (List AST))) - (do Lux/Monad - [output (resolve-type-tags type) - #let [source+ (` (get@ (~ (tag$ [module name])) (~ source)))]] - (case output - (#Some [tags members]) - (do Lux/Monad - [decls' (map% Lux/Monad - (: (-> (, Ident Type) (Lux (List AST))) - (lambda [[sname stype]] (open-field prefix sname source+ stype))) - (zip2 tags members))] - (return (list:join decls'))) - - _ - (return (@list (` (;_lux_def (~ (symbol$ ["" (text:++ prefix name)])) (~ source+)))))))) - -(defmacro #export (open tokens) - (case tokens - (\ (@list& [_ (#SymbolS struct-name)] tokens')) - (do Lux/Monad - [@module get-module-name - #let [prefix (case tokens' - (\ (@list [_ (#TextS prefix)])) - prefix - - _ - "")] - struct-type (find-var-type struct-name) - output (resolve-type-tags struct-type) - #let [source (symbol$ struct-name)]] - (case output - (#Some [tags members]) - (do Lux/Monad - [decls' (map% Lux/Monad (: (-> (, Ident Type) (Lux (List AST))) - (lambda [[sname stype]] (open-field prefix sname source stype))) - (zip2 tags members))] - (return (list:join decls'))) - - _ - (fail "Can only \"open\" records."))) - - _ - (fail "Wrong syntax for open"))) - -(defmacro #export (import tokens) - (do Lux/Monad - [imports (parse-imports tokens) - imports (map% Lux/Monad - (: (-> Importation (Lux Importation)) - (lambda [import] - (case import - [m-name m-alias m-referrals m-openings] - (do Lux/Monad - [m-name (clean-module m-name)] - (wrap [m-name m-alias m-referrals m-openings]))))) - imports) - unknowns' (map% Lux/Monad - (: (-> Importation (Lux (List Text))) - (lambda [import] - (case import - [m-name _ _ _] - (do Lux/Monad - [? (module-exists? m-name)] - (wrap (if ? - (@list) - (@list m-name))))))) - imports) - #let [unknowns (list:join unknowns')]] - (case unknowns - #Nil - (do Lux/Monad - [output' (map% Lux/Monad - (: (-> Importation (Lux (List AST))) - (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)] - (wrap (filter (is-member? +defs) *defs))) - - (#Exclude -defs) - (do Lux/Monad - [*defs (exported-defs m-name)] - (wrap (filter (. not (is-member? -defs)) *defs))) - - #Nothing - (wrap (@list))) - #let [openings (: (List AST) - (case m-openings - #None - (@list) - - (#Some prefix structs) - (map (: (-> Ident AST) - (lambda [struct] - (let [[_ name] struct] - (` (open (~ (symbol$ [m-name name])) (~ (text$ prefix))))))) - structs)))]] - (wrap ($ list:++ - (: (List AST) (@list (` (;_lux_import (~ (text$ m-name)))))) - (: (List AST) - (case m-alias - #None (@list) - (#Some alias) (@list (` (;_lux_alias (~ (text$ alias)) (~ (text$ m-name))))))) - (map (: (-> Text AST) - (lambda [def] - (` (;_lux_def (~ (symbol$ ["" def])) (~ (symbol$ [m-name def])))))) - defs) - openings)))))) - imports)] - (wrap (list:join output'))) - - _ - (wrap (list:++ (map (: (-> Text AST) (lambda [m-name] (` (;_lux_import (~ (text$ m-name)))))) - unknowns) - (: (List AST) (@list (` (;import (~@ tokens)))))))))) - -(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 - (: (-> AST AST (Lux AST)) - (lambda [so-far part] - (case part - [_ (#SymbolS slot)] - (return (` (using (~ so-far) (~ (symbol$ slot))))) - - (\ [_ (#FormS (@list& [_ (#SymbolS slot)] args))]) - (return (` ((using (~ so-far) (~ (symbol$ slot))) - (~@ args)))) - - _ - (fail "Wrong syntax for ::")))) - start parts)] - (return (@list output))) - - _ - (fail "Wrong syntax for ::"))) - -(defmacro #export (set@ tokens) - (case tokens - (\ (@list [_ (#TagS slot')] value record)) - (do Lux/Monad - [slot (normalize slot') - output (resolve-tag slot) - #let [[idx tags type] output]] - (case (resolve-struct-type type) - (#Some members) - (do Lux/Monad - [pattern' (map% Lux/Monad - (: (-> (, Ident (, Int Type)) (Lux (, Ident Int AST))) - (lambda [[r-slot-name [r-idx r-type]]] - (do Lux/Monad - [g!slot (gensym "")] - (return [r-slot-name r-idx g!slot])))) - (zip2 tags (enumerate members)))] - (let [pattern (record$ (map (: (-> (, Ident Int AST) (, AST AST)) - (lambda [[r-slot-name r-idx r-var]] - [(tag$ r-slot-name) r-var])) - pattern')) - output (record$ (map (: (-> (, Ident Int AST) (, AST AST)) - (lambda [[r-slot-name r-idx r-var]] - [(tag$ r-slot-name) (if (i= idx r-idx) - value - r-var)])) - pattern'))] - (return (@list (` (;_lux_case (~ record) (~ pattern) (~ output))))))) - - _ - (fail "set@ can only use records."))) - - _ - (fail "Wrong syntax for set@"))) - -(defmacro #export (update@ tokens) - (case tokens - (\ (@list [_ (#TagS slot')] fun record)) - (do Lux/Monad - [slot (normalize slot') - output (resolve-tag slot) - #let [[idx tags type] output]] - (case (resolve-struct-type type) - (#Some members) - (do Lux/Monad - [pattern' (map% Lux/Monad - (: (-> (, Ident (, Int Type)) (Lux (, Ident Int AST))) - (lambda [[r-slot-name [r-idx r-type]]] - (do Lux/Monad - [g!slot (gensym "")] - (return [r-slot-name r-idx g!slot])))) - (zip2 tags (enumerate members)))] - (let [pattern (record$ (map (: (-> (, Ident Int AST) (, AST AST)) - (lambda [[r-slot-name r-idx r-var]] - [(tag$ r-slot-name) r-var])) - pattern')) - output (record$ (map (: (-> (, Ident Int AST) (, AST AST)) - (lambda [[r-slot-name r-idx r-var]] - [(tag$ r-slot-name) (if (i= idx r-idx) - (` ((~ fun) (~ r-var))) - r-var)])) - pattern'))] - (return (@list (` (;_lux_case (~ record) (~ pattern) (~ output))))))) - - _ - (fail "update@ can only use records."))) - - _ - (fail "Wrong syntax for update@"))) - -(defmacro #export (\template tokens) - (case tokens - (\ (@list [_ (#TupleS data)] - [_ (#TupleS bindings)] - [_ (#TupleS templates)])) - (case (: (Maybe (List AST)) - (do Maybe/Monad - [bindings' (map% Maybe/Monad get-name bindings) - data' (map% Maybe/Monad tuple->list data)] - (let [apply (: (-> RepEnv (List AST)) - (lambda [env] (map (apply-template env) templates)))] - (|> data' - (join-map (. apply (make-env bindings'))) - wrap)))) - (#Some output) - (return output) - - #None - (fail "Wrong syntax for \\template")) - - _ - (fail "Wrong syntax for \\template"))) - -(def (interleave xs ys) - (All [a] (-> (List a) (List a) (List a))) - (case xs - #Nil - #Nil - - (#Cons x xs') - (case ys - #Nil - #Nil - - (#Cons y ys') - (@list& x y (interleave xs' ys'))))) - -(do-template [<name> <init> <op>] - [(def (<name> p xs) - (All [a] - (-> (-> a Bool) (List a) Bool)) - (foldL (lambda [_1 _2] (<op> _1 (p _2))) <init> xs))] - - [every? true and]) - -(def (type->ast type) - (-> Type AST) - (case type - (#DataT name params) - (` (#DataT (~ (text$ name)) (~ (untemplate-list (map type->ast params))))) - - (#;VariantT cases) - (` (#VariantT (~ (untemplate-list (map type->ast cases))))) - - (#TupleT parts) - (` (#TupleT (~ (untemplate-list (map type->ast parts))))) - - (#LambdaT in out) - (` (#LambdaT (~ (type->ast in)) (~ (type->ast out)))) - - (#BoundT idx) - (` (#BoundT (~ (int$ idx)))) - - (#VarT id) - (` (#VarT (~ (int$ id)))) - - (#ExT id) - (` (#ExT (~ (int$ id)))) - - (#UnivQ env type) - (let [env' (untemplate-list (map type->ast env))] - (` (#UnivQ (~ env') (~ (type->ast type))))) - - (#ExQ env type) - (let [env' (untemplate-list (map type->ast env))] - (` (#ExQ (~ env') (~ (type->ast type))))) - - (#AppT fun arg) - (` (#AppT (~ (type->ast fun)) (~ (type->ast arg)))) - - (#NamedT [module name] type) - (` (#NamedT [(~ (text$ module)) (~ (text$ name))] (~ (type->ast type)))))) - -(defmacro #export (loop tokens) - (case tokens - (\ (@list [_ (#TupleS bindings)] body)) - (let [pairs (as-pairs bindings) - vars (map first pairs) - inits (map second pairs)] - (if (every? symbol? inits) - (do Lux/Monad - [inits' (: (Lux (List Ident)) - (case (map% Maybe/Monad get-ident inits) - (#Some inits') (return inits') - #None (fail "Wrong syntax for loop"))) - init-types (map% Lux/Monad find-var-type inits') - expected expected-type] - (return (@list (` ((: (-> (~@ (map type->ast init-types)) - (~ (type->ast expected))) - (lambda (~ (symbol$ ["" "recur"])) [(~@ vars)] - (~ body))) - (~@ inits)))))) - (do Lux/Monad - [aliases (map% Lux/Monad - (: (-> AST (Lux AST)) - (lambda [_] (gensym ""))) - inits)] - (return (@list (` (let [(~@ (interleave aliases inits))] - (;loop [(~@ (interleave vars aliases))] - (~ body))))))))) - - _ - (fail "Wrong syntax for loop"))) - -(defmacro #export (export tokens) - (return (map (: (-> AST AST) (lambda [token] (` (;_lux_export (~ token))))) tokens))) - -(defmacro #export (\slots tokens) - (case tokens - (\ (@list body [_ (#TupleS (@list& hslot' tslots'))])) - (do Lux/Monad - [slots (: (Lux (, Ident (List Ident))) - (case (: (Maybe (, Ident (List Ident))) - (do Maybe/Monad - [hslot (get-tag hslot') - tslots (map% Maybe/Monad get-tag tslots')] - (wrap [hslot tslots]))) - (#Some slots) - (return slots) - - #None - (fail "Wrong syntax for \\slots"))) - #let [[hslot tslots] slots] - hslot (normalize hslot) - tslots (map% Lux/Monad normalize tslots) - output (resolve-tag hslot) - g!_ (gensym "_") - #let [[idx tags type] output - slot-pairings (map (: (-> Ident (, Text AST)) - (lambda [[module name]] [name (symbol$ ["" name])])) - (@list& hslot tslots)) - pattern (record$ (map (: (-> Ident (, AST AST)) - (lambda [[module name]] - (let [tag (tag$ [module name])] - (case (get name slot-pairings) - (#Some binding) [tag binding] - #None [tag g!_])))) - tags))]] - (return (@list pattern body))) - - _ - (fail "Wrong syntax for \\slots"))) - -(do-template [<name> <diff>] - [(def #export <name> - (-> Int Int) - (i+ <diff>))] - - [inc 1] - [dec -1]) diff --git a/source/lux/codata/function.lux b/source/lux/codata/function.lux deleted file mode 100644 index 1b7336049..000000000 --- a/source/lux/codata/function.lux +++ /dev/null @@ -1,27 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -## If a copy of the MPL was not distributed with this file, -## You can obtain one at http://mozilla.org/MPL/2.0/. - -(;import lux - (lux/control (monoid #as m))) - -## [Functions] -(def #export (const x y) - (All [a b] (-> a (-> b a))) - x) - -(def #export (flip f) - (All [a b c] - (-> (-> a b c) (-> b a c))) - (lambda [x y] (f y x))) - -(def #export (. f g) - (All [a b c] - (-> (-> b c) (-> a b) (-> a c))) - (lambda [x] (f (g x)))) - -## [Structures] -(defstruct #export Comp/Monoid (All [a] (m;Monoid (-> a a))) - (def unit id) - (def ++ .)) diff --git a/source/lux/codata/io.lux b/source/lux/codata/io.lux deleted file mode 100644 index 195aef616..000000000 --- a/source/lux/codata/io.lux +++ /dev/null @@ -1,42 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -## If a copy of the MPL was not distributed with this file, -## You can obtain one at http://mozilla.org/MPL/2.0/. - -(;import lux - (lux (control (functor #as F) - (monad #as M)) - (data list))) - -## [Types] -(deftype #export (IO a) - (-> (,) a)) - -## [Syntax] -(defmacro #export (@io tokens state) - (case tokens - (\ (@list value)) - (let [blank (: AST [["" -1 -1] (#;SymbolS ["" ""])])] - (#;Right [state (@list (` (;_lux_lambda (~ blank) (~ blank) (~ value))))])) - - _ - (#;Left "Wrong syntax for @io"))) - -## [Structures] -(defstruct #export IO/Functor (F;Functor IO) - (def (map f ma) - (@io (f (ma []))))) - -(defstruct #export IO/Monad (M;Monad IO) - (def _functor IO/Functor) - - (def (wrap x) - (@io x)) - - (def (join mma) - (mma []))) - -## [Functions] -(def #export (run-io io) - (All [a] (-> (IO a) a)) - (io [])) diff --git a/source/lux/codata/lazy.lux b/source/lux/codata/lazy.lux deleted file mode 100644 index c0c79fc1a..000000000 --- a/source/lux/codata/lazy.lux +++ /dev/null @@ -1,56 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -## If a copy of the MPL was not distributed with this file, -## You can obtain one at http://mozilla.org/MPL/2.0/. - -(;import lux - (lux (meta ast) - (control (functor #as F #refer #all) - (monad #as M #refer #all)) - (data list)) - (.. function)) - -## [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)) - -(def #export (call/cc f) - (All [a b c] (Lazy (-> a (Lazy b c)) (Lazy a c))) - (lambda [k] - (f (lambda [a _] - (k a)) - k))) - -(def #export (run-lazy l k) - (All [a z] (-> (Lazy a z) (-> a z) z)) - (l k)) - -## [Structs] -(defstruct #export Lazy/Functor (Functor Lazy) - (def (map f ma) - (lambda [k] (ma (. k f))))) - -(defstruct #export Lazy/Monad (Monad Lazy) - (def _functor Lazy/Functor) - - (def (wrap a) - (... a)) - - (def join !)) diff --git a/source/lux/codata/reader.lux b/source/lux/codata/reader.lux deleted file mode 100644 index e776f73ec..000000000 --- a/source/lux/codata/reader.lux +++ /dev/null @@ -1,30 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -## If a copy of the MPL was not distributed with this file, -## You can obtain one at http://mozilla.org/MPL/2.0/. - -(;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 (map f fa) - (lambda [env] - (f (fa env))))) - -(defstruct #export Reader/Monad (All [r] - (Monad (Reader r))) - (def _functor Reader/Functor) - - (def (wrap x) - (lambda [env] x)) - - (def (join mma) - (lambda [env] - (mma env env)))) diff --git a/source/lux/codata/state.lux b/source/lux/codata/state.lux deleted file mode 100644 index 311fce320..000000000 --- a/source/lux/codata/state.lux +++ /dev/null @@ -1,39 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -## If a copy of the MPL was not distributed with this file, -## You can obtain one at http://mozilla.org/MPL/2.0/. - -(;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 (All [s] - (Functor (State s))) - (def (map f ma) - (lambda [state] - (let [[state' a] (ma state)] - [state' (f a)])))) - -(defstruct #export State/Monad (All [s] - (Monad (State s))) - (def _functor State/Functor) - - (def (wrap a) - (lambda [state] - [state a])) - - (def (join mma) - (lambda [state] - (let [[state' ma] (mma state)] - (ma state'))))) - -## [Functions] -(def #export (run-state state action) - (All [s a] (-> s (State s a) a)) - (let [[state' output] (action state)] - output)) diff --git a/source/lux/codata/stream.lux b/source/lux/codata/stream.lux deleted file mode 100644 index 86ce99761..000000000 --- a/source/lux/codata/stream.lux +++ /dev/null @@ -1,140 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -## If a copy of the MPL was not distributed with this file, -## You can obtain one at http://mozilla.org/MPL/2.0/. - -(;import lux - (lux (control (functor #as F #refer #all) - (monad #as M #refer #all) - (comonad #as CM #refer #all)) - (meta lux - syntax) - (data (list #as l #refer (#only @list @list& List/Monad) #open ("" List/Fold)) - (number (int #open ("i" Int/Number Int/Ord))) - bool) - (codata (lazy #as L #refer #all)))) - -(open List/Monad "list:") - -## [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 x' xs') (... [x (cycle' x' 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) - (@ (i+ -1 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) (i+ -1 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 (comp p) xs)]) - -## [Structures] -(defstruct #export Stream/Functor (Functor Stream) - (def (map f fa) - (let [[h t] (! fa)] - (... [(f h) (map f t)])))) - -(defstruct #export Stream/CoMonad (CoMonad Stream) - (def _functor Stream/Functor) - (def unwrap head) - (def (split wa) - (let [[head tail] (! wa)] - (... [wa (split tail)])))) - -## [Pattern-matching] -(defsyntax #export (\stream& body [patterns (+^ id^)]) - (case (l;reverse patterns) - (\ (@list& last prevs)) - (do Lux/Monad - [prevs (map% Lux/Monad macro-expand-1 prevs) - g!s (gensym "s") - #let [body+ (foldL (lambda [inner outer] - (` (let [[(~ outer) (~ g!s)] (! (~ g!s))] - (~ inner)))) - (` (let [(~ last) (~ g!s)] (~ body))) - prevs)]] - (wrap (@list g!s body+))) - - _ - (fail "Wrong syntax for \\stream&"))) diff --git a/source/lux/control/bounded.lux b/source/lux/control/bounded.lux deleted file mode 100644 index b4c8a3e57..000000000 --- a/source/lux/control/bounded.lux +++ /dev/null @@ -1,14 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -## If a copy of the MPL was not distributed with this file, -## You can obtain one at http://mozilla.org/MPL/2.0/. - -(;import lux) - -## Signatures -(defsig #export (Bounded a) - (: a - top) - - (: a - bottom)) diff --git a/source/lux/control/comonad.lux b/source/lux/control/comonad.lux deleted file mode 100644 index 2543f34da..000000000 --- a/source/lux/control/comonad.lux +++ /dev/null @@ -1,52 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -## If a copy of the MPL was not distributed with this file, -## You can obtain one at http://mozilla.org/MPL/2.0/. - -(;import lux - (../functor #as F) - (lux/data/list #refer #all #open ("" List/Fold))) - -## [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 - (map f (split ma)))) - -## [Syntax] -(defmacro #export (be tokens state) - (case tokens - (#;Cons comonad (#;Cons [_ (#;TupleS bindings)] (#;Cons body #;Nil))) - (let [g!map (: AST [["" -1 -1] (#;SymbolS ["" " map "])]) - g!split (: AST [["" -1 -1] (#;SymbolS ["" " split "])]) - body' (foldL (: (-> AST (, AST AST) AST) - (lambda [body' binding] - (let [[var value] binding] - (case var - [_ (#;TagS ["" "let"])] - (` (let (~ value) (~ body'))) - - _ - (` (|> (~ value) (~ g!split) ((~ g!map) (lambda [(~ var)] (~ body'))))) - )))) - body - (reverse (as-pairs bindings)))] - (#;Right [state (#;Cons (` (case (~ comonad) - {#_functor {#F;map (~ g!map)} #unwrap (~ (' unwrap)) #split (~ g!split)} - (~ body'))) - #;Nil)])) - - _ - (#;Left "Wrong syntax for be"))) diff --git a/source/lux/control/enum.lux b/source/lux/control/enum.lux deleted file mode 100644 index 4ce368e96..000000000 --- a/source/lux/control/enum.lux +++ /dev/null @@ -1,25 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -## If a copy of the MPL was not distributed with this file, -## You can obtain one at http://mozilla.org/MPL/2.0/. - -(;import lux - (lux/control ord)) - -## [Signatures] -(defsig #export (Enum e) - (: (Ord e) _ord) - (: (-> e e) succ) - (: (-> e e) pred)) - -## [Functions] -(def (range' <= succ from to) - (All [a] (-> (-> a a Bool) (-> a a) a a (List a))) - (if (<= from to) - (#;Cons from (range' <= succ (succ from) to)) - #;Nil)) - -(def #export (range enum from to) - (All [a] (-> (Enum a) a a (List a))) - (using enum - (range' <= succ from to))) diff --git a/source/lux/control/eq.lux b/source/lux/control/eq.lux deleted file mode 100644 index d86df5757..000000000 --- a/source/lux/control/eq.lux +++ /dev/null @@ -1,11 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -## If a copy of the MPL was not distributed with this file, -## You can obtain one at http://mozilla.org/MPL/2.0/. - -(;import lux) - -## [Signatures] -(defsig #export (Eq a) - (: (-> a a Bool) - =)) diff --git a/source/lux/control/fold.lux b/source/lux/control/fold.lux deleted file mode 100644 index d0aef1576..000000000 --- a/source/lux/control/fold.lux +++ /dev/null @@ -1,42 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -## If a copy of the MPL was not distributed with this file, -## You can obtain one at http://mozilla.org/MPL/2.0/. - -(;import lux - (lux (control monoid - eq) - (data/number/int #open ("i" Int/Number Int/Eq)))) - -## [Signatures] -(defsig #export (Fold F) - (: (All [a b] - (-> (-> a b a) a (F b) a)) - foldL) - (: (All [a b] - (-> (-> b a a) a (F b) a)) - foldR)) - -## [Functions] -(def #export (foldM mon fold xs) - (All [F a] (-> (Monoid a) (Fold F) (F a) a)) - (using [mon fold] - (foldL ++ unit xs))) - -(def #export (size fold xs) - (All [F a] (-> (Fold F) (F a) Int)) - (using fold - (foldL (lambda [count _] (i+ 1 count)) - 0 - xs))) - -(def #export (member? eq fold x xs) - (All [F a] (-> (Eq a) (Fold F) a (F a) Bool)) - (using [eq fold] - (foldL (lambda [prev x'] (or prev (= x x'))) - false - xs))) - -(def #export (empty? fold xs) - (All [F a] (-> (Fold F) (F a) Bool)) - (i= 0 (size fold xs))) diff --git a/source/lux/control/functor.lux b/source/lux/control/functor.lux deleted file mode 100644 index 99c34a45c..000000000 --- a/source/lux/control/functor.lux +++ /dev/null @@ -1,12 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -## If a copy of the MPL was not distributed with this file, -## You can obtain one at http://mozilla.org/MPL/2.0/. - -(;import lux) - -## Signatures -(defsig #export (Functor f) - (: (All [a b] - (-> (-> a b) (f a) (f b))) - map)) diff --git a/source/lux/control/hash.lux b/source/lux/control/hash.lux deleted file mode 100644 index 643c49e9d..000000000 --- a/source/lux/control/hash.lux +++ /dev/null @@ -1,11 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -## If a copy of the MPL was not distributed with this file, -## You can obtain one at http://mozilla.org/MPL/2.0/. - -(;import lux) - -## [Signatures] -(defsig #export (Hash a) - (: (-> a Int) - hash)) diff --git a/source/lux/control/monad.lux b/source/lux/control/monad.lux deleted file mode 100644 index e5c5989cf..000000000 --- a/source/lux/control/monad.lux +++ /dev/null @@ -1,107 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -## If a copy of the MPL was not distributed with this file, -## You can obtain one at http://mozilla.org/MPL/2.0/. - -(;import lux - (.. (functor #as F) - (monoid #as M))) - -## [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 - (#;Cons monad (#;Cons [_ (#;TupleS bindings)] (#;Cons body #;Nil))) - (let [g!map (: AST [["" -1 -1] (#;SymbolS ["" " map "])]) - g!join (: AST [["" -1 -1] (#;SymbolS ["" " join "])]) - body' (foldL (: (-> AST (, AST AST) AST) - (lambda [body' binding] - (let [[var value] binding] - (case var - [_ (#;TagS ["" "let"])] - (` (let (~ value) (~ body'))) - - _ - (` (|> (~ value) ((~ g!map) (lambda [(~ var)] (~ body'))) (~ g!join))) - )))) - body - (reverse (as-pairs bindings)))] - (#;Right [state (#;Cons (` (case (~ monad) - {#_functor {#F;map (~ g!map)} #wrap (~ (' wrap)) #join (~ g!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 (map f ma)))) - -(def #export (seq% monad xs) - (All [M a] - (-> (Monad M) (List (M a)) (M (List a)))) - (case xs - #;Nil - (:: monad (wrap #;Nil)) - - (#;Cons x xs') - (do monad - [_x x - _xs (seq% monad xs')] - (wrap (#;Cons _x _xs))) - )) - -(def #export (map% monad f xs) - (All [M a b] - (-> (Monad M) (-> a (M b)) (List a) (M (List b)))) - (case xs - #;Nil - (:: monad (wrap #;Nil)) - - (#;Cons x xs') - (do monad - [_x (f x) - _xs (map% monad f xs')] - (wrap (#;Cons _x _xs))) - )) diff --git a/source/lux/control/monoid.lux b/source/lux/control/monoid.lux deleted file mode 100644 index 447ab8225..000000000 --- a/source/lux/control/monoid.lux +++ /dev/null @@ -1,21 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -## If a copy of the MPL was not distributed with this file, -## You can obtain one at http://mozilla.org/MPL/2.0/. - -(;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/control/number.lux b/source/lux/control/number.lux deleted file mode 100644 index b1bbec190..000000000 --- a/source/lux/control/number.lux +++ /dev/null @@ -1,25 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -## If a copy of the MPL was not distributed with this file, -## You can obtain one at http://mozilla.org/MPL/2.0/. - -(;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>)] - [+] [-] [*] [/] [%]) - - (do-template [<name>] - [(: (-> n n) <name>)] - [negate] [signum] [abs]) - - (: (-> Int n) - from-int) - ) diff --git a/source/lux/control/ord.lux b/source/lux/control/ord.lux deleted file mode 100644 index cb77e7042..000000000 --- a/source/lux/control/ord.lux +++ /dev/null @@ -1,41 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -## If a copy of the MPL was not distributed with this file, -## You can obtain one at http://mozilla.org/MPL/2.0/. - -(;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 (= x y)))) - (def > >) - (def (>= x y) - (or (> x y) - (:: eq (= 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/control/show.lux b/source/lux/control/show.lux deleted file mode 100644 index 706819ec2..000000000 --- a/source/lux/control/show.lux +++ /dev/null @@ -1,11 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -## If a copy of the MPL was not distributed with this file, -## You can obtain one at http://mozilla.org/MPL/2.0/. - -(;import lux) - -## [Signatures] -(defsig #export (Show a) - (: (-> a Text) - show)) diff --git a/source/lux/data/bool.lux b/source/lux/data/bool.lux deleted file mode 100644 index a3e28733b..000000000 --- a/source/lux/data/bool.lux +++ /dev/null @@ -1,36 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -## If a copy of the MPL was not distributed with this file, -## You can obtain one at http://mozilla.org/MPL/2.0/. - -(;import lux - (lux (control (monoid #as m) - (eq #as E) - (show #as S)) - (codata function))) - -## [Structures] -(defstruct #export Bool/Eq (E;Eq Bool) - (def (= x y) - (if x - y - (not y)))) - -(defstruct #export Bool/Show (S;Show Bool) - (def (show x) - (if x "true" "false"))) - -(do-template [<name> <unit> <op>] - [(defstruct #export <name> (m;Monoid Bool) - (def unit <unit>) - (def (++ x y) - (<op> x y)))] - - [ Or/Monoid false or] - [And/Monoid true and] - ) - -## [Functions] -(def #export comp - (All [a] (-> (-> a Bool) (-> a Bool))) - (. not)) diff --git a/source/lux/data/char.lux b/source/lux/data/char.lux deleted file mode 100644 index b7b4c6bda..000000000 --- a/source/lux/data/char.lux +++ /dev/null @@ -1,22 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -## If a copy of the MPL was not distributed with this file, -## You can obtain one at http://mozilla.org/MPL/2.0/. - -(;import lux - (lux/control (eq #as E) - (show #as S)) - (.. (text #as T #open ("text:" Text/Monoid)))) - -## [Structures] -(defstruct #export Char/Eq (E;Eq Char) - (def (= x y) - (_jvm_ceq x y))) - -(defstruct #export Char/Show (S;Show Char) - (def (show x) - ($ text:++ "#\"" (_jvm_invokevirtual "java.lang.Object" "toString" [] x []) "\""))) - -(def #export (->text c) - (-> Char Text) - (_jvm_invokevirtual "java.lang.Object" "toString" [] c [])) diff --git a/source/lux/data/either.lux b/source/lux/data/either.lux deleted file mode 100644 index 38de1e2d1..000000000 --- a/source/lux/data/either.lux +++ /dev/null @@ -1,63 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -## If a copy of the MPL was not distributed with this file, -## You can obtain one at http://mozilla.org/MPL/2.0/. - -(;import lux - (lux (control (functor #as F #refer #all) - (monad #as M #refer #all)) - (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 xs) - (All [a b] (-> (List (Either a b)) (, (List a) (List b)))) - (case xs - #;Nil - [#;Nil #;Nil] - - (#;Cons x xs') - (let [[lefts rights] (partition xs')] - (case x - (#;Left x') [(#;Cons x' lefts) rights] - (#;Right x') [lefts (#;Cons x' rights)])))) - -## [Structures] -(defstruct #export Error/Functor (All [a] (Functor (Either a))) - (def (map f ma) - (case ma - (#;Left msg) (#;Left msg) - (#;Right datum) (#;Right (f datum))))) - -(defstruct #export Error/Monad (All [a] (Monad (Either a))) - (def _functor Error/Functor) - - (def (wrap a) - (#;Right a)) - - (def (join mma) - (case mma - (#;Left msg) (#;Left msg) - (#;Right ma) ma))) diff --git a/source/lux/data/id.lux b/source/lux/data/id.lux deleted file mode 100644 index e4f2a775f..000000000 --- a/source/lux/data/id.lux +++ /dev/null @@ -1,27 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -## If a copy of the MPL was not distributed with this file, -## You can obtain one at http://mozilla.org/MPL/2.0/. - -(;import lux - (lux/control (functor #as F #refer #all) - (monad #as M #refer #all) - (comonad #as CM #refer #all))) - -## [Types] -(deftype #export (Id a) - a) - -## [Structures] -(defstruct #export Id/Functor (Functor Id) - (def map id)) - -(defstruct #export Id/Monad (Monad Id) - (def _functor Id/Functor) - (def wrap id) - (def join id)) - -(defstruct #export Id/CoMonad (CoMonad Id) - (def _functor Id/Functor) - (def unwrap id) - (def split id)) diff --git a/source/lux/data/ident.lux b/source/lux/data/ident.lux deleted file mode 100644 index cb2353e43..000000000 --- a/source/lux/data/ident.lux +++ /dev/null @@ -1,33 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -## If a copy of the MPL was not distributed with this file, -## You can obtain one at http://mozilla.org/MPL/2.0/. - -(;import lux - (lux (control (eq #as E) - (show #as S)) - (data (text #open ("text:" Text/Monoid Text/Eq))))) - -## [Types] -## (deftype Ident -## (, Text Text)) - -## [Functions] -(do-template [<name> <side>] - [(def #export (<name> [left right]) - (-> Ident Text) - <side>)] - - [module left] - [name right] - ) - -## [Structures] -(defstruct #export Ident/Eq (E;Eq Ident) - (def (= [xmodule xname] [ymodule yname]) - (and (text:= xmodule ymodule) - (text:= xname yname)))) - -(defstruct #export Ident/Show (S;Show Ident) - (def (show [module name]) - ($ text:++ module ";" name))) diff --git a/source/lux/data/list.lux b/source/lux/data/list.lux deleted file mode 100644 index 6bf050228..000000000 --- a/source/lux/data/list.lux +++ /dev/null @@ -1,344 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -## If a copy of the MPL was not distributed with this file, -## You can obtain one at http://mozilla.org/MPL/2.0/. - -(;import lux - (lux (control (monoid #as m #refer #all) - (functor #as F #refer #all) - (monad #as M #refer #all) - (eq #as E) - (ord #as O) - (fold #as f)) - (data (number (int #open ("i:" Int/Number Int/Ord Int/Show))) - bool - (text #open ("text:" Text/Monoid)) - tuple) - codata/function)) - -## [Types] -## (deftype (List a) -## (| #Nil -## (#Cons (, a (List a))))) - -## [Functions] -(defstruct #export List/Fold (f;Fold List) - (def (foldL f init xs) - (case xs - #;Nil - init - - (#;Cons [x xs']) - (foldL f (f init x) xs'))) - - (def (foldR f init xs) - (case xs - #;Nil - init - - (#;Cons [x xs']) - (f x (foldR f init xs'))))) - -(open List/Fold) - -(def #export (fold mon xs) - (All [a] - (-> (m;Monoid a) (List a) a)) - (using mon - (foldL ++ unit 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 (comp 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 (i:+ -1 n) xs')]) #;Nil] - [drop (drop (i:+ -1 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 (i:+ -1 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 (i:+ -1 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) - (All [a] (-> (List a) 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) - (@ (i:+ -1 i) xs')))) - -## [Syntax] -(defmacro #export (@list xs state) - (#;Right state (#;Cons (foldL (: (-> AST AST AST) - (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 (: (-> AST AST AST) - (lambda [tail head] (` (#;Cons (~ head) (~ tail))))) - last - init))) - - _ - (#;Left "Wrong syntax for @list&"))) - -## [Structures] -(defstruct #export (List/Eq eq) - (All [a] (-> (E;Eq a) (E;Eq (List a)))) - (def (= xs ys) - (case [xs ys] - [#;Nil #;Nil] - true - - [(#;Cons x xs') (#;Cons y ys')] - (and (:: eq (= x y)) - (= xs' ys')) - - [_ _] - false - ))) - -(defstruct #export List/Monoid (All [a] - (Monoid (List a))) - (def unit #;Nil) - (def (++ xs ys) - (case xs - #;Nil ys - (#;Cons x xs') (#;Cons x (++ xs' ys))))) - -(defstruct #export List/Functor (Functor List) - (def (map f ma) - (case ma - #;Nil #;Nil - (#;Cons a ma') (#;Cons (f a) (map f ma'))))) - -(defstruct #export List/Monad (Monad List) - (def _functor List/Functor) - - (def (wrap a) - (#;Cons a #;Nil)) - - (def (join mma) - (using List/Monoid - (foldL ++ unit mma)))) - -## [Functions] -(def #export (sort ord xs) - (All [a] (-> (O;Ord a) (List a) (List a))) - (case xs - #;Nil - #;Nil - - (#;Cons x xs') - (using ord - (let [pre (filter (>= x) xs') - post (filter (< x) xs') - ++ (:: List/Monoid ++)] - ($ ++ (sort ord pre) (@list x) (sort ord post)))))) - -## [Syntax] -(def (symbol$ name) - (-> Text AST) - [["" -1 -1] (#;SymbolS "" name)]) - -(def (range from to) - (-> Int Int (List Int)) - (if (i:<= from to) - (@list& from (range (i:+ 1 from) to)) - (@list))) - -(defmacro #export (zip tokens state) - (case tokens - (\ (@list [_ (#;IntS num-lists)])) - (if (i:> num-lists 0) - (using List/Functor - (let [indices (range 0 (i:- num-lists 1)) - type-vars (: (List AST) (map (. symbol$ i:show) indices)) - zip-type (` (All [(~@ type-vars)] - (-> (~@ (map (: (-> AST AST) (lambda [var] (` (List (~ var))))) - type-vars)) - (List (, (~@ type-vars)))))) - vars+lists (map (lambda [idx] - (let [base (text:++ "_" (i:show idx))] - [(symbol$ base) - (symbol$ (text:++ base "s"))])) - indices) - pattern (` [(~@ (map (lambda [[v vs]] (` (#;Cons (~ v) (~ vs)))) - vars+lists))]) - g!step (symbol$ "\tstep\t") - g!blank (symbol$ "\t_\t") - list-vars (map second vars+lists) - code (` (: (~ zip-type) - (lambda (~ g!step) [(~@ list-vars)] - (case [(~@ list-vars)] - (~ pattern) - (#;Cons [(~@ (map first vars+lists))] - ((~ g!step) (~@ list-vars))) - - (~ g!blank) - #;Nil))))] - (#;Right [state (@list code)]))) - (#;Left "Can't zip no lists.")) - - _ - (#;Left "Wrong syntax for zip"))) - -(def #export zip2 (zip 2)) -(def #export zip3 (zip 3)) - -(def #export (empty? xs) - (All [a] (-> (List a) Bool)) - (case xs - #;Nil true - _ false)) diff --git a/source/lux/data/maybe.lux b/source/lux/data/maybe.lux deleted file mode 100644 index 1303270a7..000000000 --- a/source/lux/data/maybe.lux +++ /dev/null @@ -1,46 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -## If a copy of the MPL was not distributed with this file, -## You can obtain one at http://mozilla.org/MPL/2.0/. - -(;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 (All [a] (Monoid (Maybe a))) - (def unit #;None) - (def (++ xs ys) - (case xs - #;None ys - (#;Some x) (#;Some x)))) - -(defstruct #export Maybe/Functor (Functor Maybe) - (def (map f ma) - (case ma - #;None #;None - (#;Some a) (#;Some (f a))))) - -(defstruct #export Maybe/Monad (Monad Maybe) - (def _functor Maybe/Functor) - - (def (wrap x) - (#;Some x)) - - (def (join mma) - (case mma - #;None #;None - (#;Some xs) xs))) - -## [Functions] -(def #export (? else maybe) - (All [a] (-> a (Maybe a) a)) - (case maybe - (#;Some x) x - _ else)) diff --git a/source/lux/data/number/int.lux b/source/lux/data/number/int.lux deleted file mode 100644 index 1e71b8a5a..000000000 --- a/source/lux/data/number/int.lux +++ /dev/null @@ -1,93 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -## If a copy of the MPL was not distributed with this file, -## You can obtain one at http://mozilla.org/MPL/2.0/. - -(;import lux - (lux/control (number #as N) - (monoid #as m) - (eq #as E) - (ord #as O) - (enum #as EN) - (bounded #as B) - (show #as S))) - -## [Structures] -## Number -(do-template [<name> <type> <+> <-> <*> </> <%> <=> <<> <from> <0> <1> <-1>] - [(defstruct #export <name> (N;Number <type>) - (def (+ x y) (<+> x y)) - (def (- x y) (<-> x y)) - (def (* x y) (<*> x y)) - (def (/ x y) (</> x y)) - (def (% x y) (<%> x y)) - (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 _jvm_ladd _jvm_lsub _jvm_lmul _jvm_ldiv _jvm_lrem _jvm_leq _jvm_llt id 0 1 -1]) - -## Eq -(defstruct #export Int/Eq (E;Eq Int) - (def (= x y) (_jvm_leq x y))) - -## Ord -(do-template [<name> <type> <eq> <=> <lt> <gt>] - [(defstruct #export <name> (O;Ord <type>) - (def _eq <eq>) - (def (< x y) (<lt> x y)) - (def (<= x y) - (or (<lt> x y) - (<=> x y))) - (def (> x y) (<gt> x y)) - (def (>= x y) - (or (<gt> x y) - (<=> x y))))] - - [ Int/Ord Int Int/Eq _jvm_leq _jvm_llt _jvm_lgt]) - -## Enum -(defstruct #export Int/Enum (EN;Enum Int) - (def _ord Int/Ord) - (def succ (lambda [n] (:: Int/Number (+ n 1)))) - (def pred (lambda [n] (:: Int/Number (- n 1))))) - -## Bounded -(do-template [<name> <type> <top> <bottom>] - [(defstruct #export <name> (B;Bounded <type>) - (def top <top>) - (def bottom <bottom>))] - - [ Int/Bounded Int (_jvm_getstatic "java.lang.Long" "MAX_VALUE") (_jvm_getstatic "java.lang.Long" "MIN_VALUE")]) - -## Monoid -(do-template [<name> <type> <unit> <++>] - [(defstruct #export <name> (m;Monoid <type>) - (def unit <unit>) - (def (++ x y) (<++> x y)))] - - [ IntAdd/Monoid Int 0 _jvm_ladd] - [ IntMul/Monoid Int 1 _jvm_lmul] - [ IntMax/Monoid Int (:: Int/Bounded bottom) (O;max Int/Ord)] - [ IntMin/Monoid Int (:: Int/Bounded top) (O;min Int/Ord)] - ) - -## Show -(do-template [<name> <type> <body>] - [(defstruct #export <name> (S;Show <type>) - (def (show x) - <body>))] - - [ Int/Show Int (_jvm_invokevirtual "java.lang.Object" "toString" [] x [])] - ) diff --git a/source/lux/data/number/real.lux b/source/lux/data/number/real.lux deleted file mode 100644 index 7d5243385..000000000 --- a/source/lux/data/number/real.lux +++ /dev/null @@ -1,93 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -## If a copy of the MPL was not distributed with this file, -## You can obtain one at http://mozilla.org/MPL/2.0/. - -(;import lux - (lux/control (number #as N) - (monoid #as m) - (eq #as E) - (ord #as O) - (enum #as EN) - (bounded #as B) - (show #as S))) - -## [Structures] -## Number -(do-template [<name> <type> <+> <-> <*> </> <%> <=> <<> <from> <0> <1> <-1>] - [(defstruct #export <name> (N;Number <type>) - (def (+ x y) (<+> x y)) - (def (- x y) (<-> x y)) - (def (* x y) (<*> x y)) - (def (/ x y) (</> x y)) - (def (% x y) (<%> x y)) - (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>)) - )] - - [Real/Number Real _jvm_dadd _jvm_dsub _jvm_dmul _jvm_ddiv _jvm_drem _jvm_deq _jvm_dlt _jvm_l2d 0.0 1.0 -1.0]) - -## Eq -(defstruct #export Real/Eq (E;Eq Real) - (def (= x y) (_jvm_deq x y))) - -## Ord -(do-template [<name> <type> <eq> <=> <lt> <gt>] - [(defstruct #export <name> (O;Ord <type>) - (def _eq <eq>) - (def (< x y) (<lt> x y)) - (def (<= x y) - (or (<lt> x y) - (<=> x y))) - (def (> x y) (<gt> x y)) - (def (>= x y) - (or (<gt> x y) - (<=> x y))))] - - [Real/Ord Real Real/Eq _jvm_deq _jvm_dlt _jvm_dgt]) - -## Enum -(defstruct Real/Enum (EN;Enum Real) - (def _ord Real/Ord) - (def succ (lambda [n] (:: Real/Number (+ n 1.0)))) - (def pred (lambda [n] (:: Real/Number (- n 1.0))))) - -## Bounded -(do-template [<name> <type> <top> <bottom>] - [(defstruct #export <name> (B;Bounded <type>) - (def top <top>) - (def bottom <bottom>))] - - [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 unit <unit>) - (def (++ x y) (<++> x y)))] - - [RealAdd/Monoid Real 0.0 _jvm_dadd] - [RealMul/Monoid Real 1.0 _jvm_dmul] - [RealMax/Monoid Real (:: Real/Bounded bottom) (O;max Real/Ord)] - [RealMin/Monoid Real (:: Real/Bounded top) (O;min Real/Ord)] - ) - -## Show -(do-template [<name> <type> <body>] - [(defstruct #export <name> (S;Show <type>) - (def (show x) - <body>))] - - [Real/Show Real (_jvm_invokevirtual "java.lang.Object" "toString" [] x [])] - ) diff --git a/source/lux/data/text.lux b/source/lux/data/text.lux deleted file mode 100644 index af2de51ff..000000000 --- a/source/lux/data/text.lux +++ /dev/null @@ -1,195 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -## If a copy of the MPL was not distributed with this file, -## You can obtain one at http://mozilla.org/MPL/2.0/. - -(;import lux - (lux (control (monoid #as m) - (eq #as E) - (ord #as O) - (show #as S) - (monad #as M #refer #all)) - (data (number (int #open ("i" Int/Number Int/Ord))) - maybe))) - -## [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 (= x y) - (_jvm_invokevirtual "java.lang.Object" "equals" ["java.lang.Object"] - x [y]))) - -(defstruct #export Text/Ord (O;Ord Text) - (def _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))] - - [< i<] - [<= i<=] - [> i>] - [>= i>=])) - -(defstruct #export Text/Show (S;Show Text) - (def show id)) - -(defstruct #export Text/Monoid (m;Monoid Text) - (def unit "") - (def (++ x y) - (_jvm_invokevirtual "java.lang.String" "concat" ["java.lang.String"] - x [y]))) - -## [Syntax] -(def (extract-var template) - (-> Text (Maybe (, Text Text Text))) - (do Maybe/Monad - [pre-idx (index-of "#{" template) - [pre in] (split pre-idx template) - [_ in] (split 2 in) - post-idx (index-of "}" in) - [var post] (split post-idx in) - #let [[_ post] (? ["" ""] (split 1 post))]] - (wrap [pre var post]))) - -(do-template [<name> <type> <tag>] - [(def (<name> value) - (-> <type> AST) - [["" -1 -1] (<tag> value)])] - - [text$ Text #;TextS] - [symbol$ Ident #;SymbolS]) - -(def (unravel-template template) - (-> Text (List AST)) - (case (extract-var template) - (#;Some [pre var post]) - (#;Cons (text$ pre) - (#;Cons (symbol$ ["" var]) - (unravel-template post))) - - #;None - (#;Cons (text$ template) #;Nil))) - -(defmacro #export (<> tokens state) - (case tokens - (#;Cons [_ (#;TextS template)] #;Nil) - (let [++ (symbol$ ["" ""])] - (#;Right state (#;Cons (` (;let [(~ ++) (get@ #m;++ Text/Monoid)] - (;$ (~ ++) (~@ (unravel-template template))))) - #;Nil))) - - _ - (#;Left "Wrong syntax for <>"))) - -(def #export (split-lines text) - (-> Text (List Text)) - (case (: (Maybe (List Text)) - (do Maybe/Monad - [idx (index-of "\n" text) - [head post] (split (inc idx) text)] - (wrap (#;Cons head (split-lines post))))) - #;None - (#;Cons text #;Nil) - - (#;Some xs) - xs)) diff --git a/source/lux/data/tuple.lux b/source/lux/data/tuple.lux deleted file mode 100644 index 6eef74670..000000000 --- a/source/lux/data/tuple.lux +++ /dev/null @@ -1,35 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -## If a copy of the MPL was not distributed with this file, -## You can obtain one at http://mozilla.org/MPL/2.0/. - -(;import lux) - -## [Functions] -(do-template [<name> <type> <output>] - [(def #export (<name> xy) - (All [a b] (-> (, a b) <type>)) - (let [[x y] xy] - <output>))] - - [first a x] - [second b 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)))) - -(def #export (swap xy) - (All [a b] (-> (, a b) (, b a))) - (let [[x y] xy] - [y x])) diff --git a/source/lux/data/writer.lux b/source/lux/data/writer.lux deleted file mode 100644 index 3bf99c1ad..000000000 --- a/source/lux/data/writer.lux +++ /dev/null @@ -1,31 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -## If a copy of the MPL was not distributed with this file, -## You can obtain one at http://mozilla.org/MPL/2.0/. - -(;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 (map f fa) - (let [[log datum] fa] - [log (f datum)]))) - -(defstruct #export (Writer/Monad mon) (All [l] - (-> (Monoid l) (Monad (Writer l)))) - (def _functor Writer/Functor) - - (def (wrap x) - [(:: mon unit) x]) - - (def (join mma) - (let [[log1 [log2 a]] mma] - [(:: mon (++ log1 log2)) a]))) diff --git a/source/lux/host/io.lux b/source/lux/host/io.lux deleted file mode 100644 index 220f089a2..000000000 --- a/source/lux/host/io.lux +++ /dev/null @@ -1,60 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -## If a copy of the MPL was not distributed with this file, -## You can obtain one at http://mozilla.org/MPL/2.0/. - -(;import lux - (lux (data (list #refer #all #open ("" List/Fold))) - (codata io) - (meta ast - syntax - lux) - control/monad) - (.. jvm)) - -## [Functions] -(do-template [<name> <method> <type> <class>] - [(def #export (<name> x) - (-> <type> (IO (,))) - (@io (_jvm_invokevirtual "java.io.PrintStream" <method> [<class>] - (_jvm_getstatic "java.lang.System" "out") [x])))] - - [write-char "print" Char "char"] - [write "print" Text "java.lang.String"] - [write-line "println" Text "java.lang.String"] - ) - -(do-template [<name> <type> <op>] - [(def #export <name> - (IO (Maybe <type>)) - (let [in (_jvm_getstatic "java.lang.System" "in") - reader (_jvm_new "java.io.InputStreamReader" ["java.io.InputStream"] [in]) - buff-reader (_jvm_new "java.io.BufferedReader" ["java.io.Reader"] [reader])] - (@io (let [output (: (Either Text <type>) (try <op>)) - _close (: (Either Text (,)) (try (_jvm_invokeinterface "java.io.Closeable" "close" [] buff-reader [])))] - (case [output _close] - (\or [(#;Left _) _] [_ (#;Left _)]) #;None - [(#;Right input) (#;Right _)] (#;Some input))))))] - - [read-char Char (_jvm_i2c (_jvm_invokevirtual "java.io.BufferedReader" "read" [] buff-reader []))] - [read-line Text (_jvm_invokevirtual "java.io.BufferedReader" "readLine" [] buff-reader [])] - ) - -## [Syntax] -(def simple-bindings^ - (Parser (List (, Text AST))) - (tuple^ (*^ (&^ local-symbol^ id^)))) - -(defsyntax #export (with-open [bindings simple-bindings^] body) - (do Lux/Monad - [g!output (gensym "output") - #let [code (foldL (: (-> AST (, Text AST) AST) - (lambda [body [res-name res-value]] - (let [g!res-name (symbol$ ["" res-name])] - (` (let [(~ g!res-name) (~ res-value) - (~ g!output) (~ body)] - (exec (;_jvm_invokeinterface "java.io.Closeable" "close" [] (~ g!res-name) []) - (~ g!output))))))) - body - (reverse bindings))]] - (wrap (@list code)))) diff --git a/source/lux/host/jvm.lux b/source/lux/host/jvm.lux deleted file mode 100644 index 737c1731d..000000000 --- a/source/lux/host/jvm.lux +++ /dev/null @@ -1,377 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -## If a copy of the MPL was not distributed with this file, -## You can obtain one at http://mozilla.org/MPL/2.0/. - -(;import lux - (lux (control (monoid #as m) - (functor #as F) - (monad #as M #refer (#only do seq%)) - (enum #as E)) - (data (list #refer #all #open ("" List/Functor List/Fold)) - (number/int #refer #all #open ("i:" Int/Ord Int/Number)) - maybe - tuple - (text #open ("text:" Text/Monoid))) - (meta lux - ast - syntax))) - -(open List/Monad "list:") - -## [Types] -(defsyntax #export (Array [dimensions (?^ nat^)] type) - (emit (@list (foldL (lambda [inner _] (` (#;DataT "#Array" (@list (~ inner))))) - type - (repeat (? 1 dimensions) []))))) - -## [Utils] -## Types -(deftype StackFrame (^ java.lang.StackTraceElement)) -(deftype StackTrace (Array StackFrame)) - -(deftype Modifier Text) -(deftype JvmType Text) - -(deftype AnnotationParam - (, Text AST)) - -(deftype Annotation - (& #ann-name Text - #ann-params (List AnnotationParam))) - -(deftype MemberDecl - (& #member-name Text - #member-modifiers (List Modifier) - #member-anns (List Annotation))) - -(deftype FieldDecl - JvmType) - -(deftype MethodDecl - (& #method-inputs (List JvmType) - #method-output JvmType - #method-exs (List JvmType))) - -(deftype ArgDecl - (& #arg-name Text - #arg-type JvmType)) - -(deftype MethodDef - (& #method-vars (List ArgDecl) - #return-type JvmType - #return-body AST - #throws-exs (List JvmType))) - -(deftype ExpectedInput - (& #opt-input? Bool - #input-type JvmType)) - -(deftype ExpectedOutput - (& #ex-output? Bool - #opt-output? Bool - #output-type JvmType)) - -## Functions -(def (prepare-args args) - (-> (List ExpectedInput) (Lux (, (List AST) (List AST) (List AST) (List Text)))) - (do Lux/Monad - [vars (seq% Lux/Monad (repeat (size args) (gensym ""))) - #let [pairings (map (: (-> (, (, Bool Text) AST) (, AST (List AST))) - (lambda [[[opt? arg-class] var]] - (if opt? - [(` (Maybe (^ (~ (symbol$ ["" arg-class]))))) - (@list var (` (: (^ (~ (symbol$ ["" arg-class]))) - (case (~ var) - (#;Some (~ var)) (~ var) - #;None ;_jvm_null))))] - [(` (^ (~ (symbol$ ["" arg-class])))) - (@list)]))) - (zip2 args vars)) - var-types (map first pairings) - var-rebinds (map second pairings) - arg-classes (map second args)]] - (wrap [vars var-types (list:join var-rebinds) arg-classes]))) - -(def (class->type class) - (-> JvmType AST) - (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)) - "void" (` ;Unit) - _ - (` (^ (~ (symbol$ ["" class])))))) - -## Parsers -(def annotation-params^ - (Parser (List AnnotationParam)) - (record^ (*^ (tuple^ (&^ local-tag^ id^))))) - -(def annotation^ - (Parser Annotation) - (form^ (&^ local-symbol^ - annotation-params^))) - -(def annotations^' - (Parser (List Annotation)) - (do Parser/Monad - [_ (tag!^ ["" "ann"])] - (tuple^ (*^ annotation^)))) - -(def annotations^ - (Parser (List Annotation)) - (do Parser/Monad - [anns?? (?^ annotations^')] - (wrap (? (@list) anns??)))) - -(def member-decl^ - (Parser MemberDecl) - (do Parser/Monad - [modifiers (*^ local-tag^) - name local-symbol^ - anns annotations^] - (wrap [name modifiers anns]))) - -(def throws-decl'^ - (Parser (List JvmType)) - (do Parser/Monad - [_ (tag!^ ["" "throws"])] - (tuple^ (*^ local-symbol^)))) - -(def throws-decl^ - (Parser (List JvmType)) - (do Parser/Monad - [exs? (?^ throws-decl'^)] - (wrap (? (@list) exs?)))) - -(def method-decl'^ - (Parser MethodDecl) - (do Parser/Monad - [inputs (tuple^ (*^ local-symbol^)) - outputs local-symbol^ - exs throws-decl^] - (wrap [inputs outputs exs]))) - -(def method-decl^ - (Parser (, MemberDecl MethodDecl)) - (form^ (&^ member-decl^ - method-decl'^))) - -(def field-decl^ - (Parser (, MemberDecl FieldDecl)) - (form^ (&^ member-decl^ - local-symbol^))) - -(def arg-decl^ - (Parser ArgDecl) - (form^ (&^ local-symbol^ local-symbol^))) - -(def method-def'^ - (Parser MethodDef) - (do Parser/Monad - [inputs (tuple^ (*^ arg-decl^)) - output local-symbol^ - exs throws-decl^ - body id^] - (wrap [inputs output body exs]))) - -(def method-def^ - (Parser (, MemberDecl MethodDef)) - (form^ (&^ member-decl^ - method-def'^))) - -(def exp-input^ - (Parser ExpectedInput) - (&^ (tag?^ ["" "?"]) - local-symbol^)) - -(def exp-output^ - (Parser ExpectedOutput) - (do Parser/Monad - [ex? (tag?^ ["" "!"]) - opt? (tag?^ ["" "?"]) - return local-symbol^] - (wrap [ex? opt? return]))) - -## Generators -(def (gen-annotation-param [name value]) - (-> AnnotationParam (, AST AST)) - [(text$ name) value]) - -(def (gen-annotation [name params]) - (-> Annotation AST) - (` ((~ (text$ name)) - (~ (record$ (map gen-annotation-param params)))))) - -(def (gen-method-decl [[name modifiers anns] [inputs output exs]]) - (-> (, MemberDecl MethodDecl) AST) - (` ((~ (text$ name)) - [(~@ (map text$ modifiers))] - [(~@ (map gen-annotation anns))] - [(~@ (map text$ exs))] - [(~@ (map text$ inputs))] - (~ (text$ output))))) - -(def (gen-field-decl [[name modifiers anns] class]) - (-> (, MemberDecl FieldDecl) AST) - (` ((~ (text$ name)) - [(~@ (map text$ modifiers))] - [(~@ (map gen-annotation anns))] - (~ (text$ class)) - ))) - -(def (gen-arg-decl [name type]) - (-> ArgDecl AST) - (form$ (@list (symbol$ ["" name]) (text$ type)))) - -(def (gen-method-def [[name modifiers anns] [inputs output body exs]]) - (-> (, MemberDecl MethodDef) AST) - (` ((~ (text$ name)) - [(~@ (map text$ modifiers))] - [(~@ (map gen-annotation anns))] - [(~@ (map text$ exs))] - [(~@ (map gen-arg-decl inputs))] - (~ (text$ output)) - (~ body)))) - -(def (gen-expected-output [ex? opt? output] body) - (-> ExpectedOutput AST (, AST AST)) - (let [type (class->type output) - [body type] (if opt? - [(` (;;??? (~ body))) - (` (Maybe (~ type)))] - [body type]) - [body type] (if ex? - [(` (;;try (~ body))) - (` (Either Text (~ type)))] - [body type])] - [body type])) - -## [Functions] -(def (stack-trace->text trace) - (-> StackTrace Text) - (let [size (_jvm_arraylength trace) - idxs (E;range Int/Enum 0 (i:+ -1 size))] - (|> idxs - (map (: (-> Int Text) - (lambda [idx] - (_jvm_invokevirtual "java.lang.Object" "toString" [] (_jvm_aaload trace idx) [])))) - (interpose "\n") - (foldL text:++ "") - ))) - -(def (get-stack-trace t) - (-> (^ java.lang.Throwable) StackTrace) - (_jvm_invokevirtual "java.lang.Throwable" "getStackTrace" [] t [])) - -(def #export (throwable->text t) - (-> (^ java.lang.Throwable) Text) - ($ text:++ - (_jvm_invokevirtual "java.lang.Object" "toString" [] t []) - "\n" - (|> t get-stack-trace stack-trace->text))) - -## [Syntax] -(defsyntax #export (defclass [name local-symbol^] [super local-symbol^] [interfaces (tuple^ (*^ local-symbol^))] - [annotations annotations^] - [fields (*^ field-decl^)] - [methods (*^ method-def^)]) - (emit (@list (` (;_jvm_class (~ (text$ name)) (~ (text$ super)) - [(~@ (map text$ interfaces))] - [(~@ (map gen-annotation annotations))] - [(~@ (map gen-field-decl fields))] - [(~@ (map gen-method-def methods))]))))) - -(defsyntax #export (definterface [name local-symbol^] [supers (tuple^ (*^ local-symbol^))] - [annotations annotations^] - [members (*^ method-decl^)]) - (emit (@list (` (;_jvm_interface (~ (text$ name)) [(~@ (map text$ supers))] - [(~@ (map gen-annotation annotations))] - (~@ (map gen-method-decl members))))))) - -(defsyntax #export (object [super local-symbol^] [interfaces (tuple^ (*^ local-symbol^))] - [methods (*^ method-def^)]) - (emit (@list (` (;_jvm_anon-class (~ (text$ super)) - [(~@ (map text$ interfaces))] - [(~@ (map gen-method-def methods))]))))) - -(defsyntax #export (program [args symbol^] body) - (emit (@list (` (;_jvm_program (~ (symbol$ args)) - (~ body)))))) - -(defsyntax #export (??? expr) - (do Lux/Monad - [g!temp (gensym "")] - (wrap (@list (` (let [(~ g!temp) (~ expr)] - (if (;_jvm_null? (~ g!temp)) - #;None - (#;Some (~ g!temp))))))))) - -(defsyntax #export (try expr) - (emit (@list (` (;_jvm_try (#;Right (~ expr)) - (~ (' (_jvm_catch "java.lang.Exception" e - (#;Left (throwable->text e)))))))))) - -(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 "") - g!_ (gensym "")] - (emit (@list (` (let [(~ g!lock) (~ lock) - (~ g!_) (;_jvm_monitorenter (~ g!lock)) - (~ g!body) (~ body) - (~ g!_) (;_jvm_monitorexit (~ g!lock))] - (~ g!body))))) - )) - -(defsyntax #export (null? obj) - (emit (@list (` (;_jvm_null? (~ obj)))))) - -(defsyntax #export (new$ [class local-symbol^] [args (tuple^ (*^ exp-input^))] [unsafe? (tag?^ ["" "unsafe"])]) - (do Lux/Monad - [[vars var-types var-rebinds arg-classes] (prepare-args args) - #let [new-expr (` (;_jvm_new (~ (text$ class)) [(~@ (map text$ arg-classes))] [(~@ vars)])) - return-type (class->type class) - [new-expr return-type] (if unsafe? - [(` (try (~ new-expr))) (` (Either Text (~ return-type)))] - [new-expr return-type])]] - (wrap (@list (` (: (-> (, (~@ var-types)) (~ return-type)) - (lambda [[(~@ vars)]] - (let [(~@ var-rebinds)] - (~ new-expr))))))))) - -(do-template [<name> <op> <use-self?>] - [(defsyntax #export (<name> [class local-symbol^] [method local-symbol^] [args (tuple^ (*^ exp-input^))] - [expected-output exp-output^] [unsafe? (tag?^ ["" "unsafe"])]) - (do Lux/Monad - [[vars var-types var-rebinds arg-classes] (prepare-args args) - g!self (gensym "self") - #let [included-self (: (List AST) - (if <use-self?> - (@list g!self) - (@list))) - [body return-type] (gen-expected-output expected-output - (` (<op> (~ (text$ class)) (~ (text$ method)) [(~@ (map text$ arg-classes))] (~@ included-self) [(~@ vars)]))) - [body return-type] (if unsafe? - [(` (try (~ body))) (` (Either Text (~ return-type)))] - [body return-type])]] - (wrap (@list (` (: (-> (, (~@ var-types)) (^ (~ (symbol$ ["" class]))) (~ return-type)) - (lambda [[(~@ vars)] (~@ included-self)] - (let [(~@ var-rebinds)] - (~ body))))))) - ))] - - [invoke-virtual$ ;_jvm_invokevirtual true] - [invoke-interface$ ;_jvm_invokeinterface true] - [invoke-special$ ;_jvm_invokespecial true] - [invoke-static$ ;_jvm_invokestatic false] - ) diff --git a/source/lux/math.lux b/source/lux/math.lux deleted file mode 100644 index a60ce512c..000000000 --- a/source/lux/math.lux +++ /dev/null @@ -1,80 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -## If a copy of the MPL was not distributed with this file, -## You can obtain one at http://mozilla.org/MPL/2.0/. - -(;import lux - (lux/data/number/int #open ("i:" Int/Number))) - -## [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"] - ) - -(def (gcd' a b) - (-> Int Int Int) - (case b - 0 a - _ (gcd' b (i:% a b)))) - -(def #export (gcd a b) - (-> Int Int Int) - (gcd' (i:abs a) (i:abs b))) - -(def #export (lcm x y) - (-> Int Int Int) - (case [x y] - (\or [_ 0] [0 _]) - 0 - - _ - (i:abs (i:* (i:/ x (gcd x y)) y)))) diff --git a/source/lux/meta/ast.lux b/source/lux/meta/ast.lux deleted file mode 100644 index a9bc8b588..000000000 --- a/source/lux/meta/ast.lux +++ /dev/null @@ -1,113 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -## If a copy of the MPL was not distributed with this file, -## You can obtain one at http://mozilla.org/MPL/2.0/. - -(;import lux - (lux (control (show #as S #refer #all) - (eq #as E #refer #all)) - (data bool - (number int - real) - char - (text #refer (#only Text/Show Text/Eq) #open ("text:" Text/Monoid)) - ident - (list #refer #all #open ("" List/Functor List/Fold)) - ))) - -## [Types] -## (deftype (AST' w) -## (| (#;BoolS Bool) -## (#;IntS Int) -## (#;RealS Real) -## (#;CharS Char) -## (#;TextS Text) -## (#;SymbolS Text Text) -## (#;TagS Text Text) -## (#;FormS (List (w (AST' w)))) -## (#;TupleS (List (w (AST' w)))) -## (#;RecordS (List (, (w (AST' w)) (w (AST' w))))))) - -## (deftype AST -## (Meta Cursor (AST' (Meta Cursor)))) - -## [Utils] -(def _cursor Cursor ["" -1 -1]) - -## [Functions] -(do-template [<name> <type> <tag>] - [(def #export (<name> x) - (-> <type> AST) - [_cursor (<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 AST) #;FormS] - [tuple$ (List AST) #;TupleS] - [record$ (List (, AST AST)) #;RecordS] - ) - -## [Structures] -(defstruct #export AST/Show (Show AST) - (def (show ast) - (case ast - (\template [<tag> <struct>] - [[_ (<tag> value)] - (:: <struct> (show value))]) - [[#;BoolS Bool/Show] - [#;IntS Int/Show] - [#;RealS Real/Show] - [#;CharS Char/Show] - [#;TextS Text/Show]] - - (\template [<tag> <prefix>] - [[_ (<tag> ident)] - (text:++ <prefix> (:: Ident/Show (show ident)))]) - [[#;SymbolS ""] [#;TagS "#"]] - - (\template [<tag> <open> <close>] - [[_ (<tag> members)] - ($ text:++ <open> (|> members (map show) (interpose "") (foldL text:++ text:unit)) <close>)]) - [[#;FormS "(" ")"] [#;TupleS "[" "]"]] - - [_ (#;RecordS pairs)] - ($ text:++ "{" (|> pairs (map (lambda [[left right]] ($ text:++ (show left) " " (show right)))) (interpose "") (foldL text:++ text:unit)) "}") - ))) - -(defstruct #export AST/Eq (Eq AST) - (def (= x y) - (case [x y] - (\template [<tag> <struct>] - [[[_ (<tag> x')] [_ (<tag> y')]] - (:: <struct> (= x' y'))]) - [[#;BoolS Bool/Eq] - [#;IntS Int/Eq] - [#;RealS Real/Eq] - [#;CharS Char/Eq] - [#;TextS Text/Eq] - [#;SymbolS Ident/Eq] - [#;TagS Ident/Eq]] - - (\template [<tag>] - [[[_ (<tag> xs')] [_ (<tag> ys')]] - (and (:: Int/Eq (= (size xs') (size ys'))) - (foldL (lambda [old [x' y']] - (and old (= x' y'))) - true - (zip2 xs' ys')))]) - [[#;FormS] [#;TupleS]] - - [[_ (#;RecordS xs')] [_ (#;RecordS ys')]] - (and (:: Int/Eq (= (size xs') (size ys'))) - (foldL (lambda [old [[xl' xr'] [yl' yr']]] - (and old (= xl' yl') (= xr' yr'))) - true - (zip2 xs' ys'))) - - _ - false))) diff --git a/source/lux/meta/lux.lux b/source/lux/meta/lux.lux deleted file mode 100644 index b6ff09f59..000000000 --- a/source/lux/meta/lux.lux +++ /dev/null @@ -1,366 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -## If a copy of the MPL was not distributed with this file, -## You can obtain one at http://mozilla.org/MPL/2.0/. - -(;import lux - (.. ast) - (lux/control (monoid #as m) - (functor #as F) - (monad #as M #refer (#only do)) - (show #as S)) - (lux/data (list #refer #all #open ("list:" List/Monoid List/Functor)) - (text #as T #open ("text:" Text/Monoid Text/Eq)) - (number/int #as I #open ("i" Int/Number)) - (tuple #as t) - ident)) - -## [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 (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 _functor Lux/Functor) - (def (wrap x) - (lambda [state] - (#;Right [state x]))) - (def (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)) - (case (get module modules) - (#;Some $module) - (case (|> (: (Module Compiler) $module) (get@ #;defs) (get name)) - (#;Some gdef) - (case (: Definition 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) - - _ - #;None) - - _ - #;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] - (wrap [module-name name])) - - _ - (:: Lux/Monad (wrap ident)))) - -(def #export (macro-expand syntax) - (-> AST (Lux (List AST))) - (case syntax - [_ (#;FormS (#;Cons [[_ (#;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)] - (wrap (:: List/Monad (join expansion')))) - - #;None - (:: Lux/Monad (wrap (@list syntax))))) - - _ - (:: Lux/Monad (wrap (@list syntax))))) - -(def #export (macro-expand-all syntax) - (-> AST (Lux (List AST))) - (case syntax - [_ (#;FormS (#;Cons [[_ (#;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-all expansion)] - (wrap (:: List/Monad (join expansion')))) - - #;None - (do Lux/Monad - [parts' (M;map% Lux/Monad macro-expand-all (@list& (symbol$ macro-name) args))] - (wrap (@list (form$ (:: List/Monad (join parts')))))))) - - [_ (#;FormS (#;Cons [harg targs]))] - (do Lux/Monad - [harg+ (macro-expand-all harg) - targs+ (M;map% Lux/Monad macro-expand-all targs)] - (wrap (@list (form$ (list:++ harg+ (:: List/Monad (join (: (List (List AST)) targs+)))))))) - - [_ (#;TupleS members)] - (do Lux/Monad - [members' (M;map% Lux/Monad macro-expand-all members)] - (wrap (@list (tuple$ (:: List/Monad (join members')))))) - - _ - (:: Lux/Monad (wrap (@list syntax))))) - -(def #export (gensym prefix state) - (-> Text (Lux AST)) - (#;Right [(update@ #;seed (i+ 1) state) - (symbol$ ["" ($ text:++ "__gensym__" prefix (:: I;Int/Show (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) - (-> AST (Lux AST)) - (do Lux/Monad - [token+ (macro-expand token)] - (case token+ - (\ (@list token')) - (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 (map (: (-> (, Text Definition) - (List Text)) - (lambda [gdef] - (let [[name [export? _]] gdef] - (if export? - (@list name) - (@list))))) - (get@ #;defs =module)))])) - - #;None - (#;Left ($ text:++ "Unknown module: " module)))) - -(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 #export (find-in-env name state) - (-> Text Compiler (Maybe Type)) - (case state - {#;source source #;modules modules - #;envs envs #;type-vars types #;host host - #;seed seed #;eval? eval? #;expected expected - #;cursor cursor} - (some (: (-> (Env Text (Meta (, Type Cursor) Analysis)) (Maybe Type)) - (lambda [env] - (case env - {#;name _ #;inner-closures _ #;locals {#;counter _ #;mappings locals} #;closure {#;counter _ #;mappings closure}} - (try-both (some (: (-> (, Text (Meta (, Type Cursor) Analysis)) (Maybe Type)) - (lambda [binding] - (let [[bname [[type _] _]] binding] - (if (text:= name bname) - (#;Some type) - #;None))))) - locals - closure)))) - envs))) - -(def (find-in-defs' name state) - (-> Ident Compiler (Maybe Definition)) - (let [[v-prefix v-name] name - {#;source source #;modules modules - #;envs envs #;type-vars types #;host host - #;seed seed #;eval? eval? #;expected expected - #;cursor cursor} state] - (case (get v-prefix modules) - #;None - #;None - - (#;Some {#;defs defs #;module-aliases _ #;imports _ #;tags _ #;types _}) - (case (get v-name defs) - #;None - #;None - - (#;Some def) - (case def - [_ (#;AliasD name')] (find-in-defs' name' state) - _ (#;Some def) - ))) - )) - -(def #export (find-in-defs name state) - (-> Ident Compiler (Maybe Type)) - (case (find-in-defs' name state) - (#;Some [_ def-data]) - (case def-data - (#;ValueD [type value]) (#;Some type) - (#;MacroD _) (#;Some Macro) - (#;TypeD _) (#;Some Type) - _ #;None) - - #;None - #;None)) - -(def #export (find-var-type name) - (-> Ident (Lux Type)) - (do Lux/Monad - [#let [[_ _name] name] - 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]) - - _ - (#;Left ($ text:++ "Unknown var: " (ident->text name))))))) - )) - -(def #export (find-type name) - (-> Ident (Lux Type)) - (do Lux/Monad - [name' (normalize name)] - (: (Lux Type) - (lambda [state] - (case (find-in-defs' name' state) - (#;Some def-data) - (case def-data - [_ (#;TypeD type)] (#;Right [state type]) - _ (#;Left ($ text:++ "Definition is not a type: " (ident->text name)))) - - _ - (#;Left ($ text:++ "Unknown var: " (ident->text name)))))) - )) - -(def #export (defs module-name state) - (-> Text (Lux (List (, Text Definition)))) - (case (get module-name (get@ #;modules state)) - #;None (#;Left ($ text:++ "Unknown module: " module-name)) - (#;Some module) (#;Right [state (get@ #;defs module)]) - )) - -(def #export (exports module-name) - (-> Text (Lux (List (, Text Definition)))) - (do Lux/Monad - [defs (defs module-name)] - (wrap (filter (lambda [[name [exported? data]]] exported?) - defs)))) - -(def #export (modules state) - (Lux (List Text)) - (|> state - (get@ #;modules) - (list:map t;first) - (#;Right state))) - -(def #export (find-module name state) - (-> Text (Lux (Module Compiler))) - (case (get name (get@ #;modules state)) - (#;Some module) - (#;Right state module) - - _ - (#;Left ($ text:++ "Unknown module: " name)))) - -(def #export (tags-for [module name]) - (-> Ident (Lux (Maybe (List Ident)))) - (do Lux/Monad - [module (find-module module)] - (case (get name (get@ #;types module)) - (#;Some [tags _]) - (wrap (#;Some tags)) - - _ - (wrap #;None)))) diff --git a/source/lux/meta/syntax.lux b/source/lux/meta/syntax.lux deleted file mode 100644 index 641dfba0d..000000000 --- a/source/lux/meta/syntax.lux +++ /dev/null @@ -1,306 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -## If a copy of the MPL was not distributed with this file, -## You can obtain one at http://mozilla.org/MPL/2.0/. - -(;import lux - (.. ast - (lux #as l #refer (#only Lux/Monad gensym))) - (lux (control (functor #as F) - (monad #as M #refer (#only do)) - (eq #as E)) - (data (bool #as b) - (char #as c) - (text #as t #open ("text:" Text/Monoid Text/Eq)) - (list #refer #all #open ("" List/Functor List/Fold)) - (number (int #open ("i" Int/Ord)) - (real #open ("r" Real/Eq)))))) - -## [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')))) - -(def (pair->tuple [left right]) - (-> (, AST AST) AST) - (tuple$ (@list left right))) - -## [Types] -(deftype #export (Parser a) - (-> (List AST) (Maybe (, (List AST) a)))) - -## [Structures] -(defstruct #export Parser/Functor (F;Functor Parser) - (def (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 _functor Parser/Functor) - - (def (wrap x tokens) - (#;Some [tokens x])) - - (def (join mma) - (lambda [tokens] - (case (mma tokens) - #;None - #;None - - (#;Some [tokens' ma]) - (ma tokens'))))) - -## [Parsers] -(def #export (id^ tokens) - (Parser AST) - (case tokens - #;Nil #;None - (#;Cons [t tokens']) (#;Some [tokens' t]))) - -(do-template [<name> <type> <tag>] - [(def #export (<name> tokens) - (Parser <type>) - (case tokens - (#;Cons [[_ (<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] - ) - -(def #export (assert v tokens) - (-> Bool (Parser (,))) - (if v - (#;Some [tokens []]) - #;None)) - -(def #export nat^ - (Parser Int) - (do Parser/Monad - [n int^ - _ (assert (i>= n 0))] - (wrap n))) - -(do-template [<name> <tag>] - [(def #export (<name> tokens) - (Parser Text) - (case tokens - (#;Cons [[_ (<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 Bool)) - (case tokens - (#;Cons [[_ (<tag> x)] tokens']) - (#;Some [tokens' (<eq> v x)]) - - _ - (#;Some [tokens false])))] - - [ bool?^ Bool #;BoolS (:: b;Bool/Eq =)] - [ int?^ Int #;IntS i=] - [ real?^ Real #;RealS r=] - [ char?^ Char #;CharS (:: c;Char/Eq =)] - [ text?^ Text #;TextS (:: t;Text/Eq =)] - [symbol?^ Ident #;SymbolS ident:=] - [ tag?^ Ident #;TagS ident:=] - ) - -(do-template [<name> <type> <tag> <eq>] - [(def #export (<name> v tokens) - (-> <type> (Parser Unit)) - (case tokens - (#;Cons [[_ (<tag> x)] tokens']) - (if (<eq> v x) - (#;Some [tokens' []]) - #;None) - - _ - #;None))] - - [ bool!^ Bool #;BoolS (:: b;Bool/Eq =)] - [ int!^ Int #;IntS i=] - [ real!^ Real #;RealS r=] - [ char!^ Char #;CharS (:: c;Char/Eq =)] - [ text!^ Text #;TextS (:: t;Text/Eq =)] - [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 [[_ (<tag> members)] tokens']) - (case (p members) - (#;Some [#;Nil x]) (#;Some [tokens' x]) - _ #;None) - - _ - #;None))] - - [ form^ #;FormS] - [tuple^ #;TupleS] - ) - -(def #export (record^ p tokens) - (All [a] - (-> (Parser a) (Parser a))) - (case tokens - (#;Cons [[_ (#;RecordS pairs)] tokens']) - (case (p (map pair->tuple pairs)) - (#;Some [#;Nil x]) (#;Some [tokens' x]) - _ #;None) - - _ - #;None)) - -(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 AST) (Maybe (, (List AST) 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)] - (wrap (@list& x xs))) - tokens'))) - -(def #export (+^ p) - (All [a] - (-> (Parser a) (Parser (List a)))) - (do Parser/Monad - [x p - xs (*^ p)] - (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] - (wrap [x1 x2]))) - -(def #export (|^ p1 p2 tokens) - (All [a b] - (-> (Parser a) (Parser b) (Parser (Either a b)))) - (case (p1 tokens) - (#;Some [tokens' x1]) (#;Some [tokens' (#;Left x1)]) - #;None (run-parser (do Parser/Monad - [x2 p2] - (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] (case tokens - (\ (@list& [_ (#;TagS ["" "export"])] tokens')) - [true tokens'] - - _ - [false tokens])] - (case tokens - (\ (@list [_ (#;FormS (@list& [_ (#;SymbolS ["" name])] args))] - body)) - (do Lux/Monad - [vars+parsers (M;map% Lux/Monad - (: (-> AST (Lux (, AST AST))) - (lambda [arg] - (case arg - (\ [_ (#;TupleS (@list var parser))]) - (wrap [var parser]) - - (\ [_ (#;SymbolS var-name)]) - (wrap [(symbol$ var-name) (` id^)]) - - _ - (l;fail "Syntax pattern expects 2-tuples or symbols.")))) - args) - g!tokens (gensym "tokens") - g!_ (gensym "_") - #let [error-msg (text$ (text:++ "Wrong syntax for " name)) - body' (foldL (: (-> AST (, AST AST) AST) - (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 (, AST AST)) (@list& [(symbol$ ["" ""]) (` end^)] (reverse vars+parsers)))) - macro-def (` (defmacro ((~ (symbol$ ["" name])) (~ g!tokens)) - (~ body')))]] - (wrap (@list& macro-def - (if exported? - (@list (` (;_lux_export (~ (symbol$ ["" name]))))) - (@list))))) - - _ - (l;fail "Wrong syntax for defsyntax")))) diff --git a/source/lux/meta/type.lux b/source/lux/meta/type.lux deleted file mode 100644 index 0938d104d..000000000 --- a/source/lux/meta/type.lux +++ /dev/null @@ -1,193 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -## If a copy of the MPL was not distributed with this file, -## You can obtain one at http://mozilla.org/MPL/2.0/. - -(;import lux - (lux (control show - eq - monad) - (data (char #as c) - (text #as t #open ("text:" Text/Monoid Text/Eq)) - (number/int #open ("int:" Int/Number Int/Ord Int/Show)) - maybe - (list #refer #all #open ("list:" List/Monad List/Monoid List/Fold))) - )) - -(open List/Fold) - -## [Utils] -(def (unravel-fun type) - (-> Type (, Type (List Type))) - (case type - (#;LambdaT in out') - (let [[out ins] (unravel-fun out')] - [out (@list& in ins)]) - - _ - [type (@list)])) - -(def (unravel-app type) - (-> Type (, Type (List Type))) - (case type - (#;AppT left' right) - (let [[left rights] (unravel-app left')] - [left (list:++ rights (@list right))]) - - _ - [type (@list)])) - -## [Structures] -(defstruct #export Type/Show (Show Type) - (def (show type) - (case type - (#;DataT name params) - (case params - #;Nil - ($ text:++ "(^ " name ")") - - _ - ($ text:++ "(^ " name " " (|> params (list:map show) (interpose " ") (list:foldL text:++ "")) ")")) - - (#;TupleT members) - (case members - #;Nil - "(,)" - - _ - ($ text:++ "(, " (|> members (list:map show) (interpose " ") (foldL text:++ "")) ")")) - - (#;VariantT members) - (case members - #;Nil - "(|)" - - _ - ($ text:++ "(| " (|> members (list:map show) (interpose " ") (foldL text:++ "")) ")")) - - (#;LambdaT input output) - (let [[out ins] (unravel-fun type)] - ($ text:++ "(-> " (|> ins (list:map show) (interpose " ") (foldL text:++ "")) " " (show out) ")")) - - (#;VarT id) - ($ text:++ "⌈" (int:show id) "⌋") - - (#;BoundT idx) - (int:show idx) - - (#;ExT id) - ($ text:++ "⟨" (int:show id) "⟩") - - (#;AppT fun param) - (let [[type-fun type-args] (unravel-app type)] - ($ text:++ "(" (show type-fun) " " (|> type-args (list:map show) (interpose " ") (foldL text:++ "")) ")")) - - (#;UnivQ env body) - ($ text:++ "(All " (show body) ")") - - (#;ExQ env body) - ($ text:++ "(Ex " (show body) ")") - - (#;NamedT [module name] type) - ($ text:++ module ";" name) - ))) - -(defstruct #export Type/Eq (Eq Type) - (def (= x y) - (case [x y] - [(#;DataT xname xparams) (#;DataT yname yparams)] - (and (text:= xname yname) - (int:= (size xparams) (size yparams)) - (foldL (lambda [prev [x y]] - (and prev (= x y))) - true - (zip2 xparams yparams))) - - (\or [(#;VarT xid) (#;VarT yid)] - [(#;ExT xid) (#;ExT yid)] - [(#;BoundT xid) (#;BoundT yid)]) - (int:= xid yid) - - (\or [(#;LambdaT xleft xright) (#;LambdaT yleft yright)] - [(#;AppT xleft xright) (#;AppT yleft yright)]) - (and (= xleft yleft) - (= xright yright)) - - [(#;NamedT [xmodule xname] xtype) (#;NamedT [ymodule yname] ytype)] - (and (text:= xmodule ymodule) - (text:= xname yname) - (= xtype ytype)) - - (\or [(#;TupleT xmembers) (#;TupleT ymembers)] - [(#;VariantT xmembers) (#;VariantT ymembers)]) - (and (int:= (size xmembers) (size ymembers)) - (foldL (lambda [prev [x y]] - (and prev (= x y))) - true - (zip2 xmembers ymembers))) - - (\or [(#;UnivQ xenv xbody) (#;UnivQ yenv ybody)] - [(#;ExQ xenv xbody) (#;ExQ yenv ybody)]) - (and (int:= (size xenv) (size yenv)) - (foldL (lambda [prev [x y]] - (and prev (= x y))) - (= xbody ybody) - (zip2 xenv yenv))) - - _ - false - ))) - -## [Functions] -(def #export (beta-reduce env type) - (-> (List Type) Type Type) - (case type - (\template [<tag>] - [(<tag> members) - (<tag> (list:map (beta-reduce env) members))]) - [[#;VariantT] - [#;TupleT]] - - (\template [<tag>] - [(<tag> left right) - (<tag> (beta-reduce env left) (beta-reduce env right))]) - [[#;LambdaT] - [#;AppT]] - - (\template [<tag>] - [(<tag> env def) - (case env - #;Nil - (<tag> env def) - - _ - type)]) - [[#;UnivQ] - [#;ExQ]] - - (#;BoundT idx) - (? type (@ idx env)) - - (#;NamedT name type) - (beta-reduce env type) - - _ - type - )) - -(def #export (apply-type type-fun param) - (-> Type Type (Maybe Type)) - (case type-fun - (#;UnivQ env body) - (#;Some (beta-reduce (@list& type-fun param env) body)) - - (#;AppT F A) - (do Maybe/Monad - [type-fn* (apply-type F A)] - (apply-type type-fn* param)) - - (#;NamedT name type) - (apply-type type param) - - _ - #;None)) diff --git a/src/lux.clj b/src/lux.clj index 4b1c15ef7..eb8729053 100644 --- a/src/lux.clj +++ b/src/lux.clj @@ -8,7 +8,6 @@ (:require [lux.base :as & :refer [|let |do return fail return* fail* |case]] [lux.compiler.base :as &compiler-base] [lux.compiler :as &compiler] - [lux.packager.lib :as &lib] :reload-all) (:import (java.io File))) @@ -19,9 +18,6 @@ (time (&compiler/compile-program program-module)) (println "Please provide a module name to compile.")) - (&/$Cons "lib" (&/$Cons lib-module (&/$Nil))) - (&lib/package lib-module (new File &compiler-base/input-dir)) - _ (println "Can't understand command.")) (System/exit 0) @@ -29,5 +25,4 @@ (comment (-main "compile" "program") - (-main "lib" "lux") ) diff --git a/src/lux/lib/loader.clj b/src/lux/lib/loader.clj index 13810238a..e70576c24 100644 --- a/src/lux/lib/loader.clj +++ b/src/lux/lib/loader.clj @@ -11,9 +11,7 @@ FileInputStream ByteArrayInputStream ByteArrayOutputStream) - java.util.zip.GZIPInputStream - (org.apache.commons.compress.archivers.tar TarArchiveEntry - TarArchiveInputStream))) + java.util.jar.JarInputStream)) ;; [Utils] (defn ^:private fetch-libs [] @@ -21,7 +19,7 @@ (.getURLs) seq (map #(.getFile ^java.net.URL %)) - (filter #(.endsWith ^String % ".tar.gz")) + (filter #(.endsWith ^String % ".jar")) (map #(new File ^String %)))) (let [init-capacity (* 100 1024) @@ -38,23 +36,19 @@ (defn ^:private unpackage [^File lib-file] (let [is (->> lib-file (new FileInputStream) - (new GZIPInputStream) - (new TarArchiveInputStream))] + (new JarInputStream))] (loop [lib-data {} - entry (.getNextTarEntry is)] + entry (.getNextJarEntry is)] (if entry - (recur (assoc lib-data (.getName entry) (new String (read-stream is))) - (.getNextTarEntry is)) + (if (.endsWith (.getName entry) ".lux") + (recur (assoc lib-data (.substring (.getName entry) 1) (new String (read-stream is))) + (.getNextJarEntry is)) + (recur lib-data + (.getNextJarEntry is))) lib-data)))) ;; [Exports] -(def lib-ext ".tar.gz") - (defn load [] (->> (fetch-libs) (map unpackage) (reduce merge {}))) - -(comment - (->> &/lib-dir load keys) - ) diff --git a/src/lux/packager/lib.clj b/src/lux/packager/lib.clj deleted file mode 100644 index af48e31eb..000000000 --- a/src/lux/packager/lib.clj +++ /dev/null @@ -1,41 +0,0 @@ -;; Copyright (c) Eduardo Julian. All rights reserved. -;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -;; If a copy of the MPL was not distributed with this file, -;; You can obtain one at http://mozilla.org/MPL/2.0/. - -(ns lux.packager.lib - (:require [lux.lib.loader :as &lib]) - (:import (java.io File - FileOutputStream) - java.util.zip.GZIPOutputStream - (org.apache.commons.compress.archivers.tar TarArchiveEntry - TarArchiveOutputStream) - )) - -;; [Utils] -(defn ^:private read-file ^objects [^File file] - (with-open [is (java.io.FileInputStream. file)] - (let [data (byte-array (.length file))] - (.read is data) - data))) - -(defn ^:private add-to-tar! [prefix ^File file ^TarArchiveOutputStream os] - "(-> Text File TarArchiveOutputStream Unit)" - (let [file-name (str prefix "/" (.getName file))] - (if (.isDirectory file) - (doseq [file (seq (.listFiles file))] - (add-to-tar! file-name file os)) - (let [data (read-file file)] - (doto os - (.putArchiveEntry (doto (new TarArchiveEntry file-name) - (.setSize (.length file)))) - (.write data 0 (alength data)) - (.closeArchiveEntry)))))) - -;; [Exports] -(defn package [output-lib-name ^File source-dir] - "(-> Text File Unit)" - (with-open [out (->> (str output-lib-name &lib/lib-ext) (new FileOutputStream) (new GZIPOutputStream) (new TarArchiveOutputStream))] - (doseq [file (seq (.listFiles source-dir))] - (add-to-tar! "" file out)) - )) diff --git a/src/lux/packager/program.clj b/src/lux/packager/program.clj index 83927ba0d..0ff06a453 100644 --- a/src/lux/packager/program.clj +++ b/src/lux/packager/program.clj @@ -74,19 +74,29 @@ (recur (.read is buffer 0 buffer-size))))) (.toByteArray os))))) -(defn ^:private add-jar! [^File jar-file ^JarOutputStream out] +(defn ^:private add-jar! [^File jar-file seen ^JarOutputStream out] (with-open [is (->> jar-file (new FileInputStream) (new JarInputStream))] - (loop [^JarEntry entry (.getNextJarEntry is)] - (when entry - (when (and (not (.isDirectory entry)) - (not (.startsWith (.getName entry) "META-INF/"))) - (let [entry-data (read-stream is)] - (doto out - (.putNextEntry entry) - (.write entry-data 0 (alength entry-data)) - (.flush) - (.closeEntry)))) - (recur (.getNextJarEntry is)))))) + (loop [^JarEntry entry (.getNextJarEntry is) + seen seen] + (if entry + (let [entry-name (.getName entry)] + (if (and (not (.isDirectory entry)) + (not (.startsWith entry-name "META-INF/")) + (.endsWith entry-name ".class") + (not (contains? seen entry-name))) + (let [;; _ (prn 'entry entry-name) + entry-data (read-stream is)] + (doto out + (.putNextEntry entry) + (.write entry-data 0 (alength entry-data)) + (.flush) + (.closeEntry)) + (recur (.getNextJarEntry is) + (conj seen entry-name))) + (recur (.getNextJarEntry is) + seen))) + seen + )))) ;; [Resources] (defn package [module] @@ -94,6 +104,10 @@ (with-open [out (new JarOutputStream (->> &&/output-package (new File) (new FileOutputStream)) (manifest module))] (doseq [$group (.listFiles (new File &&/output-dir))] (write-module! $group out)) - (doseq [^String jar-file (fetch-available-jars)] - (add-jar! (new File jar-file) out)) + (->> (fetch-available-jars) + (filter #(and (not (.endsWith % "luxc.jar")) + (not (.endsWith % "tools.nrepl-0.2.3.jar")) + (not (.endsWith % "clojure-complete-0.2.3.jar")))) + (reduce (fn [s ^String j] (add-jar! (new File ^String j) s out)) + #{})) )) |