aboutsummaryrefslogtreecommitdiff
path: root/source/lux.lux
diff options
context:
space:
mode:
authorEduardo Julian2015-06-20 20:19:02 -0400
committerEduardo Julian2015-06-20 20:19:02 -0400
commit5e9e876131901204dd34ce1548a4df3cb6cba95f (patch)
tree82bb0f7f20fe13f91f15656ed61f28e585b19ced /source/lux.lux
parent082ef348efef7c4f1941c48f94b58e22fea724a4 (diff)
- The directory for source-code is now named "input".
- Implemented module-caching to avoid the waiting too much during program compilation.
Diffstat (limited to 'source/lux.lux')
-rw-r--r--source/lux.lux2169
1 files changed, 0 insertions, 2169 deletions
diff --git a/source/lux.lux b/source/lux.lux
deleted file mode 100644
index 07b245a5d..000000000
--- a/source/lux.lux
+++ /dev/null
@@ -1,2169 +0,0 @@
-## Copyright (c) Eduardo Julian. All rights reserved.
-## The use and distribution terms for this software are covered by the
-## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
-## which can be found in the file epl-v10.html at the root of this distribution.
-## By using this software in any fashion, you are agreeing to be bound by
-## the terms of this license.
-## You must not remove this notice, or any other, from this software.
-
-## First things first, must define functions
-(_jvm_interface "lux.Function" []
- (apply ["java.lang.Object"] "java.lang.Object" ["public" "abstract"]))
-
-## (_jvm_class "lux.MyFunction" "java.lang.Object" ["lux.Function"]
-## [(foo "java.lang.Object" ["public" "static"])]
-## (<init> [] "void"
-## ["public"]
-## (_jvm_invokespecial java.lang.Object <init> [] this []))
-## (apply [(arg "java.lang.Object")] "java.lang.Object"
-## ["public"]
-## "YOLO"))
-
-## Basic types
-(_lux_def Bool (#DataT "java.lang.Boolean"))
-(_lux_export Bool)
-
-(_lux_def Int (#DataT "java.lang.Long"))
-(_lux_export Int)
-
-(_lux_def Real (#DataT "java.lang.Double"))
-(_lux_export Real)
-
-(_lux_def Char (#DataT "java.lang.Character"))
-(_lux_export Char)
-
-(_lux_def Text (#DataT "java.lang.String"))
-(_lux_export Text)
-
-(_lux_def Void (#VariantT #Nil))
-(_lux_export Void)
-
-(_lux_def Ident (#TupleT (#Cons [Text (#Cons [Text #Nil])])))
-(_lux_export Ident)
-
-## (deftype (List a)
-## (| #Nil
-## (#Cons (, a (List a)))))
-(_lux_def List
- (#AllT [(#Some #Nil) "lux;List" "a"
- (#VariantT (#Cons [["lux;Nil" (#TupleT #Nil)]
- (#Cons [["lux;Cons" (#TupleT (#Cons [(#BoundT "a")
- (#Cons [(#AppT [(#BoundT "lux;List") (#BoundT "a")])
- #Nil])]))]
- #Nil])]))]))
-(_lux_export List)
-
-## (deftype (Maybe a)
-## (| #None
-## (#Some a)))
-(_lux_def Maybe
- (#AllT [(#Some #Nil) "lux;Maybe" "a"
- (#VariantT (#Cons [["lux;None" (#TupleT #Nil)]
- (#Cons [["lux;Some" (#BoundT "a")]
- #Nil])]))]))
-(_lux_export Maybe)
-
-## (deftype #rec Type
-## (| (#DataT Text)
-## (#TupleT (List Type))
-## (#VariantT (List (, Text Type)))
-## (#RecordT (List (, Text Type)))
-## (#LambdaT (, Type Type))
-## (#BoundT Text)
-## (#VarT Int)
-## (#AllT (, (Maybe (List (, Text Type))) Text Text Type))
-## (#AppT (, Type Type))))
-(_lux_def Type
- (_lux_case (#AppT [(#BoundT "Type") (#BoundT "_")])
- Type
- (_lux_case (#AppT [List (#TupleT (#Cons [Text (#Cons [Type #Nil])]))])
- TypeEnv
- (#AppT [(#AllT [(#Some #Nil) "Type" "_"
- (#VariantT (#Cons [["lux;DataT" Text]
- (#Cons [["lux;TupleT" (#AppT [List Type])]
- (#Cons [["lux;VariantT" TypeEnv]
- (#Cons [["lux;RecordT" TypeEnv]
- (#Cons [["lux;LambdaT" (#TupleT (#Cons [Type (#Cons [Type #Nil])]))]
- (#Cons [["lux;BoundT" Text]
- (#Cons [["lux;VarT" Int]
- (#Cons [["lux;AllT" (#TupleT (#Cons [(#AppT [Maybe TypeEnv]) (#Cons [Text (#Cons [Text (#Cons [Type #Nil])])])]))]
- (#Cons [["lux;AppT" (#TupleT (#Cons [Type (#Cons [Type #Nil])]))]
- (#Cons [["lux;ExT" Int]
- #Nil])])])])])])])])])]))])
- Void]))))
-(_lux_export Type)
-
-## (deftype (Bindings k v)
-## (& #counter Int
-## #mappings (List (, k v))))
-(_lux_def Bindings
- (#AllT [(#Some #Nil) "lux;Bindings" "k"
- (#AllT [#None "" "v"
- (#RecordT (#Cons [["lux;counter" Int]
- (#Cons [["lux;mappings" (#AppT [List
- (#TupleT (#Cons [(#BoundT "k")
- (#Cons [(#BoundT "v")
- #Nil])]))])]
- #Nil])]))])]))
-
-## (deftype (Env k v)
-## (& #name Text
-## #inner-closures Int
-## #locals (Bindings k v)
-## #closure (Bindings k v)))
-(_lux_def Env
- (#AllT [(#Some #Nil) "lux;Env" "k"
- (#AllT [#None "" "v"
- (#RecordT (#Cons [["lux;name" Text]
- (#Cons [["lux;inner-closures" Int]
- (#Cons [["lux;locals" (#AppT [(#AppT [Bindings (#BoundT "k")])
- (#BoundT "v")])]
- (#Cons [["lux;closure" (#AppT [(#AppT [Bindings (#BoundT "k")])
- (#BoundT "v")])]
- #Nil])])])]))])]))
-
-## (deftype Cursor
-## (, Text Int Int))
-(_lux_def Cursor
- (#TupleT (#Cons [Text (#Cons [Int (#Cons [Int #Nil])])])))
-
-## (deftype (Meta m v)
-## (| (#Meta (, m v))))
-(_lux_def Meta
- (#AllT [(#Some #Nil) "lux;Meta" "m"
- (#AllT [#None "" "v"
- (#VariantT (#Cons [["lux;Meta" (#TupleT (#Cons [(#BoundT "m")
- (#Cons [(#BoundT "v")
- #Nil])]))]
- #Nil]))])]))
-(_lux_export Meta)
-
-## (deftype (Syntax' w)
-## (| (#BoolS Bool)
-## (#IntS Int)
-## (#RealS Real)
-## (#CharS Char)
-## (#TextS Text)
-## (#SymbolS (, Text Text))
-## (#TagS (, Text Text))
-## (#FormS (List (w (Syntax' w))))
-## (#TupleS (List (w (Syntax' w))))
-## (#RecordS (List (, (w (Syntax' w)) (w (Syntax' w)))))))
-(_lux_def Syntax'
- (_lux_case (#AppT [(#BoundT "w")
- (#AppT [(#BoundT "lux;Syntax'")
- (#BoundT "w")])])
- Syntax
- (_lux_case (#AppT [List Syntax])
- SyntaxList
- (#AllT [(#Some #Nil) "lux;Syntax'" "w"
- (#VariantT (#Cons [["lux;BoolS" Bool]
- (#Cons [["lux;IntS" Int]
- (#Cons [["lux;RealS" Real]
- (#Cons [["lux;CharS" Char]
- (#Cons [["lux;TextS" Text]
- (#Cons [["lux;SymbolS" Ident]
- (#Cons [["lux;TagS" Ident]
- (#Cons [["lux;FormS" SyntaxList]
- (#Cons [["lux;TupleS" SyntaxList]
- (#Cons [["lux;RecordS" (#AppT [List (#TupleT (#Cons [Syntax (#Cons [Syntax #Nil])]))])]
- #Nil])
- ])])])])])])])])])
- )]))))
-(_lux_export Syntax')
-
-## (deftype Syntax
-## (Meta Cursor (Syntax' (Meta Cursor))))
-(_lux_def Syntax
- (_lux_case (#AppT [Meta Cursor])
- w
- (#AppT [w (#AppT [Syntax' w])])))
-(_lux_export Syntax)
-
-(_lux_def SyntaxList (#AppT [List Syntax]))
-
-## (deftype (Either l r)
-## (| (#Left l)
-## (#Right r)))
-(_lux_def Either
- (#AllT [(#Some #Nil) "lux;Either" "l"
- (#AllT [#None "" "r"
- (#VariantT (#Cons [["lux;Left" (#BoundT "l")]
- (#Cons [["lux;Right" (#BoundT "r")]
- #Nil])]))])]))
-(_lux_export Either)
-
-## (deftype (StateE s a)
-## (-> s (Either Text (, s a))))
-(_lux_def StateE
- (#AllT [(#Some #Nil) "lux;StateE" "s"
- (#AllT [#None "" "a"
- (#LambdaT [(#BoundT "s")
- (#AppT [(#AppT [Either Text])
- (#TupleT (#Cons [(#BoundT "s")
- (#Cons [(#BoundT "a")
- #Nil])]))])])])]))
-
-## (deftype Reader
-## (List (Meta Cursor Text)))
-(_lux_def Reader
- (#AppT [List
- (#AppT [(#AppT [Meta Cursor])
- Text])]))
-(_lux_export Reader)
-
-## (deftype HostState
-## (& #writer (^ org.objectweb.asm.ClassWriter)
-## #loader (^ java.net.URLClassLoader)
-## #classes (^ clojure.lang.Atom)))
-(_lux_def HostState
- (#RecordT (#Cons [["lux;writer" (#DataT "org.objectweb.asm.ClassWriter")]
- (#Cons [["lux;loader" (#DataT "java.lang.ClassLoader")]
- (#Cons [["lux;classes" (#DataT "clojure.lang.Atom")]
- #Nil])])])))
-
-## (deftype (DefData' m)
-## (| #TypeD
-## (#ValueD Type)
-## (#MacroD m)
-## (#AliasD Ident)))
-(_lux_def DefData'
- (#AllT [(#Some #Nil) "lux;DefData'" ""
- (#VariantT (#Cons [["lux;TypeD" (#TupleT #Nil)]
- (#Cons [["lux;ValueD" Type]
- (#Cons [["lux;MacroD" (#BoundT "")]
- (#Cons [["lux;AliasD" Ident]
- #Nil])])])]))]))
-
-## (deftype LuxVar
-## (| (#Local Int)
-## (#Global Ident)))
-(_lux_def LuxVar
- (#VariantT (#Cons [["lux;Local" Int]
- (#Cons [["lux;Global" Ident]
- #Nil])])))
-(_lux_export LuxVar)
-
-## (deftype (Module Compiler)
-## (& #module-aliases (List (, Text Text))
-## #defs (List (, Text (, Bool (DefData' (-> (List Syntax) (StateE Compiler (List Syntax)))))))
-## #imports (List Text)
-## ))
-(_lux_def Module
- (#AllT [(#Some #Nil) "lux;Module" "Compiler"
- (#RecordT (#Cons [["lux;module-aliases" (#AppT [List (#TupleT (#Cons [Text (#Cons [Text #Nil])]))])]
- (#Cons [["lux;defs" (#AppT [List (#TupleT (#Cons [Text
- (#Cons [(#TupleT (#Cons [Bool (#Cons [(#AppT [DefData' (#LambdaT [SyntaxList
- (#AppT [(#AppT [StateE (#BoundT "Compiler")])
- SyntaxList])])])
- #Nil])]))
- #Nil])]))])]
- (#Cons [["lux;imports" (#AppT [List Text])]
- #Nil])])]))]))
-(_lux_export Module)
-
-## (deftype #rec Compiler
-## (& #source Reader
-## #modules (List (, Text (Module Compiler)))
-## #envs (List (Env Text (, LuxVar Type)))
-## #types (Bindings Int Type)
-## #host HostState
-## #seed Int
-## #seen-sources (List Text)))
-(_lux_def Compiler
- (#AppT [(#AllT [(#Some #Nil) "lux;Compiler" ""
- (#RecordT (#Cons [["lux;source" Reader]
- (#Cons [["lux;modules" (#AppT [List (#TupleT (#Cons [Text
- (#Cons [(#AppT [Module (#AppT [(#BoundT "lux;Compiler") (#BoundT "")])])
- #Nil])]))])]
- (#Cons [["lux;envs" (#AppT [List (#AppT [(#AppT [Env Text])
- (#TupleT (#Cons [LuxVar (#Cons [Type #Nil])]))])])]
- (#Cons [["lux;types" (#AppT [(#AppT [Bindings Int]) Type])]
- (#Cons [["lux;host" HostState]
- (#Cons [["lux;seed" Int]
- (#Cons [["lux;seen-sources" (#AppT [List Text])]
- #Nil])])])])])])]))])
- Void]))
-(_lux_export Compiler)
-
-## (deftype Macro
-## (-> (List Syntax) (StateE Compiler (List Syntax))))
-(_lux_def Macro
- (#LambdaT [SyntaxList
- (#AppT [(#AppT [StateE Compiler])
- SyntaxList])]))
-(_lux_export Macro)
-
-## Base functions & macros
-## (def (_meta data)
-## (-> (Syntax' (Meta Cursor)) Syntax)
-## (#Meta [["" -1 -1] data]))
-(_lux_def _meta
- (_lux_: (#LambdaT [(#AppT [Syntax'
- (#AppT [Meta Cursor])])
- Syntax])
- (_lux_lambda _ data
- (#Meta [["" -1 -1] data]))))
-
-## (def (return x)
-## (All [a]
-## (-> a Compiler
-## (Either Text (, Compiler a))))
-## ...)
-(_lux_def return
- (_lux_: (#AllT [(#Some #Nil) "" "a"
- (#LambdaT [(#BoundT "a")
- (#LambdaT [Compiler
- (#AppT [(#AppT [Either Text])
- (#TupleT (#Cons [Compiler
- (#Cons [(#BoundT "a")
- #Nil])]))])])])])
- (_lux_lambda _ val
- (_lux_lambda _ state
- (#Right [state val])))))
-
-## (def (fail msg)
-## (All [a]
-## (-> Text Compiler
-## (Either Text (, Compiler a))))
-## ...)
-(_lux_def fail
- (_lux_: (#AllT [(#Some #Nil) "" "a"
- (#LambdaT [Text
- (#LambdaT [Compiler
- (#AppT [(#AppT [Either Text])
- (#TupleT (#Cons [Compiler
- (#Cons [(#BoundT "a")
- #Nil])]))])])])])
- (_lux_lambda _ msg
- (_lux_lambda _ state
- (#Left msg)))))
-
-(_lux_def $text
- (_lux_: (#LambdaT [Text Syntax])
- (_lux_lambda _ text
- (_meta (#TextS text)))))
-
-(_lux_def $symbol
- (_lux_: (#LambdaT [Ident Syntax])
- (_lux_lambda _ ident
- (_meta (#SymbolS ident)))))
-
-(_lux_def $tag
- (_lux_: (#LambdaT [Ident Syntax])
- (_lux_lambda _ ident
- (_meta (#TagS ident)))))
-
-(_lux_def $form
- (_lux_: (#LambdaT [(#AppT [List Syntax]) Syntax])
- (_lux_lambda _ tokens
- (_meta (#FormS tokens)))))
-
-(_lux_def $tuple
- (_lux_: (#LambdaT [(#AppT [List Syntax]) Syntax])
- (_lux_lambda _ tokens
- (_meta (#TupleS tokens)))))
-
-(_lux_def $record
- (_lux_: (#LambdaT [(#AppT [List (#TupleT (#Cons [Syntax (#Cons [Syntax #Nil])]))]) Syntax])
- (_lux_lambda _ tokens
- (_meta (#RecordS tokens)))))
-
-(_lux_def let'
- (_lux_: Macro
- (_lux_lambda _ tokens
- (_lux_case tokens
- (#Cons [lhs (#Cons [rhs (#Cons [body #Nil])])])
- (return (_lux_: SyntaxList
- (#Cons [($form (#Cons [($symbol ["" "_lux_case"])
- (#Cons [rhs (#Cons [lhs (#Cons [body #Nil])])])]))
- #Nil])))
-
- _
- (fail "Wrong syntax for let'")))))
-(_lux_declare-macro let')
-
-(_lux_def lambda'
- (_lux_: Macro
- (_lux_lambda _ tokens
- (_lux_case tokens
- (#Cons [(#Meta [_ (#TupleS (#Cons [arg args']))]) (#Cons [body #Nil])])
- (return (_lux_: SyntaxList
- (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_lambda"]))
- (#Cons [(_meta (#SymbolS ["" ""]))
- (#Cons [arg
- (#Cons [(_lux_case args'
- #Nil
- body
-
- _
- (_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "lambda'"]))
- (#Cons [(_meta (#TupleS args'))
- (#Cons [body #Nil])])]))))
- #Nil])])])])))
- #Nil])))
-
- (#Cons [(#Meta [_ (#SymbolS self)]) (#Cons [(#Meta [_ (#TupleS (#Cons [arg args']))]) (#Cons [body #Nil])])])
- (return (_lux_: SyntaxList
- (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_lambda"]))
- (#Cons [(_meta (#SymbolS self))
- (#Cons [arg
- (#Cons [(_lux_case args'
- #Nil
- body
-
- _
- (_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "lambda'"]))
- (#Cons [(_meta (#TupleS args'))
- (#Cons [body #Nil])])]))))
- #Nil])])])])))
- #Nil])))
-
- _
- (fail "Wrong syntax for lambda")))))
-(_lux_declare-macro lambda')
-
-(_lux_def def'
- (_lux_: Macro
- (lambda' [tokens]
- (_lux_case tokens
- (#Cons [(#Meta [_ (#TagS ["" "export"])])
- (#Cons [(#Meta [_ (#FormS (#Cons [name args]))])
- (#Cons [type (#Cons [body #Nil])])])])
- (return (_lux_: SyntaxList
- (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_def"]))
- (#Cons [name
- (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_:"]))
- (#Cons [type
- (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "lambda'"]))
- (#Cons [name
- (#Cons [(_meta (#TupleS args))
- (#Cons [body #Nil])])])])))
- #Nil])])])))
- #Nil])])])))
- (#Cons [(_meta (#FormS (#Cons [($symbol ["" "_lux_export"]) (#Cons [name #Nil])])))
- #Nil])])))
-
- (#Cons [(#Meta [_ (#TagS ["" "export"])]) (#Cons [name (#Cons [type (#Cons [body #Nil])])])])
- (return (_lux_: SyntaxList
- (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_def"]))
- (#Cons [name
- (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_:"]))
- (#Cons [type
- (#Cons [body
- #Nil])])])))
- #Nil])])])))
- (#Cons [(_meta (#FormS (#Cons [($symbol ["" "_lux_export"]) (#Cons [name #Nil])])))
- #Nil])])))
-
- (#Cons [(#Meta [_ (#FormS (#Cons [name args]))])
- (#Cons [type (#Cons [body #Nil])])])
- (return (_lux_: SyntaxList
- (#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 (_lux_: SyntaxList
- (#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' #export (defmacro tokens)
- Macro
- (_lux_case tokens
- (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) (#Cons [body #Nil])])
- (return (_lux_: SyntaxList
- (#Cons [($form (#Cons [($symbol ["lux" "def'"])
- (#Cons [($form (#Cons [name args]))
- (#Cons [($symbol ["lux" "Macro"])
- (#Cons [body
- #Nil])])
- ])]))
- (#Cons [($form (#Cons [($symbol ["" "_lux_declare-macro"]) (#Cons [name #Nil])]))
- #Nil])])))
-
- (#Cons [(#Meta [_ (#TagS ["" "export"])]) (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) (#Cons [body #Nil])])])
- (return (_lux_: SyntaxList
- (#Cons [($form (#Cons [($symbol ["lux" "def'"])
- (#Cons [($tag ["" "export"])
- (#Cons [($form (#Cons [name args]))
- (#Cons [($symbol ["lux" "Macro"])
- (#Cons [body
- #Nil])])
- ])])]))
- (#Cons [($form (#Cons [($symbol ["" "_lux_declare-macro"]) (#Cons [name #Nil])]))
- #Nil])])))
-
- _
- (fail "Wrong syntax for defmacro")))
-(_lux_declare-macro defmacro)
-
-(defmacro #export (comment tokens)
- (return (_lux_: SyntaxList #Nil)))
-
-(defmacro (->' tokens)
- (_lux_case tokens
- (#Cons [input (#Cons [output #Nil])])
- (return (_lux_: SyntaxList
- (#Cons [(_meta (#FormS (#Cons [(_meta (#TagS ["lux" "LambdaT"]))
- (#Cons [(_meta (#TupleS (#Cons [input (#Cons [output #Nil])])))
- #Nil])])))
- #Nil])))
-
- (#Cons [input (#Cons [output others])])
- (return (_lux_: SyntaxList
- (#Cons [(_meta (#FormS (#Cons [(_meta (#TagS ["lux" "LambdaT"]))
- (#Cons [(_meta (#TupleS (#Cons [input
- (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "->'"]))
- (#Cons [output others])])))
- #Nil])])))
- #Nil])])))
- #Nil])))
-
- _
- (fail "Wrong syntax for ->'")))
-
-(defmacro (All' tokens)
- (_lux_case tokens
- (#Cons [(#Meta [_ (#TupleS #Nil)])
- (#Cons [body #Nil])])
- (return (_lux_: SyntaxList
- (#Cons [body
- #Nil])))
-
- (#Cons [(#Meta [_ (#TupleS (#Cons [(#Meta [_ (#SymbolS ["" arg-name])]) other-args]))])
- (#Cons [body #Nil])])
- (return (_lux_: SyntaxList
- (#Cons [(_meta (#FormS (#Cons [(_meta (#TagS ["lux" "AllT"]))
- (#Cons [(_meta (#TupleS (#Cons [(_meta (#TagS ["lux" "None"]))
- (#Cons [(_meta (#TextS ""))
- (#Cons [(_meta (#TextS arg-name))
- (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "All'"]))
- (#Cons [(_meta (#TupleS other-args))
- (#Cons [body
- #Nil])])])))
- #Nil])])])])))
- #Nil])])))
- #Nil])))
-
- _
- (fail "Wrong syntax for All'")))
-
-(defmacro (B' tokens)
- (_lux_case tokens
- (#Cons [(#Meta [_ (#SymbolS ["" bound-name])])
- #Nil])
- (return (_lux_: SyntaxList
- (#Cons [(_meta (#FormS (#Cons [(_meta (#TagS ["lux" "BoundT"]))
- (#Cons [(_meta (#TextS bound-name))
- #Nil])])))
- #Nil])))
-
- _
- (fail "Wrong syntax for B'")))
-
-(defmacro ($' tokens)
- (_lux_case tokens
- (#Cons [x #Nil])
- (return tokens)
-
- (#Cons [x (#Cons [y xs])])
- (return (_lux_: SyntaxList
- (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "$'"]))
- (#Cons [(_meta (#FormS (#Cons [(_meta (#TagS ["lux" "AppT"]))
- (#Cons [(_meta (#TupleS (#Cons [x (#Cons [y #Nil])])))
- #Nil])])))
- xs])])))
- #Nil])))
-
- _
- (fail "Wrong syntax for $'")))
-
-(def' #export (foldL f init xs)
- (All' [a b]
- (->' (->' (B' a) (B' b) (B' a))
- (B' a)
- ($' List (B' b))
- (B' a)))
- (_lux_case xs
- #Nil
- init
-
- (#Cons [x xs'])
- (foldL f (f init x) xs')))
-
-(def' #export (foldR f init xs)
- (All' [a b]
- (->' (->' (B' b) (B' a) (B' a))
- (B' a)
- ($' List (B' b))
- (B' a)))
- (_lux_case xs
- #Nil
- init
-
- (#Cons [x xs'])
- (f x (foldR f init xs'))))
-
-(def' #export (reverse list)
- (All' [a]
- (->' ($' List (B' a)) ($' List (B' a))))
- (foldL (_lux_: (All' [a]
- (->' ($' List (B' a)) (B' a) ($' List (B' a))))
- (lambda' [tail head]
- (#Cons [head tail])))
- #Nil
- list))
-
-(defmacro #export (list xs)
- (return (_lux_: SyntaxList
- (#Cons [(foldL (lambda' [tail head]
- (_meta (#FormS (#Cons [(_meta (#TagS ["lux" "Cons"]))
- (#Cons [(_meta (#TupleS (#Cons [head (#Cons [tail #Nil])])))
- #Nil])]))))
- (_meta (#TagS ["lux" "Nil"]))
- (reverse xs))
- #Nil]))))
-
-(defmacro #export (list& xs)
- (_lux_case (reverse xs)
- (#Cons [last init])
- (return (_lux_: SyntaxList
- (list (foldL (lambda' [tail head]
- (_meta (#FormS (list (_meta (#TagS ["lux" "Cons"]))
- (_meta (#TupleS (list head tail)))))))
- last
- init))))
-
- _
- (fail "Wrong syntax for list&")))
-
-(defmacro #export (lambda tokens)
- (let' [name tokens'] (_lux_: (#TupleT (list Ident ($' List Syntax)))
- (_lux_case tokens
- (#Cons [(#Meta [_ (#SymbolS name)]) tokens'])
- [name tokens']
-
- _
- [["" ""] tokens]))
- (_lux_case tokens'
- (#Cons [(#Meta [_ (#TupleS args)]) (#Cons [body #Nil])])
- (_lux_case args
- #Nil
- (fail "lambda requires a non-empty arguments tuple.")
-
- (#Cons [harg targs])
- (return (_lux_: SyntaxList
- (list ($form (list ($symbol ["" "_lux_lambda"])
- ($symbol name)
- harg
- (foldL (lambda' [body' arg]
- ($form (list ($symbol ["" "_lux_lambda"])
- ($symbol ["" ""])
- arg
- body')))
- body
- (reverse targs))))))))
-
- _
- (fail "Wrong syntax for lambda"))))
-
-(defmacro (def'' tokens)
- (_lux_case tokens
- (#Cons [(#Meta [_ (#TagS ["" "export"])])
- (#Cons [(#Meta [_ (#FormS (#Cons [name args]))])
- (#Cons [type (#Cons [body #Nil])])])])
- (return (_lux_: SyntaxList
- (list ($form (list ($symbol ["" "_lux_def"])
- name
- ($form (list ($symbol ["" "_lux_:"])
- type
- ($form (list ($symbol ["lux" "lambda"])
- name
- ($tuple args)
- body))))))
- ($form (list ($symbol ["" "_lux_export"]) name)))))
-
- (#Cons [(#Meta [_ (#TagS ["" "export"])]) (#Cons [name (#Cons [type (#Cons [body #Nil])])])])
- (return (_lux_: SyntaxList
- (list ($form (list ($symbol ["" "_lux_def"])
- name
- ($form (list ($symbol ["" "_lux_:"])
- type
- body))))
- ($form (list ($symbol ["" "_lux_export"]) name)))))
-
- (#Cons [(#Meta [_ (#FormS (#Cons [name args]))])
- (#Cons [type (#Cons [body #Nil])])])
- (return (_lux_: SyntaxList
- (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 (_lux_: SyntaxList
- (list ($form (list ($symbol ["" "_lux_def"])
- name
- ($form (list ($symbol ["" "_lux_:"]) type body)))))))
-
- _
- (fail "Wrong syntax for def")
- ))
-
-(def'' (as-pairs xs)
- (All' [a]
- (->' ($' List (B' a)) ($' List (#TupleT (list (B' a) (B' a))))))
- (_lux_case xs
- (#Cons [x (#Cons [y xs'])])
- (#Cons [[x y] (as-pairs xs')])
-
- _
- #Nil))
-
-(defmacro #export (let tokens)
- (_lux_case tokens
- (#Cons [(#Meta [_ (#TupleS bindings)]) (#Cons [body #Nil])])
- (return (_lux_: SyntaxList
- (list (foldL (_lux_: (->' Syntax (#TupleT (list Syntax Syntax))
- Syntax)
- (lambda [body binding]
- (_lux_case binding
- [label value]
- (_meta (#FormS (list (_meta (#SymbolS ["lux" "let'"])) label value body))))))
- body
- (foldL (_lux_: (All' [a]
- (->' ($' List (B' a)) (B' a) ($' List (B' a))))
- (lambda [tail head] (#Cons [head tail])))
- #Nil
- (as-pairs bindings))))))
-
- _
- (fail "Wrong syntax for let")))
-
-(def'' #export (map f xs)
- (All' [a b]
- (->' (->' (B' a) (B' b)) ($' List (B' a)) ($' List (B' b))))
- (_lux_case xs
- #Nil
- #Nil
-
- (#Cons [x xs'])
- (#Cons [(f x) (map f xs')])))
-
-(def'' #export (any? p xs)
- (All' [a]
- (->' (->' (B' a) Bool) ($' List (B' a)) Bool))
- (_lux_case xs
- #Nil
- false
-
- (#Cons [x xs'])
- (_lux_case (p x)
- true true
- false (any? p xs'))))
-
-(def'' (spliced? token)
- (->' Syntax Bool)
- (_lux_case token
- (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS ["" "~@"])]) (#Cons [_ #Nil])]))])
- true
-
- _
- false))
-
-(def'' (wrap-meta content)
- (->' Syntax Syntax)
- (_meta (#FormS (list (_meta (#TagS ["lux" "Meta"]))
- (_meta (#TupleS (list (_meta (#TupleS (list (_meta (#TextS "")) (_meta (#IntS -1)) (_meta (#IntS -1)))))
- content)))))))
-
-(def'' (untemplate-list tokens)
- (->' ($' List Syntax) Syntax)
- (_lux_case tokens
- #Nil
- (_meta (#TagS ["lux" "Nil"]))
-
- (#Cons [token tokens'])
- (_meta (#FormS (list (_meta (#TagS ["lux" "Cons"]))
- (_meta (#TupleS (list token (untemplate-list tokens')))))))))
-
-(def'' (list:++ xs ys)
- (All' [a] (->' ($' List (B' a)) ($' List (B' a)) ($' List (B' a))))
- (_lux_case xs
- (#Cons [x xs'])
- (#Cons [x (list:++ xs' ys)])
-
- #Nil
- ys))
-
-(defmacro #export ($ tokens)
- (_lux_case tokens
- (#Cons [op (#Cons [init args])])
- (return (_lux_: SyntaxList
- (list (foldL (lambda [a1 a2] ($form (list op a1 a2)))
- init
- args))))
-
- _
- (fail "Wrong syntax for $")))
-
-(def'' (splice untemplate tag elems)
- (->' (->' Syntax Syntax) Syntax ($' List Syntax) Syntax)
- (_lux_case (any? spliced? elems)
- true
- (let [elems' (map (_lux_: (->' Syntax Syntax)
- (lambda [elem]
- (_lux_case elem
- (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS ["" "~@"])]) (#Cons [spliced #Nil])]))])
- spliced
-
- _
- ($form (list ($symbol ["" "_lux_:"])
- ($symbol ["lux" "SyntaxList"])
- ($form (list ($symbol ["lux" "list"]) (untemplate elem))))))))
- elems)]
- (wrap-meta ($form (list tag
- ($form (list& ($symbol ["lux" "$"])
- ($symbol ["lux" "list:++"])
- elems'))))))
-
- false
- (wrap-meta ($form (list tag (untemplate-list (map untemplate elems)))))))
-
-(def'' (untemplate subst token)
- (->' Text Syntax Syntax)
- (_lux_case token
- (#Meta [_ (#BoolS value)])
- (wrap-meta ($form (list ($tag ["lux" "BoolS"]) (_meta (#BoolS value)))))
-
- (#Meta [_ (#IntS value)])
- (wrap-meta ($form (list ($tag ["lux" "IntS"]) (_meta (#IntS value)))))
-
- (#Meta [_ (#RealS value)])
- (wrap-meta ($form (list ($tag ["lux" "RealS"]) (_meta (#RealS value)))))
-
- (#Meta [_ (#CharS value)])
- (wrap-meta ($form (list ($tag ["lux" "CharS"]) (_meta (#CharS value)))))
-
- (#Meta [_ (#TextS value)])
- (wrap-meta ($form (list ($tag ["lux" "TextS"]) (_meta (#TextS value)))))
-
- (#Meta [_ (#TagS [module name])])
- (let [module' (_lux_case module
- ""
- subst
-
- _
- module)]
- (wrap-meta ($form (list ($tag ["lux" "TagS"]) ($tuple (list ($text module') ($text name)))))))
-
- (#Meta [_ (#SymbolS [module name])])
- (let [module' (_lux_case module
- ""
- subst
-
- _
- module)]
- (wrap-meta ($form (list ($tag ["lux" "SymbolS"]) ($tuple (list ($text module') ($text name)))))))
-
- (#Meta [_ (#TupleS elems)])
- (splice (untemplate subst) ($tag ["lux" "TupleS"]) elems)
-
- (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS ["" "~"])]) (#Cons [unquoted #Nil])]))])
- unquoted
-
- (#Meta [_ (#FormS elems)])
- (splice (untemplate subst) ($tag ["lux" "FormS"]) elems)
-
- (#Meta [_ (#RecordS fields)])
- (wrap-meta ($form (list ($tag ["lux" "RecordS"])
- (untemplate-list (map (_lux_: (->' (#TupleT (list Syntax Syntax)) Syntax)
- (lambda [kv]
- (let [[k v] kv]
- ($tuple (list (untemplate subst k) (untemplate subst v))))))
- fields)))))
- ))
-
-(defmacro (`' tokens)
- (_lux_case tokens
- (#Cons [template #Nil])
- (return (_lux_: SyntaxList
- (list (untemplate "" template))))
-
- _
- (fail "Wrong syntax for `'")))
-
-(defmacro #export (|> tokens)
- (_lux_case tokens
- (#Cons [init apps])
- (return (_lux_: SyntaxList
- (list (foldL (_lux_: (->' Syntax Syntax Syntax)
- (lambda [acc app]
- (_lux_case app
- (#Meta [_ (#FormS parts)])
- ($form (list:++ parts (list acc)))
-
- _
- (`' ((~ app) (~ acc))))))
- init
- apps))))
-
- _
- (fail "Wrong syntax for |>")))
-
-(defmacro #export (if tokens)
- (_lux_case tokens
- (#Cons [test (#Cons [then (#Cons [else #Nil])])])
- (return (_lux_: SyntaxList
- (list (`' (_lux_case (~ test)
- true (~ then)
- false (~ else))))))
-
- _
- (fail "Wrong syntax for if")))
-
-## (deftype (Lux a)
-## (-> Compiler (Either Text (, Compiler a))))
-(def'' #export Lux
- Type
- (All' [a]
- (->' Compiler ($' Either Text (#TupleT (list Compiler (B' a)))))))
-
-## (defsig (Monad m)
-## (: (All [a] (-> a (m a)))
-## return)
-## (: (All [a b] (-> (-> a (m b)) (m a) (m b)))
-## bind))
-(def'' Monad
- Type
- (All' [m]
- (#RecordT (list ["lux;return" (All' [a] (->' (B' a) ($' (B' m) (B' a))))]
- ["lux;bind" (All' [a b] (->' (->' (B' a) ($' (B' m) (B' b)))
- ($' (B' m) (B' a))
- ($' (B' m) (B' b))))]))))
-
-(def'' Maybe:Monad
- ($' Monad Maybe)
- {#lux;return
- (lambda return [x]
- (#Some x))
-
- #lux;bind
- (lambda [f ma]
- (_lux_case ma
- #None #None
- (#Some a) (f a)))})
-
-(def'' Lux:Monad
- ($' Monad Lux)
- {#lux;return
- (lambda [x]
- (lambda [state]
- (#Right [state x])))
-
- #lux;bind
- (lambda [f ma]
- (lambda [state]
- (_lux_case (ma state)
- (#Left msg)
- (#Left msg)
-
- (#Right [state' a])
- (f a state'))))})
-
-(defmacro #export (^ tokens)
- (_lux_case tokens
- (#Cons [(#Meta [_ (#SymbolS ["" class-name])]) #Nil])
- (return (_lux_: SyntaxList
- (list (`' (#;DataT (~ (_meta (#TextS class-name))))))))
-
- _
- (fail "Wrong syntax for ^")))
-
-(defmacro #export (-> tokens)
- (_lux_case (reverse tokens)
- (#Cons [output inputs])
- (return (_lux_: SyntaxList
- (list (foldL (_lux_: (->' Syntax Syntax Syntax)
- (lambda [o i] (`' (#;LambdaT [(~ i) (~ o)]))))
- output
- inputs))))
-
- _
- (fail "Wrong syntax for ->")))
-
-(defmacro #export (, tokens)
- (return (_lux_: SyntaxList
- (list (`' (#;TupleT (;list (~@ tokens))))))))
-
-(defmacro (do tokens)
- (_lux_case tokens
- (#Cons [monad (#Cons [(#Meta [_ (#TupleS bindings)]) (#Cons [body #Nil])])])
- (let [body' (foldL (_lux_: (-> Syntax (, Syntax Syntax) Syntax)
- (lambda [body' binding]
- (let [[var value] binding]
- (_lux_case var
- (#Meta [_ (#TagS ["" "let"])])
- (`' (;let (~ value) (~ body')))
-
- _
- (`' (;bind (_lux_lambda (~ ($symbol ["" ""]))
- (~ var)
- (~ body'))
- (~ value)))))))
- body
- (reverse (as-pairs bindings)))]
- (return (_lux_: SyntaxList
- (list (`' (_lux_case (~ monad)
- {#;return ;return #;bind ;bind}
- (~ body')))))))
-
- _
- (fail "Wrong syntax for do")))
-
-(def'' (map% m f xs)
- ## (All [m a b]
- ## (-> (Monad m) (-> a (m b)) (List a) (m (List b))))
- (All' [m a b]
- (-> ($' Monad (B' m))
- (-> (B' a) ($' (B' m) (B' b)))
- ($' List (B' a))
- ($' (B' m) ($' List (B' b)))))
- (let [{#;return ;return #;bind _} m]
- (_lux_case xs
- #Nil
- (;return (_lux_: List #Nil))
-
- (#Cons [x xs'])
- (do m
- [y (f x)
- ys (map% m f xs')]
- (;return (_lux_: List (#Cons [y ys]))))
- )))
-
-(def'' #export (. f g)
- (All' [a b c]
- (-> (-> (B' b) (B' c)) (-> (B' a) (B' b)) (-> (B' a) (B' c))))
- (lambda [x]
- (f (g x))))
-
-(def'' (get-ident x)
- (-> Syntax ($' Maybe Text))
- (_lux_case x
- (#Meta [_ (#SymbolS ["" sname])])
- (#Some sname)
-
- _
- #None))
-
-(def'' (tuple->list tuple)
- (-> Syntax ($' Maybe ($' List Syntax)))
- (_lux_case tuple
- (#Meta [_ (#TupleS members)])
- (#Some members)
-
- _
- #None))
-
-(def'' RepEnv
- Type
- ($' List (, Text Syntax)))
-
-(def'' (make-env xs ys)
- (-> ($' List Text) ($' List Syntax) RepEnv)
- (_lux_case (_lux_: (, ($' List Text) ($' List Syntax))
- [xs ys])
- [(#Cons [x xs']) (#Cons [y ys'])]
- (#Cons [[x y] (make-env xs' ys')])
-
- _
- #Nil))
-
-(def'' (text:= x y)
- (-> Text Text Bool)
- (_jvm_invokevirtual java.lang.Object equals [java.lang.Object]
- x [y]))
-
-(def'' (get-rep key env)
- (-> Text RepEnv ($' Maybe Syntax))
- (_lux_case env
- #Nil
- #None
-
- (#Cons [[k v] env'])
- (if (text:= k key)
- (#Some v)
- (get-rep key env'))))
-
-(def'' (apply-template env template)
- (-> RepEnv Syntax Syntax)
- (_lux_case template
- (#Meta [_ (#SymbolS ["" sname])])
- (_lux_case (get-rep sname env)
- (#Some subst)
- subst
-
- _
- template)
-
- (#Meta [_ (#TupleS elems)])
- ($tuple (map (apply-template env) elems))
-
- (#Meta [_ (#FormS elems)])
- ($form (map (apply-template env) elems))
-
- (#Meta [_ (#RecordS members)])
- ($record (map (_lux_: (-> (, Syntax Syntax) (, Syntax Syntax))
- (lambda [kv]
- (let [[slot value] kv]
- [(apply-template env slot) (apply-template env value)])))
- members))
-
- _
- template))
-
-(def'' (join-map f xs)
- (All' [a b]
- (-> (-> (B' a) ($' List (B' b))) ($' List (B' a)) ($' List (B' b))))
- (_lux_case xs
- #Nil
- #Nil
-
- (#Cons [x xs'])
- (list:++ (f x) (join-map f xs'))))
-
-(defmacro #export (do-template tokens)
- (_lux_case tokens
- (#Cons [(#Meta [_ (#TupleS bindings)]) (#Cons [(#Meta [_ (#TupleS templates)]) data])])
- (_lux_case (_lux_: (, ($' Maybe ($' List Text)) ($' Maybe ($' List ($' List Syntax))))
- [(map% Maybe:Monad get-ident bindings)
- (map% Maybe:Monad tuple->list data)])
- [(#Some bindings') (#Some data')]
- (let [apply (_lux_: (-> RepEnv ($' List Syntax))
- (lambda [env] (map (apply-template env) templates)))]
- (|> data'
- (join-map (. apply (make-env bindings')))
- return))
-
- _
- (fail "All the do-template bindigns must be symbols."))
-
- _
- (fail "Wrong syntax for do-template")))
-
-(do-template [<name> <cmp> <type>]
- [(def'' #export (<name> x y)
- (-> <type> <type> Bool)
- (<cmp> x y))]
-
- [int:= _jvm_leq Int]
- [int:> _jvm_lgt Int]
- [int:< _jvm_llt Int]
- [real:= _jvm_deq Real]
- [real:> _jvm_dgt Real]
- [real:< _jvm_dlt Real]
- )
-
-(do-template [<name> <cmp> <type>]
- [(def'' #export (<name> x y)
- (-> <type> <type> <type>)
- (<cmp> x y))]
-
- [int:+ _jvm_ladd Int]
- [int:- _jvm_lsub Int]
- [int:* _jvm_lmul Int]
- [int:/ _jvm_ldiv Int]
- [int:% _jvm_lrem Int]
- [real:+ _jvm_dadd Real]
- [real:- _jvm_dsub Real]
- [real:* _jvm_dmul Real]
- [real:/ _jvm_ddiv Real]
- [real:% _jvm_drem Real]
- )
-
-(def'' (multiple? div n)
- (-> Int Int Bool)
- (int:= 0 (int:% n div)))
-
-(def'' #export (length list)
- (-> List Int)
- (foldL (lambda [acc _] (int:+ 1 acc)) 0 list))
-
-(def'' #export (not x)
- (-> Bool Bool)
- (if x false true))
-
-(def'' #export (text:++ x y)
- (-> Text Text Text)
- (_jvm_invokevirtual java.lang.String concat [java.lang.String]
- x [y]))
-
-(def'' (ident->text ident)
- (-> Ident Text)
- (let [[module name] ident]
- ($ text:++ module ";" name)))
-
-(def'' (replace-syntax reps syntax)
- (-> RepEnv Syntax Syntax)
- (_lux_case syntax
- (#Meta [_ (#SymbolS ["" name])])
- (_lux_case (get-rep name reps)
- (#Some replacement)
- replacement
-
- #None
- syntax)
-
- (#Meta [_ (#FormS parts)])
- (#Meta [_ (#FormS (map (replace-syntax reps) parts))])
-
- (#Meta [_ (#TupleS members)])
- (#Meta [_ (#TupleS (map (replace-syntax reps) members))])
-
- (#Meta [_ (#RecordS slots)])
- (#Meta [_ (#RecordS (map (_lux_: (-> (, Syntax Syntax) (, Syntax Syntax))
- (lambda [slot]
- (let [[k v] slot]
- [(replace-syntax reps k) (replace-syntax reps v)])))
- slots))])
-
- _
- syntax)
- )
-
-(defmacro #export (All tokens)
- (let [[self-ident tokens'] (_lux_: (, Text SyntaxList)
- (_lux_case tokens
- (#Cons [(#Meta [_ (#SymbolS ["" self-ident])]) tokens'])
- [self-ident tokens']
-
- _
- ["" tokens]))]
- (_lux_case tokens'
- (#Cons [(#Meta [_ (#TupleS args)]) (#Cons [body #Nil])])
- (_lux_case (map% Maybe:Monad get-ident args)
- (#Some idents)
- (_lux_case idents
- #Nil
- (return (_lux_: SyntaxList
- (list body)))
-
- (#Cons [harg targs])
- (let [replacements (map (_lux_: (-> Text (, Text Syntax))
- (lambda [ident] [ident (`' (#;BoundT (~ ($text ident))))]))
- (list& self-ident idents))
- body' (foldL (_lux_: (-> Syntax Text Syntax)
- (lambda [body' arg']
- (`' (#;AllT [#;None "" (~ ($text arg')) (~ body')]))))
- (replace-syntax replacements body)
- (reverse targs))]
- (return (_lux_: SyntaxList
- (list (`' (#;AllT [(#;Some #;Nil) (~ ($text self-ident)) (~ ($text harg)) (~ body')])))))))
-
- #None
- (fail "'All' arguments must be symbols."))
-
- _
- (fail "Wrong syntax for All"))
- ))
-
-(def'' (get k plist)
- (All [a]
- (-> Text ($' List (, Text a)) ($' Maybe a)))
- (_lux_case plist
- (#Cons [[k' v] plist'])
- (if (text:= k k')
- (#Some v)
- (get k plist'))
-
- #Nil
- #None))
-
-(def'' #export (get-module-name state)
- ($' Lux Text)
- (_lux_case state
- {#source source #modules modules
- #envs envs #types types #host host
- #seed seed #seen-sources seen-sources}
- (_lux_case (reverse envs)
- #Nil
- (#Left "Can't get the module name without a module!")
-
- (#Cons [{#name module-name #inner-closures _ #locals _ #closure _} _])
- (#Right [state module-name]))))
-
-(def'' (find-macro' modules current-module module name)
- (-> ($' List (, Text ($' Module Compiler)))
- Text Text Text
- ($' Maybe Macro))
- (do Maybe:Monad
- [$module (get module modules)
- gdef (let [{#module-aliases _ #defs bindings #imports _} (_lux_: ($' Module Compiler) $module)]
- (get name bindings))]
- (_lux_case (_lux_: (, Bool ($' DefData' Macro)) gdef)
- [exported? (#MacroD macro')]
- (if exported?
- (#Some macro')
- (if (text:= module current-module)
- (#Some macro')
- #None))
-
- [_ (#AliasD [r-module r-name])]
- (find-macro' modules current-module r-module r-name)
-
- _
- #None)))
-
-(def'' #export (find-macro ident)
- (-> Ident ($' Lux ($' Maybe Macro)))
- (do Lux:Monad
- [current-module get-module-name]
- (let [[module name] ident]
- (lambda [state]
- (_lux_case state
- {#source source #modules modules
- #envs envs #types types #host host
- #seed seed #seen-sources seen-sources}
- (#Right [state (find-macro' modules current-module module name)]))))))
-
-(def'' (list:join xs)
- (All [a]
- (-> ($' List ($' List a)) ($' List a)))
- (foldL list:++ #Nil xs))
-
-(def'' #export (normalize ident)
- (-> Ident ($' Lux Ident))
- (_lux_case ident
- ["" name]
- (do Lux:Monad
- [module-name get-module-name]
- (;return (_lux_: Ident [module-name name])))
-
- _
- (return ident)))
-
-(defmacro #export (| tokens)
- (do Lux:Monad
- [pairs (map% Lux:Monad
- (_lux_: (-> Syntax ($' Lux Syntax))
- (lambda [token]
- (_lux_case token
- (#Meta [_ (#TagS ident)])
- (do Lux:Monad
- [ident (normalize ident)]
- (;return (_lux_: Syntax (`' [(~ ($text (ident->text ident))) (;,)]))))
-
- (#Meta [_ (#FormS (#Cons [(#Meta [_ (#TagS ident)]) (#Cons [value #Nil])]))])
- (do Lux:Monad
- [ident (normalize ident)]
- (;return (_lux_: Syntax (`' [(~ ($text (ident->text ident))) (~ value)]))))
-
- _
- (fail "Wrong syntax for |"))))
- tokens)]
- (;return (_lux_: SyntaxList
- (list (`' (#;VariantT (;list (~@ pairs)))))))))
-
-(defmacro #export (& tokens)
- (if (not (multiple? 2 (length tokens)))
- (fail "& expects an even number of arguments.")
- (do Lux:Monad
- [pairs (map% Lux:Monad
- (_lux_: (-> (, Syntax Syntax) ($' Lux Syntax))
- (lambda [pair]
- (_lux_case pair
- [(#Meta [_ (#TagS ident)]) value]
- (do Lux:Monad
- [ident (normalize ident)]
- (;return (_lux_: Syntax (`' [(~ ($text (ident->text ident))) (~ value)]))))
-
- _
- (fail "Wrong syntax for &"))))
- (as-pairs tokens))]
- (;return (_lux_: SyntaxList
- (list (`' (#;RecordT (;list (~@ pairs))))))))))
-
-(def'' #export (->text x)
- (-> (^ java.lang.Object) Text)
- (_jvm_invokevirtual java.lang.Object toString [] x []))
-
-(def'' #export (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'' #export (syntax:show syntax)
- (-> Syntax Text)
- (_lux_case syntax
- (#Meta [_ (#BoolS value)])
- (->text value)
-
- (#Meta [_ (#IntS value)])
- (->text value)
-
- (#Meta [_ (#RealS value)])
- (->text value)
-
- (#Meta [_ (#CharS value)])
- ($ text:++ "#\"" (->text value) "\"")
-
- (#Meta [_ (#TextS value)])
- value
-
- (#Meta [_ (#SymbolS ident)])
- (ident->text ident)
-
- (#Meta [_ (#TagS ident)])
- (text:++ "#" (ident->text ident))
-
- (#Meta [_ (#TupleS members)])
- ($ text:++ "[" (|> members (map syntax:show) (interpose " ") (foldL text:++ "")) "]")
-
- (#Meta [_ (#FormS members)])
- ($ text:++ "(" (|> members (map syntax:show) (interpose " ") (foldL text:++ "")) ")")
-
- (#Meta [_ (#RecordS slots)])
- ($ text:++ "{"
- (|> slots
- (map (_lux_: (-> (, Syntax Syntax) Text)
- (lambda [slot]
- (let [[k v] slot]
- ($ text:++ (syntax:show k) " " (syntax:show v))))))
- (interpose " ")
- (foldL text:++ ""))
- "}")
- ))
-
-(def'' #export (macro-expand syntax)
- (-> Syntax ($' Lux ($' List Syntax)))
- (_lux_case syntax
- (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS macro-name)]) args]))])
- (do Lux:Monad
- [macro-name' (normalize macro-name)
- ?macro (find-macro (_lux_: Ident macro-name'))]
- (_lux_case (_lux_: ($' Maybe Macro) ?macro)
- (#Some macro)
- (do Lux:Monad
- [expansion (macro args)
- expansion' (map% Lux:Monad macro-expand (_lux_: SyntaxList expansion))]
- (;return (_lux_: SyntaxList (list:join (_lux_: ($' List SyntaxList) expansion')))))
-
- #None
- (do Lux:Monad
- [parts' (map% Lux:Monad macro-expand (list& ($symbol macro-name) args))]
- (;return (_lux_: SyntaxList (list ($form (list:join (_lux_: ($' List SyntaxList) parts')))))))))
-
- (#Meta [_ (#FormS (#Cons [harg targs]))])
- (do Lux:Monad
- [harg+ (macro-expand harg)
- targs+ (map% Lux:Monad macro-expand (_lux_: SyntaxList targs))]
- (;return (_lux_: SyntaxList (list ($form (list:++ harg+ (list:join (_lux_: ($' List SyntaxList) targs+))))))))
-
- (#Meta [_ (#TupleS members)])
- (do Lux:Monad
- [members' (map% Lux:Monad macro-expand members)]
- (;return (_lux_: SyntaxList (list ($tuple (list:join (_lux_: ($' List SyntaxList) members')))))))
-
- _
- (return (_lux_: SyntaxList (list syntax)))))
-
-(def'' (walk-type type)
- (-> Syntax Syntax)
- (_lux_case type
- (#Meta [_ (#FormS (#Cons [(#Meta [_ (#TagS tag)]) parts]))])
- ($form (#Cons [($tag tag) (map walk-type parts)]))
-
- (#Meta [_ (#TupleS members)])
- ($tuple (map walk-type members))
-
- (#Meta [_ (#FormS (#Cons [type-fn args]))])
- (foldL (_lux_: (-> Syntax Syntax Syntax)
- (lambda [type-fn arg] (`' (#;AppT [(~ type-fn) (~ arg)]))))
- (walk-type type-fn)
- (map walk-type args))
-
- _
- type))
-
-(defmacro #export (type` tokens)
- (_lux_case tokens
- (#Cons [type #Nil])
- (do Lux:Monad
- [type+ (macro-expand type)]
- (_lux_case (_lux_: SyntaxList type+)
- (#Cons [type' #Nil])
- (;return (_lux_: SyntaxList
- (list (walk-type type'))))
-
- _
- (fail "type`: 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 (_lux_: SyntaxList
- (list (`' (_lux_: (;type` (~ type)) (~ value))))))
-
- _
- (fail "Wrong syntax for :")))
-
-(defmacro #export (:! tokens)
- (_lux_case tokens
- (#Cons [type (#Cons [value #Nil])])
- (return (: (List Syntax)
- (list (`' (_lux_:! (;type` (~ type)) (~ value))))))
-
- _
- (fail "Wrong syntax for :!")))
-
-(defmacro #export (deftype tokens)
- (let [[export? tokens'] (: (, Bool (List Syntax))
- (_lux_case tokens
- (#Cons [(#Meta [_ (#TagS ["" "export"])]) tokens'])
- [true tokens']
-
- _
- [false tokens]))
- parts (: (Maybe (, Syntax (List Syntax) Syntax))
- (_lux_case tokens'
- (#Cons [(#Meta [_ (#SymbolS name)]) (#Cons [type #Nil])])
- (#Some [($symbol name) #Nil type])
-
- (#Cons [(#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS name)]) args]))]) (#Cons [type #Nil])])
- (#Some [($symbol name) args type])
-
- _
- #None))]
- (_lux_case parts
- (#Some [name args type])
- (let [with-export (: (List Syntax)
- (if export?
- (list (`' (_lux_export (~ name))))
- #Nil))
- type' (: Syntax
- (_lux_case args
- #Nil
- type
-
- _
- (`' (;All (~ name) [(~@ args)] (~ type)))))]
- (return (: (List Syntax)
- (list& (`' (_lux_def (~ name) (;type` (~ type'))))
- with-export))))
-
- #None
- (fail "Wrong syntax for deftype"))
- ))
-
-(deftype #export (IO a)
- (-> (,) a))
-
-(defmacro #export (io tokens)
- (_lux_case tokens
- (#Cons [value #Nil])
- (let [blank ($symbol ["" ""])]
- (return (_lux_: SyntaxList
- (list (`' (_lux_lambda (~ blank) (~ blank) (~ value)))))))
-
- _
- (fail "Wrong syntax for io")))
-
-(defmacro #export (exec tokens)
- (_lux_case (reverse tokens)
- (#Cons [value actions])
- (let [dummy ($symbol ["" ""])]
- (return (_lux_: SyntaxList
- (list (foldL (: (-> Syntax Syntax Syntax)
- (lambda [post pre] (`' (_lux_case (~ pre) (~ dummy) (~ post)))))
- value
- actions)))))
-
- _
- (fail "Wrong syntax for exec")))
-
-(defmacro #export (def tokens)
- (let [[export? tokens'] (: (, Bool (List Syntax))
- (_lux_case tokens
- (#Cons [(#Meta [_ (#TagS ["" "export"])]) tokens'])
- [true tokens']
-
- _
- [false tokens]))
- parts (: (Maybe (, Syntax (List Syntax) (Maybe Syntax) Syntax))
- (_lux_case tokens'
- (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) (#Cons [type (#Cons [body #Nil])])])
- (#Some [name args (#Some type) body])
-
- (#Cons [name (#Cons [type (#Cons [body #Nil])])])
- (#Some [name #Nil (#Some type) body])
-
- (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) (#Cons [body #Nil])])
- (#Some [name args #None body])
-
- (#Cons [name (#Cons [body #Nil])])
- (#Some [name #Nil #None body])
-
- _
- #None))]
- (_lux_case parts
- (#Some [name args ?type body])
- (let [body' (: Syntax
- (_lux_case args
- #Nil
- body
-
- _
- (`' (;lambda (~ name) [(~@ args)] (~ body)))))
- body'' (: Syntax
- (_lux_case ?type
- (#Some type)
- (`' (: (~ type) (~ body')))
-
- #None
- body'))]
- (return (: (List Syntax)
- (list& (`' (_lux_def (~ name) (~ body'')))
- (if export?
- (list (`' (_lux_export (~ name))))
- #Nil)))))
-
- #None
- (fail "Wrong syntax for def"))))
-
-(def (rejoin-pair pair)
- (-> (, Syntax Syntax) (List Syntax))
- (let [[left right] pair]
- (list left right)))
-
-(defmacro #export (case tokens)
- (_lux_case tokens
- (#Cons [value branches])
- (do Lux:Monad
- [expansions (map% Lux:Monad
- (: (-> (, Syntax Syntax) (Lux (List (, Syntax Syntax))))
- (lambda expander [branch]
- (let [[pattern body] branch]
- (_lux_case pattern
- (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS macro-name)]) macro-args]))])
- (do Lux:Monad
- [expansion (macro-expand ($form (list& ($symbol macro-name) body macro-args)))
- expansions (map% Lux:Monad expander (as-pairs (: (List Syntax) expansion)))]
- (;return (: (List (, Syntax Syntax)) (list:join (: (List (List (, Syntax Syntax))) expansions)))))
-
- _
- (;return (: (List (, Syntax Syntax)) (list branch)))))))
- (as-pairs branches))]
- (;return (_lux_: SyntaxList
- (list (`' (_lux_case (~ value)
- (~@ (|> (: (List (List (, Syntax Syntax))) expansions)
- list:join (map rejoin-pair) list:join))))))))
-
- _
- (fail "Wrong syntax for case")))
-
-(defmacro #export (\ tokens)
- (case tokens
- (#Cons [body (#Cons [pattern #Nil])])
- (do Lux:Monad
- [pattern+ (macro-expand pattern)]
- (case (: (List Syntax) pattern+)
- (#Cons [pattern' #Nil])
- (;return (: (List Syntax)
- (list pattern' body)))
-
- _
- (fail "\\ can only expand to 1 pattern.")))
-
- _
- (fail "Wrong syntax for \\")))
-
-(defmacro #export (\or tokens)
- (case tokens
- (#Cons [body patterns])
- (case patterns
- #Nil
- (fail "\\or can't have 0 patterns")
-
- _
- (do Lux:Monad
- [patterns' (map% Lux:Monad macro-expand patterns)]
- (;return (: (List Syntax)
- (list:join (map (: (-> Syntax (List Syntax))
- (lambda [pattern] (list pattern body)))
- (list:join patterns')))))))
-
- _
- (fail "Wrong syntax for \\or")))
-
-(do-template [<name> <offset>]
- [(def #export <name> (int:+ <offset>))]
-
- [inc 1]
- [dec -1])
-
-(def (int:show int)
- (-> Int Text)
- (_jvm_invokevirtual java.lang.Object toString []
- int []))
-
-(defmacro #export (` tokens)
- (do Lux:Monad
- [module-name get-module-name]
- (case tokens
- (\ (list template))
- (;return (_lux_: SyntaxList
- (list (untemplate module-name template))))
-
- _
- (fail "Wrong syntax for `"))))
-
-(def #export (gensym prefix state)
- (-> Text (Lux Syntax))
- (case state
- {#source source #modules modules
- #envs envs #types types #host host
- #seed seed #seen-sources seen-sources}
- (#Right [{#source source #modules modules
- #envs envs #types types #host host
- #seed (inc seed) #seen-sources seen-sources}
- ($symbol ["__gensym__" (int:show seed)])])))
-
-(def #export (macro-expand-1 token)
- (-> Syntax (Lux Syntax))
- (do Lux:Monad
- [token+ (macro-expand token)]
- (case (: (List Syntax) token+)
- (\ (list token'))
- (;return token')
-
- _
- (fail "Macro expanded to more than 1 element."))))
-
-(defmacro #export (sig tokens)
- (do Lux:Monad
- [tokens' (map% Lux:Monad macro-expand-1 tokens)
- members (map% Lux:Monad
- (: (-> Syntax (Lux (, Ident Syntax)))
- (lambda [token]
- (case token
- (\ (#Meta [_ (#FormS (list (#Meta [_ (#SymbolS ["" "_lux_:"])]) type (#Meta [_ (#SymbolS name)])))]))
- (do Lux:Monad
- [name' (normalize name)]
- (;return (: (, Ident Syntax) [name' type])))
-
- _
- (fail "Signatures require typed members!"))))
- tokens')]
- (;return (: (List Syntax)
- (list (`' (#;RecordT (list (~@ (map (: (-> (, Ident Syntax) Syntax)
- (lambda [pair]
- (let [[name type] pair]
- (`' [(~ (|> name ident->text $text))
- (~ type)]))))
- members))))))))))
-
-(defmacro #export (defsig tokens)
- (let [[export? tokens'] (: (, Bool (List Syntax))
- (case tokens
- (\ (list& (#Meta [_ (#TagS ["" "export"])]) tokens'))
- [true tokens']
-
- _
- [false tokens]))
- ?parts (: (Maybe (, Syntax (List Syntax) (List Syntax)))
- (case tokens'
- (\ (list& (#Meta [_ (#FormS (list& name args))]) sigs))
- (#Some [name args sigs])
-
- (\ (list& name sigs))
- (#Some [name #Nil sigs])
-
- _
- #None))]
- (case ?parts
- (#Some [name args sigs])
- (let [sigs' (: Syntax
- (case args
- #Nil
- (`' (;sig (~@ sigs)))
-
- _
- (`' (;All (~ name) [(~@ args)] (;sig (~@ sigs))))))]
- (return (: (List Syntax)
- (list& (`' (_lux_def (~ name) (~ sigs')))
- (if export?
- (list (`' (_lux_export (~ name))))
- #Nil)))))
-
- #None
- (fail "Wrong syntax for defsig"))))
-
-(defmacro #export (struct tokens)
- (do Lux:Monad
- [tokens' (map% Lux:Monad macro-expand-1 tokens)
- members (map% Lux:Monad
- (: (-> Syntax (Lux (, Syntax Syntax)))
- (lambda [token]
- (case token
- (\ (#Meta [_ (#FormS (list (#Meta [_ (#SymbolS ["" "_lux_def"])]) (#Meta [_ (#SymbolS name)]) value))]))
- (do Lux:Monad
- [name' (normalize name)]
- (;return (: (, Syntax Syntax) [($tag name') value])))
-
- _
- (fail "Structures require defined members!"))))
- tokens')]
- (;return (: (List Syntax)
- (list ($record members))))))
-
-(defmacro #export (defstruct tokens)
- (let [[export? tokens'] (: (, Bool (List Syntax))
- (case tokens
- (\ (list& (#Meta [_ (#TagS ["" "export"])]) tokens'))
- [true tokens']
-
- _
- [false tokens]))
- ?parts (: (Maybe (, Syntax (List Syntax) Syntax (List Syntax)))
- (case tokens'
- (\ (list& (#Meta [_ (#FormS (list& name args))]) type defs))
- (#Some [name args type defs])
-
- (\ (list& name type defs))
- (#Some [name #Nil type defs])
-
- _
- #None))]
- (case ?parts
- (#Some [name args type defs])
- (let [defs' (: Syntax
- (case args
- #Nil
- (`' (;struct (~@ defs)))
-
- _
- (`' (;lambda (~ name) [(~@ args)] (;struct (~@ defs))))))]
- (return (: (List Syntax)
- (list& (`' (def (~ name) (~ type) (~ defs')))
- (if export?
- (list (`' (_lux_export (~ name))))
- #Nil)))))
-
- #None
- (fail "Wrong syntax for defsig"))))
-
-(defsig #export (Eq a)
- (: (-> a a Bool)
- =))
-
-(do-template [<name> <type> <test>]
- [(defstruct #export <name> (Eq <type>)
- (def (= x y)
- (<test> x y)))]
-
- [Int:Eq Int _jvm_leq]
- [Real:Eq Real _jvm_deq])
-
-(def #export (id x)
- (All [a] (-> a a))
- x)
-
-(defsig #export (Show a)
- (: (-> a Text)
- show))
-
-(do-template [<name> <type> <body>]
- [(defstruct #export <name> (Show <type>)
- (def (show x)
- <body>))]
-
- [Bool:Show Bool (->text x)]
- [Int:Show Int (->text x)]
- [Real:Show Real (->text x)]
- [Char:Show Char ($ text:++ "#\"" (->text x) "\"")])
-
-(defsig #export (Ord a)
- (: (-> a a Bool)
- <)
- (: (-> a a Bool)
- <=)
- (: (-> a a Bool)
- >)
- (: (-> a a Bool)
- >=))
-
-(do-template [<name> <form> <message>]
- [(defmacro #export (<name> tokens)
- (case (reverse tokens)
- (\ (list& last init))
- (return (: (List Syntax)
- (list (foldL (: (-> Syntax Syntax Syntax)
- (lambda [post pre] (` <form>)))
- last
- init))))
-
- _
- (fail <message>)))]
-
- [and (if (~ pre) true (~ post)) "and requires >=1 clauses."]
- [or (if (~ pre) (~ post) false) "or requires >=1 clauses."])
-
-(do-template [<name> <type> <lt> <gt> <eq>]
- [(defstruct #export <name> (Ord <type>)
- (def (< x y)
- (<lt> x y))
-
- (def (<= x y)
- (or (<lt> x y)
- (<eq> x y)))
-
- (def (> x y)
- (<gt> x y))
-
- (def (>= x y)
- (or (<gt> x y)
- (<eq> x y))))]
-
- [Int:Ord Int _jvm_llt _jvm_lgt _jvm_leq]
- [Real:Ord Real _jvm_dlt _jvm_dgt _jvm_deq])
-
-(defmacro #export (lux tokens state)
- (case state
- {#source source #modules modules
- #envs envs #types types #host host
- #seed seed #seen-sources seen-sources}
- (case (get "lux" modules)
- (#Some lux)
- (let [to-alias (map (: (-> (, Text (, Bool (DefData' (-> (List Syntax) (StateE Compiler (List Syntax))))))
- (List Text))
- (lambda [gdef]
- (let [[name [export? _]] gdef]
- (if export?
- (list name)
- (list)))))
- (let [{#module-aliases _ #defs defs #imports _} lux]
- defs))]
- (#Right [state (: (List Syntax)
- (map (: (-> Text Syntax)
- (lambda [name]
- (` ((~ ($symbol ["" "_lux_def"])) (~ ($symbol ["" name])) (~ ($symbol ["lux" name]))))))
- (list:join to-alias)))]))
-
- #None
- (#Left "Uh, oh... The universe is not working properly..."))
- ))
-
-(def #export (print x)
- (-> Text (IO (,)))
- (lambda [_]
- (exec (_jvm_invokevirtual java.io.PrintStream print [java.lang.Object]
- (_jvm_getstatic java.lang.System out) [x])
- [])))
-
-(def #export (println x)
- (-> Text (IO (,)))
- (print (text:++ x "\n")))
-
-(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 (index-of part text)
- (-> Text Text Int)
- (_jvm_i2l (_jvm_invokevirtual java.lang.String indexOf [java.lang.String]
- text [part])))
-
-(def (substring1 idx text)
- (-> Int Text Text)
- (_jvm_invokevirtual java.lang.String substring [int]
- text [(_jvm_l2i idx)]))
-
-(def (substring2 idx1 idx2 text)
- (-> Int Int Text Text)
- (_jvm_invokevirtual java.lang.String substring [int int]
- text [(_jvm_l2i idx1) (_jvm_l2i idx2)]))
-
-(def (split-slot slot)
- (-> Text (, Text Text))
- (let [idx (index-of ";" slot)
- module (substring2 0 idx slot)
- name (substring1 (inc idx) slot)]
- [module name]))
-
-(def (resolve-struct-type type)
- (-> Type (Maybe Type))
- (case type
- (#RecordT slots)
- (#Some type)
-
- (#AppT [fun arg])
- (resolve-struct-type fun)
-
- (#AllT [_ _ _ body])
- (resolve-struct-type body)
-
- _
- #None))
-
-(defmacro #export (using tokens state)
- (case tokens
- (\ (list struct body))
- (case struct
- (#Meta [_ (#SymbolS vname)])
- (let [vname' (ident->text vname)]
- (case state
- {#source source #modules modules
- #envs envs #types types #host host
- #seed seed #seen-sources seen-sources}
- (let [?struct-type (some (: (-> (Env Text (, LuxVar Type)) (Maybe Type))
- (lambda [env]
- (case env
- {#name _ #inner-closures _ #locals {#counter _ #mappings mappings} #closure _}
- (some (: (-> (, Text (, LuxVar Type)) (Maybe Type))
- (lambda [binding]
- (let [[bname [_ type]] binding]
- (if (text:= vname' bname)
- (#Some type)
- #None))))
- mappings))))
- envs)]
- (case ?struct-type
- #None
- (#Left ($ text:++ "Unknown structure: " vname'))
-
- (#Some struct-type)
- (case (resolve-struct-type struct-type)
- (#Some (#RecordT slots))
- (let [pattern ($record (map (: (-> (, Text Type) (, Syntax Syntax))
- (lambda [slot]
- (let [[sname stype] slot
- [module name] (split-slot sname)]
- [($tag [module name]) ($symbol ["" name])])))
- slots))]
- (#Right [state (: (List Syntax)
- (list (` (_lux_case (~ struct) (~ pattern) (~ body)))))]))
-
- _
- (#Left "Can only \"use\" records."))))))
-
- _
- (let [dummy ($symbol ["" ""])]
- (#Right [state (: (List Syntax)
- (list (` (_lux_case (~ struct)
- (~ dummy)
- (using (~ dummy)
- (~ body))))))])))
-
- _
- (#Left "Wrong syntax for defsig")))
-
-(def #export (flip f)
- (All [a b c]
- (-> (-> a b c) (-> b a c)))
- (lambda [y x]
- (f x y)))
-
-## (def #export (curry f)
-## (All [a b c]
-## (-> (-> (, a b) c)
-## (-> a b c)))
-## (lambda [x y]
-## (f [x y])))
-
-## (def #export (uncurry f)
-## (All [a b c]
-## (-> (-> a b c)
-## (-> (, a b) c)))
-## (lambda [[x y]]
-## (f x y)))
-
-## (defmacro (loop tokens)
-## (_lux_case tokens
-## (#Cons [bindings (#Cons [body #Nil])])
-## (let [pairs (as-pairs bindings)]
-## (return (list (#FormS (#Cons [(` (lambda (~ (#SymbolS ["" "recur"])) (~ (#TupleS (map first pairs)))
-## (~ body)))
-## (map second pairs)])))))))
-
-## (defmacro (get@ tokens)
-## (let [output (_lux_case tokens
-## (#Cons [tag (#Cons [record #Nil])])
-## (` (get@' (~ tag) (~ record)))
-
-## (#Cons [tag #Nil])
-## (` (lambda [record] (get@' (~ tag) record))))]
-## (return (list output))))
-
-## (defmacro (set@ tokens)
-## (let [output (_lux_case tokens
-## (#Cons [tag (#Cons [value (#Cons [record #Nil])])])
-## (` (set@' (~ tag) (~ value) (~ record)))
-
-## (#Cons [tag (#Cons [value #Nil])])
-## (` (lambda [record] (set@' (~ tag) (~ value) record)))
-
-## (#Cons [tag #Nil])
-## (` (lambda [value record] (set@' (~ tag) value record))))]
-## (return (list output))))
-
-## (defmacro (update@ tokens)
-## (let [output (_lux_case tokens
-## (#Cons [tag (#Cons [func (#Cons [record #Nil])])])
-## (` (let [_record_ (~ record)]
-## (set@' (~ tag) ((~ func) (get@' (~ tag) _record_)) _record_)))
-
-## (#Cons [tag (#Cons [func #Nil])])
-## (` (lambda [record]
-## (` (set@' (~ tag) ((~ func) (get@' (~ tag) record)) record))))
-
-## (#Cons [tag #Nil])
-## (` (lambda [func record]
-## (set@' (~ tag) (func (get@' (~ tag) record)) record))))]
-## (return (list output))))
generated by cgit v1.2.3 (git 2.25.1) at 2024-10-05 23:27:50 +0000