aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--project.clj3
-rw-r--r--source/lux.lux3303
-rw-r--r--source/lux/codata/function.lux27
-rw-r--r--source/lux/codata/io.lux42
-rw-r--r--source/lux/codata/lazy.lux56
-rw-r--r--source/lux/codata/reader.lux30
-rw-r--r--source/lux/codata/state.lux39
-rw-r--r--source/lux/codata/stream.lux140
-rw-r--r--source/lux/control/bounded.lux14
-rw-r--r--source/lux/control/comonad.lux52
-rw-r--r--source/lux/control/enum.lux25
-rw-r--r--source/lux/control/eq.lux11
-rw-r--r--source/lux/control/fold.lux42
-rw-r--r--source/lux/control/functor.lux12
-rw-r--r--source/lux/control/hash.lux11
-rw-r--r--source/lux/control/monad.lux107
-rw-r--r--source/lux/control/monoid.lux21
-rw-r--r--source/lux/control/number.lux25
-rw-r--r--source/lux/control/ord.lux41
-rw-r--r--source/lux/control/show.lux11
-rw-r--r--source/lux/data/bool.lux36
-rw-r--r--source/lux/data/char.lux22
-rw-r--r--source/lux/data/either.lux63
-rw-r--r--source/lux/data/id.lux27
-rw-r--r--source/lux/data/ident.lux33
-rw-r--r--source/lux/data/list.lux344
-rw-r--r--source/lux/data/maybe.lux46
-rw-r--r--source/lux/data/number/int.lux93
-rw-r--r--source/lux/data/number/real.lux93
-rw-r--r--source/lux/data/text.lux195
-rw-r--r--source/lux/data/tuple.lux35
-rw-r--r--source/lux/data/writer.lux31
-rw-r--r--source/lux/host/io.lux60
-rw-r--r--source/lux/host/jvm.lux377
-rw-r--r--source/lux/math.lux80
-rw-r--r--source/lux/meta/ast.lux113
-rw-r--r--source/lux/meta/lux.lux366
-rw-r--r--source/lux/meta/syntax.lux306
-rw-r--r--source/lux/meta/type.lux193
-rw-r--r--src/lux.clj5
-rw-r--r--src/lux/lib/loader.clj24
-rw-r--r--src/lux/packager/lib.clj41
-rw-r--r--src/lux/packager/program.clj42
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))
+ #{}))
))