aboutsummaryrefslogtreecommitdiff
path: root/source/lux.lux
diff options
context:
space:
mode:
Diffstat (limited to 'source/lux.lux')
-rw-r--r--source/lux.lux3789
1 files changed, 2245 insertions, 1544 deletions
diff --git a/source/lux.lux b/source/lux.lux
index acaee2265..8861bc241 100644
--- a/source/lux.lux
+++ b/source/lux.lux
@@ -7,53 +7,55 @@
## You must not remove this notice, or any other, from this software.
## First things first, must define functions
-(jvm-interface Function
- (:' (-> [java.lang.Object] java.lang.Object)
- apply))
+(_jvm_interface "Function" []
+ ("apply" ["java.lang.Object"] "java.lang.Object" ["public" "abstract"]))
## Basic types
-(def' Bool (#DataT "java.lang.Boolean"))
-(export' Bool)
+(_lux_def Bool (#DataT "java.lang.Boolean"))
+(_lux_export Bool)
-(def' Int (#DataT "java.lang.Long"))
-(export' Int)
+(_lux_def Int (#DataT "java.lang.Long"))
+(_lux_export Int)
-(def' Real (#DataT "java.lang.Double"))
-(export' Real)
+(_lux_def Real (#DataT "java.lang.Double"))
+(_lux_export Real)
-(def' Char (#DataT "java.lang.Character"))
-(export' Char)
+(_lux_def Char (#DataT "java.lang.Character"))
+(_lux_export Char)
-(def' Text (#DataT "java.lang.String"))
-(export' Text)
+(_lux_def Text (#DataT "java.lang.String"))
+(_lux_export Text)
-(def' Void (#VariantT #Nil))
-(export' Void)
+(_lux_def Unit (#TupleT #Nil))
+(_lux_export Unit)
-(def' Ident (#TupleT (#Cons [Text (#Cons [Text #Nil])])))
-(export' Ident)
+(_lux_def Void (#VariantT #Nil))
+(_lux_export Void)
+
+(_lux_def Ident (#TupleT (#Cons [Text (#Cons [Text #Nil])])))
+(_lux_export Ident)
## (deftype (List a)
## (| #Nil
## (#Cons (, a (List a)))))
-(def' List
- (#AllT [#None "List" "a"
+(_lux_def List
+ (#AllT [(#Some #Nil) "lux;List" "a"
(#VariantT (#Cons [["lux;Nil" (#TupleT #Nil)]
(#Cons [["lux;Cons" (#TupleT (#Cons [(#BoundT "a")
- (#Cons [(#AppT [(#BoundT "List") (#BoundT "a")])
+ (#Cons [(#AppT [(#BoundT "lux;List") (#BoundT "a")])
#Nil])]))]
#Nil])]))]))
-(export' List)
+(_lux_export List)
## (deftype (Maybe a)
## (| #None
## (#Some a)))
-(def' Maybe
- (#AllT [#None "Maybe" "a"
+(_lux_def Maybe
+ (#AllT [(#Some #Nil) "lux;Maybe" "a"
(#VariantT (#Cons [["lux;None" (#TupleT #Nil)]
(#Cons [["lux;Some" (#BoundT "a")]
#Nil])]))]))
-(export' Maybe)
+(_lux_export Maybe)
## (deftype #rec Type
## (| (#DataT Text)
@@ -65,31 +67,31 @@
## (#VarT Int)
## (#AllT (, (Maybe (List (, Text Type))) Text Text Type))
## (#AppT (, Type Type))))
-(def' Type
- (case' (#AppT [(#BoundT "Type") (#BoundT "_")])
- Type
- (case' (#AppT [List (#TupleT (#Cons [Text (#Cons [Type #Nil])]))])
- TypeEnv
- (#AppT [(#AllT [#None "Type" "_"
- (#VariantT (#Cons [["lux;DataT" Text]
- (#Cons [["lux;TupleT" (#AppT [List Type])]
- (#Cons [["lux;VariantT" TypeEnv]
- (#Cons [["lux;RecordT" TypeEnv]
- (#Cons [["lux;LambdaT" (#TupleT (#Cons [Type (#Cons [Type #Nil])]))]
- (#Cons [["lux;BoundT" Text]
- (#Cons [["lux;VarT" Int]
- (#Cons [["lux;AllT" (#TupleT (#Cons [(#AppT [Maybe TypeEnv]) (#Cons [Text (#Cons [Text (#Cons [Type #Nil])])])]))]
- (#Cons [["lux;AppT" (#TupleT (#Cons [Type (#Cons [Type #Nil])]))]
- (#Cons [["lux;ExT" Int]
- #Nil])])])])])])])])])]))])
- Void]))))
-(export' Type)
+(_lux_def Type
+ (_lux_case (#AppT [(#BoundT "Type") (#BoundT "_")])
+ Type
+ (_lux_case (#AppT [List (#TupleT (#Cons [Text (#Cons [Type #Nil])]))])
+ TypeEnv
+ (#AppT [(#AllT [(#Some #Nil) "Type" "_"
+ (#VariantT (#Cons [["lux;DataT" Text]
+ (#Cons [["lux;TupleT" (#AppT [List Type])]
+ (#Cons [["lux;VariantT" TypeEnv]
+ (#Cons [["lux;RecordT" TypeEnv]
+ (#Cons [["lux;LambdaT" (#TupleT (#Cons [Type (#Cons [Type #Nil])]))]
+ (#Cons [["lux;BoundT" Text]
+ (#Cons [["lux;VarT" Int]
+ (#Cons [["lux;AllT" (#TupleT (#Cons [(#AppT [Maybe TypeEnv]) (#Cons [Text (#Cons [Text (#Cons [Type #Nil])])])]))]
+ (#Cons [["lux;AppT" (#TupleT (#Cons [Type (#Cons [Type #Nil])]))]
+ (#Cons [["lux;ExT" Int]
+ #Nil])])])])])])])])])]))])
+ Void]))))
+(_lux_export Type)
## (deftype (Bindings k v)
## (& #counter Int
## #mappings (List (, k v))))
-(def' Bindings
- (#AllT [#None "Bindings" "k"
+(_lux_def Bindings
+ (#AllT [(#Some #Nil) "lux;Bindings" "k"
(#AllT [#None "" "v"
(#RecordT (#Cons [["lux;counter" Int]
(#Cons [["lux;mappings" (#AppT [List
@@ -97,14 +99,15 @@
(#Cons [(#BoundT "v")
#Nil])]))])]
#Nil])]))])]))
+(_lux_export Bindings)
## (deftype (Env k v)
## (& #name Text
## #inner-closures Int
## #locals (Bindings k v)
## #closure (Bindings k v)))
-(def' Env
- (#AllT [#None "Env" "k"
+(_lux_def Env
+ (#AllT [(#Some #Nil) "lux;Env" "k"
(#AllT [#None "" "v"
(#RecordT (#Cons [["lux;name" Text]
(#Cons [["lux;inner-closures" Int]
@@ -113,82 +116,84 @@
(#Cons [["lux;closure" (#AppT [(#AppT [Bindings (#BoundT "k")])
(#BoundT "v")])]
#Nil])])])]))])]))
+(_lux_export Env)
## (deftype Cursor
## (, Text Int Int))
-(def' Cursor
+(_lux_def Cursor
(#TupleT (#Cons [Text (#Cons [Int (#Cons [Int #Nil])])])))
+(_lux_export Cursor)
## (deftype (Meta m v)
## (| (#Meta (, m v))))
-(def' Meta
- (#AllT [#None "Meta" "m"
+(_lux_def Meta
+ (#AllT [(#Some #Nil) "lux;Meta" "m"
(#AllT [#None "" "v"
(#VariantT (#Cons [["lux;Meta" (#TupleT (#Cons [(#BoundT "m")
(#Cons [(#BoundT "v")
#Nil])]))]
#Nil]))])]))
-(export' Meta)
+(_lux_export Meta)
## (deftype (Syntax' w)
-## (| (#Bool Bool)
-## (#Int Int)
-## (#Real Real)
-## (#Char Char)
-## (#Text Text)
-## (#Symbol (, Text Text))
-## (#Tag (, Text Text))
-## (#Form (List (w (Syntax' w))))
-## (#Tuple (List (w (Syntax' w))))
-## (#Record (List (, (w (Syntax' w)) (w (Syntax' w)))))))
-(def' Syntax'
- (case' (#AppT [(#BoundT "w")
- (#AppT [(#BoundT "Syntax'")
- (#BoundT "w")])])
- Syntax
- (case' (#AppT [List Syntax])
- SyntaxList
- (#AllT [#None "Syntax'" "w"
- (#VariantT (#Cons [["lux;Bool" Bool]
- (#Cons [["lux;Int" Int]
- (#Cons [["lux;Real" Real]
- (#Cons [["lux;Char" Char]
- (#Cons [["lux;Text" Text]
- (#Cons [["lux;Symbol" Ident]
- (#Cons [["lux;Tag" Ident]
- (#Cons [["lux;Form" SyntaxList]
- (#Cons [["lux;Tuple" SyntaxList]
- (#Cons [["lux;Record" (#AppT [List (#TupleT (#Cons [Syntax (#Cons [Syntax #Nil])]))])]
- #Nil])
- ])])])])])])])])])
- )]))))
-(export' Syntax')
+## (| (#BoolS Bool)
+## (#IntS Int)
+## (#RealS Real)
+## (#CharS Char)
+## (#TextS Text)
+## (#SymbolS (, Text Text))
+## (#TagS (, Text Text))
+## (#FormS (List (w (Syntax' w))))
+## (#TupleS (List (w (Syntax' w))))
+## (#RecordS (List (, (w (Syntax' w)) (w (Syntax' w)))))))
+(_lux_def Syntax'
+ (_lux_case (#AppT [(#BoundT "w")
+ (#AppT [(#BoundT "lux;Syntax'")
+ (#BoundT "w")])])
+ Syntax
+ (_lux_case (#AppT [List Syntax])
+ SyntaxList
+ (#AllT [(#Some #Nil) "lux;Syntax'" "w"
+ (#VariantT (#Cons [["lux;BoolS" Bool]
+ (#Cons [["lux;IntS" Int]
+ (#Cons [["lux;RealS" Real]
+ (#Cons [["lux;CharS" Char]
+ (#Cons [["lux;TextS" Text]
+ (#Cons [["lux;SymbolS" Ident]
+ (#Cons [["lux;TagS" Ident]
+ (#Cons [["lux;FormS" SyntaxList]
+ (#Cons [["lux;TupleS" SyntaxList]
+ (#Cons [["lux;RecordS" (#AppT [List (#TupleT (#Cons [Syntax (#Cons [Syntax #Nil])]))])]
+ #Nil])
+ ])])])])])])])])])
+ )]))))
+(_lux_export Syntax')
## (deftype Syntax
## (Meta Cursor (Syntax' (Meta Cursor))))
-(def' Syntax
- (case' (#AppT [Meta Cursor])
- w
- (#AppT [w (#AppT [Syntax' w])])))
-(export' Syntax)
+(_lux_def Syntax
+ (_lux_case (#AppT [Meta Cursor])
+ w
+ (#AppT [w (#AppT [Syntax' w])])))
+(_lux_export Syntax)
-(def' SyntaxList (#AppT [List Syntax]))
+(_lux_def SyntaxList (#AppT [List Syntax]))
## (deftype (Either l r)
## (| (#Left l)
## (#Right r)))
-(def' Either
- (#AllT [#None "_" "l"
+(_lux_def Either
+ (#AllT [(#Some #Nil) "lux;Either" "l"
(#AllT [#None "" "r"
(#VariantT (#Cons [["lux;Left" (#BoundT "l")]
(#Cons [["lux;Right" (#BoundT "r")]
#Nil])]))])]))
-(export' Either)
+(_lux_export Either)
## (deftype (StateE s a)
## (-> s (Either Text (, s a))))
-(def' StateE
- (#AllT [#None "StateE" "s"
+(_lux_def StateE
+ (#AllT [(#Some #Nil) "lux;StateE" "s"
(#AllT [#None "" "a"
(#LambdaT [(#BoundT "s")
(#AppT [(#AppT [Either Text])
@@ -196,22 +201,22 @@
(#Cons [(#BoundT "a")
#Nil])]))])])])]))
-## (def' Reader
+## (deftype Reader
## (List (Meta Cursor Text)))
-(def' Reader
+(_lux_def Reader
(#AppT [List
(#AppT [(#AppT [Meta Cursor])
Text])]))
-(export' Reader)
+(_lux_export Reader)
## (deftype HostState
## (& #writer (^ org.objectweb.asm.ClassWriter)
## #loader (^ java.net.URLClassLoader)
-## #eval-ctor Int))
-(def' HostState
+## #classes (^ clojure.lang.Atom)))
+(_lux_def HostState
(#RecordT (#Cons [["lux;writer" (#DataT "org.objectweb.asm.ClassWriter")]
(#Cons [["lux;loader" (#DataT "java.lang.ClassLoader")]
- (#Cons [["lux;eval-ctor" Int]
+ (#Cons [["lux;classes" (#DataT "clojure.lang.Atom")]
#Nil])])])))
## (deftype (DefData' m)
@@ -219,719 +224,713 @@
## (#ValueD Type)
## (#MacroD m)
## (#AliasD Ident)))
-(def' DefData'
- (#AllT [#None "DefData'" ""
+(_lux_def DefData'
+ (#AllT [(#Some #Nil) "lux;DefData'" ""
(#VariantT (#Cons [["lux;TypeD" (#TupleT #Nil)]
(#Cons [["lux;ValueD" Type]
(#Cons [["lux;MacroD" (#BoundT "")]
(#Cons [["lux;AliasD" Ident]
#Nil])])])]))]))
+(_lux_export DefData')
## (deftype LuxVar
## (| (#Local Int)
## (#Global Ident)))
-(def' LuxVar
+(_lux_def LuxVar
(#VariantT (#Cons [["lux;Local" Int]
(#Cons [["lux;Global" Ident]
#Nil])])))
-(export' LuxVar)
-
-## (deftype #rec CompilerState
-## (& #source (Maybe Reader)
-## #modules (List (, Text (List (, Text (, Bool (DefData' (-> (List Syntax) (StateE CompilerState (List Syntax)))))))))
-## #module-aliases (List Void)
-## #envs (List (Env Text (, LuxVar Type)))
-## #types (Bindings Int Type)
-## #host HostState))
-(def' CompilerState
- (#AppT [(#AllT [#None "CompilerState" ""
- (#RecordT (#Cons [["lux;source" (#AppT [Maybe Reader])]
+(_lux_export LuxVar)
+
+## (deftype (Module Compiler)
+## (& #module-aliases (List (, Text Text))
+## #defs (List (, Text (, Bool (DefData' (-> (List Syntax) (StateE Compiler (List Syntax)))))))
+## #imports (List Text)
+## ))
+(_lux_def Module
+ (#AllT [(#Some #Nil) "lux;Module" "Compiler"
+ (#RecordT (#Cons [["lux;module-aliases" (#AppT [List (#TupleT (#Cons [Text (#Cons [Text #Nil])]))])]
+ (#Cons [["lux;defs" (#AppT [List (#TupleT (#Cons [Text
+ (#Cons [(#TupleT (#Cons [Bool (#Cons [(#AppT [DefData' (#LambdaT [SyntaxList
+ (#AppT [(#AppT [StateE (#BoundT "Compiler")])
+ SyntaxList])])])
+ #Nil])]))
+ #Nil])]))])]
+ (#Cons [["lux;imports" (#AppT [List Text])]
+ #Nil])])]))]))
+(_lux_export Module)
+
+## (deftype #rec Compiler
+## (& #source Reader
+## #modules (List (, Text (Module Compiler)))
+## #envs (List (Env Text (, LuxVar Type)))
+## #types (Bindings Int Type)
+## #host HostState
+## #seed Int
+## #eval? Bool))
+(_lux_def Compiler
+ (#AppT [(#AllT [(#Some #Nil) "lux;Compiler" ""
+ (#RecordT (#Cons [["lux;source" Reader]
(#Cons [["lux;modules" (#AppT [List (#TupleT (#Cons [Text
- (#Cons [(#AppT [List (#TupleT (#Cons [Text
- (#Cons [(#TupleT (#Cons [Bool (#Cons [(#AppT [DefData' (#LambdaT [SyntaxList
- (#AppT [(#AppT [StateE (#AppT [(#BoundT "CompilerState")
- (#BoundT "")])])
- SyntaxList])])])
- #Nil])]))
- #Nil])]))])
+ (#Cons [(#AppT [Module (#AppT [(#BoundT "lux;Compiler") (#BoundT "")])])
#Nil])]))])]
- (#Cons [["lux;module-aliases" (#AppT [List Void])]
- (#Cons [["lux;envs" (#AppT [List (#AppT [(#AppT [Env Text])
- (#TupleT (#Cons [LuxVar (#Cons [Type #Nil])]))])])]
- (#Cons [["lux;types" (#AppT [(#AppT [Bindings Int]) Type])]
- (#Cons [["lux;host" HostState]
- (#Cons [["lux;seed" Int]
+ (#Cons [["lux;envs" (#AppT [List (#AppT [(#AppT [Env Text])
+ (#TupleT (#Cons [LuxVar (#Cons [Type #Nil])]))])])]
+ (#Cons [["lux;types" (#AppT [(#AppT [Bindings Int]) Type])]
+ (#Cons [["lux;host" HostState]
+ (#Cons [["lux;seed" Int]
+ (#Cons [["lux;eval?" Bool]
#Nil])])])])])])]))])
Void]))
-(export' CompilerState)
+(_lux_export Compiler)
## (deftype Macro
-## (-> (List Syntax) (StateE CompilerState (List Syntax))))
-(def' Macro
+## (-> (List Syntax) (StateE Compiler (List Syntax))))
+(_lux_def Macro
(#LambdaT [SyntaxList
- (#AppT [(#AppT [StateE CompilerState])
+ (#AppT [(#AppT [StateE Compiler])
SyntaxList])]))
-(export' Macro)
+(_lux_export Macro)
## Base functions & macros
+## (def _cursor
+## Cursor
+## ["" -1 -1])
+(_lux_def _cursor
+ (_lux_: Cursor ["" -1 -1]))
+
## (def (_meta data)
## (-> (Syntax' (Meta Cursor)) Syntax)
## (#Meta [["" -1 -1] data]))
-(def' _meta
- (:' (#LambdaT [(#AppT [Syntax'
- (#AppT [Meta Cursor])])
- Syntax])
- (lambda' _ data
- (#Meta [["" -1 -1] data]))))
+(_lux_def _meta
+ (_lux_: (#LambdaT [(#AppT [Syntax'
+ (#AppT [Meta Cursor])])
+ Syntax])
+ (_lux_lambda _ data
+ (#Meta [_cursor data]))))
## (def (return x)
## (All [a]
-## (-> a CompilerState
-## (Either Text (, CompilerState a))))
+## (-> a Compiler
+## (Either Text (, Compiler a))))
## ...)
-(def' return
- (:' (#AllT [#None "" "a"
- (#LambdaT [(#BoundT "a")
- (#LambdaT [CompilerState
- (#AppT [(#AppT [Either Text])
- (#TupleT (#Cons [CompilerState
- (#Cons [(#BoundT "a")
- #Nil])]))])])])])
- (lambda' _ val
- (lambda' _ state
- (#Right [state val])))))
+(_lux_def return
+ (_lux_: (#AllT [(#Some #Nil) "" "a"
+ (#LambdaT [(#BoundT "a")
+ (#LambdaT [Compiler
+ (#AppT [(#AppT [Either Text])
+ (#TupleT (#Cons [Compiler
+ (#Cons [(#BoundT "a")
+ #Nil])]))])])])])
+ (_lux_lambda _ val
+ (_lux_lambda _ state
+ (#Right [state val])))))
## (def (fail msg)
## (All [a]
-## (-> Text CompilerState
-## (Either Text (, CompilerState a))))
+## (-> Text Compiler
+## (Either Text (, Compiler a))))
## ...)
-(def' fail
- (:' (#AllT [#None "" "a"
- (#LambdaT [Text
- (#LambdaT [CompilerState
- (#AppT [(#AppT [Either Text])
- (#TupleT (#Cons [CompilerState
- (#Cons [(#BoundT "a")
- #Nil])]))])])])])
- (lambda' _ msg
- (lambda' _ state
- (#Left msg)))))
-
-(def' $text
- (:' (#LambdaT [Text Syntax])
- (lambda' _ text
- (_meta (#Text text)))))
-
-(def' $symbol
- (:' (#LambdaT [Ident Syntax])
- (lambda' _ ident
- (_meta (#Symbol ident)))))
-
-(def' $tag
- (:' (#LambdaT [Ident Syntax])
- (lambda' _ ident
- (_meta (#Tag ident)))))
-
-(def' $form
- (:' (#LambdaT [(#AppT [List Syntax]) Syntax])
- (lambda' _ tokens
- (_meta (#Form tokens)))))
-
-(def' $tuple
- (:' (#LambdaT [(#AppT [List Syntax]) Syntax])
- (lambda' _ tokens
- (_meta (#Tuple tokens)))))
-
-(def' $record
- (:' (#LambdaT [(#AppT [List (#TupleT (#Cons [Syntax (#Cons [Syntax #Nil])]))]) Syntax])
- (lambda' _ tokens
- (_meta (#Record tokens)))))
-
-(def' let'
- (:' Macro
- (lambda' _ tokens
- (case' tokens
- (#Cons [lhs (#Cons [rhs (#Cons [body #Nil])])])
- (return (:' SyntaxList
- (#Cons [($form (#Cons [($symbol ["" "case'"])
- (#Cons [rhs (#Cons [lhs (#Cons [body #Nil])])])]))
- #Nil])))
-
- _
- (fail "Wrong syntax for let'")))))
-(declare-macro' let')
-
-(def' lambda_
- (:' Macro
- (lambda' _ tokens
- (case' tokens
- (#Cons [(#Meta [_ (#Tuple (#Cons [arg args']))]) (#Cons [body #Nil])])
- (return (:' SyntaxList
- (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["" "lambda'"]))
- (#Cons [(_meta (#Symbol ["" ""]))
- (#Cons [arg
- (#Cons [(case' args'
- #Nil
- body
-
- _
- (_meta (#Form (#Cons [(_meta (#Symbol ["lux" "lambda_"]))
- (#Cons [(_meta (#Tuple args'))
- (#Cons [body #Nil])])]))))
- #Nil])])])])))
- #Nil])))
-
- (#Cons [(#Meta [_ (#Symbol self)]) (#Cons [(#Meta [_ (#Tuple (#Cons [arg args']))]) (#Cons [body #Nil])])])
- (return (:' SyntaxList
- (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["" "lambda'"]))
- (#Cons [(_meta (#Symbol self))
- (#Cons [arg
- (#Cons [(case' args'
- #Nil
- body
-
- _
- (_meta (#Form (#Cons [(_meta (#Symbol ["lux" "lambda_"]))
- (#Cons [(_meta (#Tuple args'))
- (#Cons [body #Nil])])]))))
- #Nil])])])])))
- #Nil])))
-
- _
- (fail "Wrong syntax for lambda")))))
-(declare-macro' lambda_)
-
-(def' def_
- (:' Macro
- (lambda_ [tokens]
- (case' tokens
- (#Cons [(#Meta [_ (#Tag ["" "export"])])
- (#Cons [(#Meta [_ (#Form (#Cons [name args]))])
- (#Cons [type (#Cons [body #Nil])])])])
- (return (:' SyntaxList
- (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["" "def'"]))
- (#Cons [name
- (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["" ":'"]))
- (#Cons [type
- (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["lux" "lambda_"]))
- (#Cons [name
- (#Cons [(_meta (#Tuple args))
- (#Cons [body #Nil])])])])))
- #Nil])])])))
- #Nil])])])))
- (#Cons [(_meta (#Form (#Cons [($symbol ["" "export'"]) (#Cons [name #Nil])])))
- #Nil])])))
-
- (#Cons [(#Meta [_ (#Tag ["" "export"])]) (#Cons [name (#Cons [type (#Cons [body #Nil])])])])
- (return (:' SyntaxList
- (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["" "def'"]))
- (#Cons [name
- (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["" ":'"]))
- (#Cons [type
- (#Cons [body
- #Nil])])])))
- #Nil])])])))
- (#Cons [(_meta (#Form (#Cons [($symbol ["" "export'"]) (#Cons [name #Nil])])))
- #Nil])])))
-
- (#Cons [(#Meta [_ (#Form (#Cons [name args]))])
- (#Cons [type (#Cons [body #Nil])])])
- (return (:' SyntaxList
- (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["" "def'"]))
- (#Cons [name
- (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["" ":'"]))
- (#Cons [type
- (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["lux" "lambda_"]))
- (#Cons [name
- (#Cons [(_meta (#Tuple args))
- (#Cons [body #Nil])])])])))
- #Nil])])])))
- #Nil])])])))
- #Nil])))
-
- (#Cons [name (#Cons [type (#Cons [body #Nil])])])
- (return (:' SyntaxList
- (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["" "def'"]))
- (#Cons [name
- (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["" ":'"]))
- (#Cons [type
- (#Cons [body
- #Nil])])])))
- #Nil])])])))
- #Nil])))
-
- _
- (fail "Wrong syntax for def")
- ))))
-(declare-macro' def_)
-
-(def_ #export (defmacro tokens)
+(_lux_def fail
+ (_lux_: (#AllT [(#Some #Nil) "" "a"
+ (#LambdaT [Text
+ (#LambdaT [Compiler
+ (#AppT [(#AppT [Either Text])
+ (#TupleT (#Cons [Compiler
+ (#Cons [(#BoundT "a")
+ #Nil])]))])])])])
+ (_lux_lambda _ msg
+ (_lux_lambda _ state
+ (#Left msg)))))
+
+(_lux_def text$
+ (_lux_: (#LambdaT [Text Syntax])
+ (_lux_lambda _ text
+ (_meta (#TextS text)))))
+
+(_lux_def symbol$
+ (_lux_: (#LambdaT [Ident Syntax])
+ (_lux_lambda _ ident
+ (_meta (#SymbolS ident)))))
+
+(_lux_def tag$
+ (_lux_: (#LambdaT [Ident Syntax])
+ (_lux_lambda _ ident
+ (_meta (#TagS ident)))))
+
+(_lux_def form$
+ (_lux_: (#LambdaT [(#AppT [List Syntax]) Syntax])
+ (_lux_lambda _ tokens
+ (_meta (#FormS tokens)))))
+
+(_lux_def tuple$
+ (_lux_: (#LambdaT [(#AppT [List Syntax]) Syntax])
+ (_lux_lambda _ tokens
+ (_meta (#TupleS tokens)))))
+
+(_lux_def record$
+ (_lux_: (#LambdaT [(#AppT [List (#TupleT (#Cons [Syntax (#Cons [Syntax #Nil])]))]) Syntax])
+ (_lux_lambda _ tokens
+ (_meta (#RecordS tokens)))))
+
+(_lux_def let'
+ (_lux_: Macro
+ (_lux_lambda _ tokens
+ (_lux_case tokens
+ (#Cons [lhs (#Cons [rhs (#Cons [body #Nil])])])
+ (return (#Cons [(form$ (#Cons [(symbol$ ["" "_lux_case"])
+ (#Cons [rhs (#Cons [lhs (#Cons [body #Nil])])])]))
+ #Nil]))
+
+ _
+ (fail "Wrong syntax for let'")))))
+(_lux_declare-macro let')
+
+(_lux_def lambda'
+ (_lux_: Macro
+ (_lux_lambda _ tokens
+ (_lux_case tokens
+ (#Cons [(#Meta [_ (#TupleS (#Cons [arg args']))]) (#Cons [body #Nil])])
+ (return (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_lambda"]))
+ (#Cons [(_meta (#SymbolS ["" ""]))
+ (#Cons [arg
+ (#Cons [(_lux_case args'
+ #Nil
+ body
+
+ _
+ (_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "lambda'"]))
+ (#Cons [(_meta (#TupleS args'))
+ (#Cons [body #Nil])])]))))
+ #Nil])])])])))
+ #Nil]))
+
+ (#Cons [(#Meta [_ (#SymbolS self)]) (#Cons [(#Meta [_ (#TupleS (#Cons [arg args']))]) (#Cons [body #Nil])])])
+ (return (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_lambda"]))
+ (#Cons [(_meta (#SymbolS self))
+ (#Cons [arg
+ (#Cons [(_lux_case args'
+ #Nil
+ body
+
+ _
+ (_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "lambda'"]))
+ (#Cons [(_meta (#TupleS args'))
+ (#Cons [body #Nil])])]))))
+ #Nil])])])])))
+ #Nil]))
+
+ _
+ (fail "Wrong syntax for lambda")))))
+(_lux_declare-macro lambda')
+
+(_lux_def def'
+ (_lux_: Macro
+ (lambda' [tokens]
+ (_lux_case tokens
+ (#Cons [(#Meta [_ (#TagS ["" "export"])])
+ (#Cons [(#Meta [_ (#FormS (#Cons [name args]))])
+ (#Cons [type (#Cons [body #Nil])])])])
+ (return (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_def"]))
+ (#Cons [name
+ (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_:"]))
+ (#Cons [type
+ (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "lambda'"]))
+ (#Cons [name
+ (#Cons [(_meta (#TupleS args))
+ (#Cons [body #Nil])])])])))
+ #Nil])])])))
+ #Nil])])])))
+ (#Cons [(_meta (#FormS (#Cons [(symbol$ ["" "_lux_export"]) (#Cons [name #Nil])])))
+ #Nil])]))
+
+ (#Cons [(#Meta [_ (#TagS ["" "export"])]) (#Cons [name (#Cons [type (#Cons [body #Nil])])])])
+ (return (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_def"]))
+ (#Cons [name
+ (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_:"]))
+ (#Cons [type
+ (#Cons [body
+ #Nil])])])))
+ #Nil])])])))
+ (#Cons [(_meta (#FormS (#Cons [(symbol$ ["" "_lux_export"]) (#Cons [name #Nil])])))
+ #Nil])]))
+
+ (#Cons [(#Meta [_ (#FormS (#Cons [name args]))])
+ (#Cons [type (#Cons [body #Nil])])])
+ (return (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_def"]))
+ (#Cons [name
+ (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_:"]))
+ (#Cons [type
+ (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "lambda'"]))
+ (#Cons [name
+ (#Cons [(_meta (#TupleS args))
+ (#Cons [body #Nil])])])])))
+ #Nil])])])))
+ #Nil])])])))
+ #Nil]))
+
+ (#Cons [name (#Cons [type (#Cons [body #Nil])])])
+ (return (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_def"]))
+ (#Cons [name
+ (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_:"]))
+ (#Cons [type
+ (#Cons [body
+ #Nil])])])))
+ #Nil])])])))
+ #Nil]))
+
+ _
+ (fail "Wrong syntax for def")
+ ))))
+(_lux_declare-macro def')
+
+(def' (defmacro tokens)
Macro
- (case' tokens
- (#Cons [(#Meta [_ (#Form (#Cons [name args]))]) (#Cons [body #Nil])])
- (return (:' SyntaxList
- (#Cons [($form (#Cons [($symbol ["lux" "def_"])
- (#Cons [($form (#Cons [name args]))
- (#Cons [($symbol ["lux" "Macro"])
- (#Cons [body
- #Nil])])
- ])]))
- (#Cons [($form (#Cons [($symbol ["" "declare-macro'"]) (#Cons [name #Nil])]))
- #Nil])])))
-
- (#Cons [(#Meta [_ (#Tag ["" "export"])]) (#Cons [(#Meta [_ (#Form (#Cons [name args]))]) (#Cons [body #Nil])])])
- (return (:' SyntaxList
- (#Cons [($form (#Cons [($symbol ["lux" "def_"])
- (#Cons [($tag ["" "export"])
- (#Cons [($form (#Cons [name args]))
- (#Cons [($symbol ["lux" "Macro"])
- (#Cons [body
- #Nil])])
- ])])]))
- (#Cons [($form (#Cons [($symbol ["" "declare-macro'"]) (#Cons [name #Nil])]))
- #Nil])])))
-
- _
- (fail "Wrong syntax for defmacro")))
-(declare-macro' defmacro)
+ (_lux_case tokens
+ (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) (#Cons [body #Nil])])
+ (return (#Cons [(form$ (#Cons [(symbol$ ["lux" "def'"])
+ (#Cons [(form$ (#Cons [name args]))
+ (#Cons [(symbol$ ["lux" "Macro"])
+ (#Cons [body
+ #Nil])])
+ ])]))
+ (#Cons [(form$ (#Cons [(symbol$ ["" "_lux_declare-macro"]) (#Cons [name #Nil])]))
+ #Nil])]))
+
+ (#Cons [(#Meta [_ (#TagS ["" "export"])]) (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) (#Cons [body #Nil])])])
+ (return (#Cons [(form$ (#Cons [(symbol$ ["lux" "def'"])
+ (#Cons [(tag$ ["" "export"])
+ (#Cons [(form$ (#Cons [name args]))
+ (#Cons [(symbol$ ["lux" "Macro"])
+ (#Cons [body
+ #Nil])])
+ ])])]))
+ (#Cons [(form$ (#Cons [(symbol$ ["" "_lux_declare-macro"]) (#Cons [name #Nil])]))
+ #Nil])]))
+
+ _
+ (fail "Wrong syntax for defmacro")))
+(_lux_declare-macro defmacro)
(defmacro #export (comment tokens)
- (return (:' SyntaxList #Nil)))
+ (return #Nil))
(defmacro (->' tokens)
- (case' tokens
- (#Cons [input (#Cons [output #Nil])])
- (return (:' SyntaxList
- (#Cons [(_meta (#Form (#Cons [(_meta (#Tag ["lux" "LambdaT"]))
- (#Cons [(_meta (#Tuple (#Cons [input (#Cons [output #Nil])])))
- #Nil])])))
- #Nil])))
-
- (#Cons [input (#Cons [output others])])
- (return (:' SyntaxList
- (#Cons [(_meta (#Form (#Cons [(_meta (#Tag ["lux" "LambdaT"]))
- (#Cons [(_meta (#Tuple (#Cons [input
- (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["lux" "->'"]))
- (#Cons [output others])])))
- #Nil])])))
- #Nil])])))
- #Nil])))
-
- _
- (fail "Wrong syntax for ->'")))
+ (_lux_case tokens
+ (#Cons [input (#Cons [output #Nil])])
+ (return (#Cons [(_meta (#FormS (#Cons [(_meta (#TagS ["lux" "LambdaT"]))
+ (#Cons [(_meta (#TupleS (#Cons [input (#Cons [output #Nil])])))
+ #Nil])])))
+ #Nil]))
+
+ (#Cons [input (#Cons [output others])])
+ (return (#Cons [(_meta (#FormS (#Cons [(_meta (#TagS ["lux" "LambdaT"]))
+ (#Cons [(_meta (#TupleS (#Cons [input
+ (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "->'"]))
+ (#Cons [output others])])))
+ #Nil])])))
+ #Nil])])))
+ #Nil]))
+
+ _
+ (fail "Wrong syntax for ->'")))
(defmacro (All' tokens)
- (case' tokens
- (#Cons [(#Meta [_ (#Tuple #Nil)])
- (#Cons [body #Nil])])
- (return (:' SyntaxList
- (#Cons [body
- #Nil])))
-
- (#Cons [(#Meta [_ (#Tuple (#Cons [(#Meta [_ (#Symbol ["" arg-name])]) other-args]))])
- (#Cons [body #Nil])])
- (return (:' SyntaxList
- (#Cons [(_meta (#Form (#Cons [(_meta (#Tag ["lux" "AllT"]))
- (#Cons [(_meta (#Tuple (#Cons [(_meta (#Tag ["lux" "None"]))
- (#Cons [(_meta (#Text ""))
- (#Cons [(_meta (#Text arg-name))
- (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["lux" "All'"]))
- (#Cons [(_meta (#Tuple other-args))
- (#Cons [body
- #Nil])])])))
- #Nil])])])])))
- #Nil])])))
- #Nil])))
-
- _
- (fail "Wrong syntax for All'")))
+ (_lux_case tokens
+ (#Cons [(#Meta [_ (#TupleS #Nil)])
+ (#Cons [body #Nil])])
+ (return (#Cons [body
+ #Nil]))
+
+ (#Cons [(#Meta [_ (#TupleS (#Cons [(#Meta [_ (#SymbolS ["" arg-name])]) other-args]))])
+ (#Cons [body #Nil])])
+ (return (#Cons [(_meta (#FormS (#Cons [(_meta (#TagS ["lux" "AllT"]))
+ (#Cons [(_meta (#TupleS (#Cons [(_meta (#TagS ["lux" "None"]))
+ (#Cons [(_meta (#TextS ""))
+ (#Cons [(_meta (#TextS arg-name))
+ (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "All'"]))
+ (#Cons [(_meta (#TupleS other-args))
+ (#Cons [body
+ #Nil])])])))
+ #Nil])])])])))
+ #Nil])])))
+ #Nil]))
+
+ _
+ (fail "Wrong syntax for All'")))
(defmacro (B' tokens)
- (case' tokens
- (#Cons [(#Meta [_ (#Symbol ["" bound-name])])
- #Nil])
- (return (:' SyntaxList
- (#Cons [(_meta (#Form (#Cons [(_meta (#Tag ["lux" "BoundT"]))
- (#Cons [(_meta (#Text bound-name))
- #Nil])])))
- #Nil])))
-
- _
- (fail "Wrong syntax for B'")))
+ (_lux_case tokens
+ (#Cons [(#Meta [_ (#SymbolS ["" bound-name])])
+ #Nil])
+ (return (#Cons [(_meta (#FormS (#Cons [(_meta (#TagS ["lux" "BoundT"]))
+ (#Cons [(_meta (#TextS bound-name))
+ #Nil])])))
+ #Nil]))
+
+ _
+ (fail "Wrong syntax for B'")))
(defmacro ($' tokens)
- (case' tokens
- (#Cons [x #Nil])
- (return tokens)
-
- (#Cons [x (#Cons [y xs])])
- (return (:' SyntaxList
- (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["lux" "$'"]))
- (#Cons [(_meta (#Form (#Cons [(_meta (#Tag ["lux" "AppT"]))
- (#Cons [(_meta (#Tuple (#Cons [x (#Cons [y #Nil])])))
- #Nil])])))
- xs])])))
- #Nil])))
-
- _
- (fail "Wrong syntax for $'")))
-
-(def_ #export (fold f init xs)
+ (_lux_case tokens
+ (#Cons [x #Nil])
+ (return tokens)
+
+ (#Cons [x (#Cons [y xs])])
+ (return (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "$'"]))
+ (#Cons [(_meta (#FormS (#Cons [(_meta (#TagS ["lux" "AppT"]))
+ (#Cons [(_meta (#TupleS (#Cons [x (#Cons [y #Nil])])))
+ #Nil])])))
+ xs])])))
+ #Nil]))
+
+ _
+ (fail "Wrong syntax for $'")))
+
+(def' (foldL f init xs)
(All' [a b]
(->' (->' (B' a) (B' b) (B' a))
(B' a)
($' List (B' b))
(B' a)))
- (case' xs
- #Nil
- init
+ (_lux_case xs
+ #Nil
+ init
- (#Cons [x xs'])
- (fold f (f init x) xs')))
+ (#Cons [x xs'])
+ (foldL f (f init x) xs')))
-(def_ #export (reverse list)
+(def' (reverse list)
(All' [a]
(->' ($' List (B' a)) ($' List (B' a))))
- (fold (:' (All' [a]
- (->' ($' List (B' a)) (B' a) ($' List (B' a))))
- (lambda_ [tail head]
- (#Cons [head tail])))
- #Nil
- list))
-
-(defmacro #export (list xs)
- (return (:' SyntaxList
- (#Cons [(fold (:' (->' Syntax Syntax Syntax)
- (lambda_ [tail head]
- (_meta (#Form (#Cons [(_meta (#Tag ["lux" "Cons"]))
- (#Cons [(_meta (#Tuple (#Cons [head (#Cons [tail #Nil])])))
- #Nil])])))))
- (_meta (#Tag ["lux" "Nil"]))
- (reverse xs))
- #Nil]))))
-
-(defmacro #export (list& xs)
- (case' (reverse xs)
- (#Cons [last init])
- (return (:' SyntaxList
- (list (fold (:' (->' Syntax Syntax Syntax)
- (lambda_ [tail head]
- (_meta (#Form (list (_meta (#Tag ["lux" "Cons"]))
- (_meta (#Tuple (list head tail))))))))
- last
- init))))
-
- _
- (fail "Wrong syntax for list&")))
+ (foldL (lambda' [tail head] (#Cons [head tail]))
+ #Nil
+ list))
+
+(defmacro (list xs)
+ (return (#Cons [(foldL (lambda' [tail head]
+ (_meta (#FormS (#Cons [(_meta (#TagS ["lux" "Cons"]))
+ (#Cons [(_meta (#TupleS (#Cons [head (#Cons [tail #Nil])])))
+ #Nil])]))))
+ (_meta (#TagS ["lux" "Nil"]))
+ (reverse xs))
+ #Nil])))
+
+(defmacro (list& xs)
+ (_lux_case (reverse xs)
+ (#Cons [last init])
+ (return (list (foldL (lambda' [tail head]
+ (_meta (#FormS (list (_meta (#TagS ["lux" "Cons"]))
+ (_meta (#TupleS (list head tail)))))))
+ last
+ init)))
+
+ _
+ (fail "Wrong syntax for list&")))
(defmacro #export (lambda tokens)
- (let' [name tokens'] (:' (#TupleT (list Ident ($' List Syntax)))
- (case' tokens
- (#Cons [(#Meta [_ (#Symbol name)]) tokens'])
- [name tokens']
+ (let' [name tokens'] (_lux_: (#TupleT (list Ident ($' List Syntax)))
+ (_lux_case tokens
+ (#Cons [(#Meta [_ (#SymbolS name)]) tokens'])
+ [name tokens']
- _
- [["" ""] tokens]))
- (case' tokens'
- (#Cons [(#Meta [_ (#Tuple args)]) (#Cons [body #Nil])])
- (case' args
- #Nil
- (fail "lambda requires a non-empty arguments tuple.")
-
- (#Cons [harg targs])
- (let' body' (fold (:' (->' Syntax Syntax Syntax)
- (lambda_ [body' arg]
- ($form (list ($symbol ["" "lambda'"])
- ($symbol ["" ""])
- arg
- body'))))
- body
- (reverse targs))
- (return (:' SyntaxList
- (list ($form (list ($symbol ["" "lambda'"])
- ($symbol name)
- harg
- body')))))))
+ _
+ [["" ""] tokens]))
+ (_lux_case tokens'
+ (#Cons [(#Meta [_ (#TupleS args)]) (#Cons [body #Nil])])
+ (_lux_case args
+ #Nil
+ (fail "lambda requires a non-empty arguments tuple.")
+
+ (#Cons [harg targs])
+ (return (list (form$ (list (symbol$ ["" "_lux_lambda"])
+ (symbol$ name)
+ harg
+ (foldL (lambda' [body' arg]
+ (form$ (list (symbol$ ["" "_lux_lambda"])
+ (symbol$ ["" ""])
+ arg
+ body')))
+ body
+ (reverse targs)))))))
+
+ _
+ (fail "Wrong syntax for lambda"))))
+
+(defmacro (def'' tokens)
+ (_lux_case tokens
+ (#Cons [(#Meta [_ (#TagS ["" "export"])])
+ (#Cons [(#Meta [_ (#FormS (#Cons [name args]))])
+ (#Cons [type (#Cons [body #Nil])])])])
+ (return (list (form$ (list (symbol$ ["" "_lux_def"])
+ name
+ (form$ (list (symbol$ ["" "_lux_:"])
+ type
+ (form$ (list (symbol$ ["lux" "lambda"])
+ name
+ (tuple$ args)
+ body))))))
+ (form$ (list (symbol$ ["" "_lux_export"]) name))))
+
+ (#Cons [(#Meta [_ (#TagS ["" "export"])]) (#Cons [name (#Cons [type (#Cons [body #Nil])])])])
+ (return (list (form$ (list (symbol$ ["" "_lux_def"])
+ name
+ (form$ (list (symbol$ ["" "_lux_:"])
+ type
+ body))))
+ (form$ (list (symbol$ ["" "_lux_export"]) name))))
+
+ (#Cons [(#Meta [_ (#FormS (#Cons [name args]))])
+ (#Cons [type (#Cons [body #Nil])])])
+ (return (list (form$ (list (symbol$ ["" "_lux_def"])
+ name
+ (form$ (list (symbol$ ["" "_lux_:"])
+ type
+ (form$ (list (symbol$ ["lux" "lambda"])
+ name
+ (tuple$ args)
+ body))))))))
+
+ (#Cons [name (#Cons [type (#Cons [body #Nil])])])
+ (return (list (form$ (list (symbol$ ["" "_lux_def"])
+ name
+ (form$ (list (symbol$ ["" "_lux_:"]) type body))))))
- _
- (fail "Wrong syntax for lambda"))))
-
-(defmacro (def__ tokens)
- (case' tokens
- (#Cons [(#Meta [_ (#Tag ["" "export"])])
- (#Cons [(#Meta [_ (#Form (#Cons [name args]))])
- (#Cons [type (#Cons [body #Nil])])])])
- (return (:' SyntaxList
- (list ($form (list ($symbol ["" "def'"])
- name
- ($form (list ($symbol ["" ":'"])
- type
- ($form (list ($symbol ["lux" "lambda"])
- name
- ($tuple args)
- body))))))
- ($form (list ($symbol ["" "export'"]) name)))))
-
- (#Cons [(#Meta [_ (#Tag ["" "export"])]) (#Cons [name (#Cons [type (#Cons [body #Nil])])])])
- (return (:' SyntaxList
- (list ($form (list ($symbol ["" "def'"])
- name
- ($form (list ($symbol ["" ":'"])
- type
- body))))
- ($form (list ($symbol ["" "export'"]) name)))))
-
- (#Cons [(#Meta [_ (#Form (#Cons [name args]))])
- (#Cons [type (#Cons [body #Nil])])])
- (return (:' SyntaxList
- (list ($form (list ($symbol ["" "def'"])
- name
- ($form (list ($symbol ["" ":'"])
- type
- ($form (list ($symbol ["lux" "lambda"])
- name
- ($tuple args)
- body)))))))))
-
- (#Cons [name (#Cons [type (#Cons [body #Nil])])])
- (return (:' SyntaxList
- (list ($form (list ($symbol ["" "def'"])
- name
- ($form (list ($symbol ["" ":'"]) type body)))))))
-
- _
- (fail "Wrong syntax for def")
- ))
-
-(def__ (as-pairs xs)
+ _
+ (fail "Wrong syntax for def")
+ ))
+
+(def'' (as-pairs xs)
(All' [a]
(->' ($' List (B' a)) ($' List (#TupleT (list (B' a) (B' a))))))
- (case' xs
- (#Cons [x (#Cons [y xs'])])
- (#Cons [[x y] (as-pairs xs')])
+ (_lux_case xs
+ (#Cons [x (#Cons [y xs'])])
+ (#Cons [[x y] (as-pairs xs')])
- _
- #Nil))
+ _
+ #Nil))
(defmacro #export (let tokens)
- (case' tokens
- (#Cons [(#Meta [_ (#Tuple bindings)]) (#Cons [body #Nil])])
- (return (:' SyntaxList
- (list (fold (:' (->' Syntax (#TupleT (list Syntax Syntax))
- Syntax)
- (lambda [body binding]
- (case' binding
- [label value]
- (_meta (#Form (list (_meta (#Symbol ["lux" "let'"])) label value body))))))
- body
- (fold (:' (->' ($' List (#TupleT (list Syntax Syntax))) (#TupleT (list Syntax Syntax))
- ($' List (#TupleT (list Syntax Syntax))))
- (lambda [tail head]
- (#Cons [head tail])))
- #Nil
- (as-pairs bindings))))))
-
- _
- (fail "Wrong syntax for let")))
-
-(def__ #export (map f xs)
+ (_lux_case tokens
+ (#Cons [(#Meta [_ (#TupleS bindings)]) (#Cons [body #Nil])])
+ (return (list (foldL (_lux_: (->' Syntax (#TupleT (list Syntax Syntax))
+ Syntax)
+ (lambda [body binding]
+ (_lux_case binding
+ [label value]
+ (form$ (list (symbol$ ["" "_lux_case"]) value label body)))))
+ body
+ (reverse (as-pairs bindings)))))
+
+ _
+ (fail "Wrong syntax for let")))
+
+(def'' (map f xs)
(All' [a b]
(->' (->' (B' a) (B' b)) ($' List (B' a)) ($' List (B' b))))
- (case' xs
- #Nil
- #Nil
+ (_lux_case xs
+ #Nil
+ #Nil
- (#Cons [x xs'])
- (#Cons [(f x) (map f xs')])))
+ (#Cons [x xs'])
+ (#Cons [(f x) (map f xs')])))
-(def__ #export (any? p xs)
+(def'' (any? p xs)
(All' [a]
(->' (->' (B' a) Bool) ($' List (B' a)) Bool))
- (case' xs
- #Nil
- false
+ (_lux_case xs
+ #Nil
+ false
- (#Cons [x xs'])
- (case' (p x)
- true true
- false (any? p xs'))))
+ (#Cons [x xs'])
+ (_lux_case (p x)
+ true true
+ false (any? p xs'))))
-(def__ (spliced? token)
+(def'' (spliced? token)
(->' Syntax Bool)
- (case' token
- (#Meta [_ (#Form (#Cons [(#Meta [_ (#Symbol ["" "~@"])]) (#Cons [_ #Nil])]))])
- true
+ (_lux_case token
+ (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS ["" "~@"])]) (#Cons [_ #Nil])]))])
+ true
- _
- false))
+ _
+ false))
-(def__ (wrap-meta content)
+(def'' (wrap-meta content)
(->' Syntax Syntax)
- (_meta (#Form (list (_meta (#Tag ["lux" "Meta"]))
- (_meta (#Tuple (list (_meta (#Tuple (list (_meta (#Text "")) (_meta (#Int -1)) (_meta (#Int -1)))))
- content)))))))
+ (_meta (#FormS (list (_meta (#TagS ["lux" "Meta"]))
+ (_meta (#TupleS (list (_meta (#TupleS (list (_meta (#TextS "")) (_meta (#IntS -1)) (_meta (#IntS -1)))))
+ content)))))))
-(def__ (untemplate-list tokens)
+(def'' (untemplate-list tokens)
(->' ($' List Syntax) Syntax)
- (case' tokens
- #Nil
- (_meta (#Tag ["lux" "Nil"]))
+ (_lux_case tokens
+ #Nil
+ (_meta (#TagS ["lux" "Nil"]))
- (#Cons [token tokens'])
- (_meta (#Form (list (_meta (#Tag ["lux" "Cons"]))
- (_meta (#Tuple (list token (untemplate-list tokens')))))))))
+ (#Cons [token tokens'])
+ (_meta (#FormS (list (_meta (#TagS ["lux" "Cons"]))
+ (_meta (#TupleS (list token (untemplate-list tokens')))))))))
-(def__ (list:++ xs ys)
+(def'' #export (list:++ xs ys)
(All' [a] (->' ($' List (B' a)) ($' List (B' a)) ($' List (B' a))))
- (case' xs
- (#Cons [x xs'])
- (#Cons [x (list:++ xs' ys)])
+ (_lux_case xs
+ (#Cons [x xs'])
+ (#Cons [x (list:++ xs' ys)])
- #Nil
- ys))
+ #Nil
+ ys))
(defmacro #export ($ tokens)
- (case' tokens
- (#Cons [op (#Cons [init args])])
- (return (:' SyntaxList
- (list (fold (:' (->' Syntax Syntax Syntax)
- (lambda [a1 a2]
- ($form (list op a1 a2))))
- init
- args))))
-
- _
- (fail "Wrong syntax for $")))
-
-(def__ (splice untemplate tag elems)
- (->' (->' Syntax Syntax) Syntax ($' List Syntax) Syntax)
- (case' (any? spliced? elems)
- true
- (let [elems' (map (:' (->' Syntax Syntax)
- (lambda [elem]
- (case' elem
- (#Meta [_ (#Form (#Cons [(#Meta [_ (#Symbol ["" "~@"])]) (#Cons [spliced #Nil])]))])
- spliced
-
- _
- ($form (list ($symbol ["" ":'"])
- ($symbol ["lux" "SyntaxList"])
- ($form (list ($symbol ["lux" "list"]) (untemplate elem))))))))
- elems)]
- (wrap-meta ($form (list tag
- ($form (list& ($symbol ["lux" "$"])
- ($symbol ["lux" "list:++"])
- elems'))))))
-
- false
- (wrap-meta ($form (list tag (untemplate-list (map untemplate elems)))))))
-
-(def__ (untemplate subst token)
- (->' Text Syntax Syntax)
- (case' token
- (#Meta [_ (#Bool value)])
- (wrap-meta ($form (list ($tag ["lux" "Bool"]) (_meta (#Bool value)))))
-
- (#Meta [_ (#Int value)])
- (wrap-meta ($form (list ($tag ["lux" "Int"]) (_meta (#Int value)))))
-
- (#Meta [_ (#Real value)])
- (wrap-meta ($form (list ($tag ["lux" "Real"]) (_meta (#Real value)))))
-
- (#Meta [_ (#Char value)])
- (wrap-meta ($form (list ($tag ["lux" "Char"]) (_meta (#Char value)))))
-
- (#Meta [_ (#Text value)])
- (wrap-meta ($form (list ($tag ["lux" "Text"]) (_meta (#Text value)))))
-
- (#Meta [_ (#Tag [module name])])
- (let [module' (case' module
- ""
- subst
-
- _
- module)]
- (wrap-meta ($form (list ($tag ["lux" "Tag"]) ($tuple (list ($text module') ($text name)))))))
-
- (#Meta [_ (#Symbol [module name])])
- (let [module' (case' module
- ""
- subst
-
- _
- module)]
- (wrap-meta ($form (list ($tag ["lux" "Symbol"]) ($tuple (list ($text module') ($text name)))))))
-
- (#Meta [_ (#Tuple elems)])
- (splice (untemplate subst) ($tag ["lux" "Tuple"]) elems)
-
- (#Meta [_ (#Form (#Cons [(#Meta [_ (#Symbol ["" "~"])]) (#Cons [unquoted #Nil])]))])
- unquoted
-
- (#Meta [_ (#Form elems)])
- (splice (untemplate subst) ($tag ["lux" "Form"]) elems)
-
- (#Meta [_ (#Record fields)])
- (wrap-meta ($form (list ($tag ["lux" "Record"])
- (untemplate-list (map (:' (->' (#TupleT (list Syntax Syntax)) Syntax)
- (lambda [kv]
- (let [[k v] kv]
- ($tuple (list (untemplate subst k) (untemplate subst v))))))
- fields)))))
- ))
+ (_lux_case tokens
+ (#Cons [op (#Cons [init args])])
+ (return (list (foldL (lambda [a1 a2] (form$ (list op a1 a2)))
+ init
+ args)))
+
+ _
+ (fail "Wrong syntax for $")))
+
+(def'' (splice replace? untemplate tag elems)
+ (->' Bool (->' Syntax Syntax) Syntax ($' List Syntax) Syntax)
+ (_lux_case replace?
+ true
+ (_lux_case (any? spliced? elems)
+ true
+ (let [elems' (map (lambda [elem]
+ (_lux_case elem
+ (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS ["" "~@"])]) (#Cons [spliced #Nil])]))])
+ spliced
+
+ _
+ (form$ (list (symbol$ ["" "_lux_:"])
+ (form$ (list (tag$ ["lux" "AppT"]) (tuple$ (list (symbol$ ["lux" "List"]) (symbol$ ["lux" "Syntax"])))))
+ (form$ (list (tag$ ["lux" "Cons"]) (tuple$ (list (untemplate elem)
+ (tag$ ["lux" "Nil"])))))))))
+ elems)]
+ (wrap-meta (form$ (list tag
+ (form$ (list& (symbol$ ["lux" "$"])
+ (symbol$ ["lux" "list:++"])
+ elems'))))))
+
+ false
+ (wrap-meta (form$ (list tag (untemplate-list (map untemplate elems))))))
+ false
+ (wrap-meta (form$ (list tag (untemplate-list (map untemplate elems)))))))
+
+(def'' (untemplate replace? subst token)
+ (->' Bool Text Syntax Syntax)
+ (_lux_case (_lux_: (#TupleT (list Bool Syntax)) [replace? token])
+ [_ (#Meta [_ (#BoolS value)])]
+ (wrap-meta (form$ (list (tag$ ["lux" "BoolS"]) (_meta (#BoolS value)))))
+
+ [_ (#Meta [_ (#IntS value)])]
+ (wrap-meta (form$ (list (tag$ ["lux" "IntS"]) (_meta (#IntS value)))))
+
+ [_ (#Meta [_ (#RealS value)])]
+ (wrap-meta (form$ (list (tag$ ["lux" "RealS"]) (_meta (#RealS value)))))
+
+ [_ (#Meta [_ (#CharS value)])]
+ (wrap-meta (form$ (list (tag$ ["lux" "CharS"]) (_meta (#CharS value)))))
+
+ [_ (#Meta [_ (#TextS value)])]
+ (wrap-meta (form$ (list (tag$ ["lux" "TextS"]) (_meta (#TextS value)))))
+
+ [_ (#Meta [_ (#TagS [module name])])]
+ (let [module' (_lux_case module
+ ""
+ subst
+
+ _
+ module)]
+ (wrap-meta (form$ (list (tag$ ["lux" "TagS"]) (tuple$ (list (text$ module') (text$ name)))))))
+
+ [_ (#Meta [_ (#SymbolS [module name])])]
+ (let [module' (_lux_case module
+ ""
+ subst
+
+ _
+ module)]
+ (wrap-meta (form$ (list (tag$ ["lux" "SymbolS"]) (tuple$ (list (text$ module') (text$ name)))))))
+
+ [_ (#Meta [_ (#TupleS elems)])]
+ (splice replace? (untemplate replace? subst) (tag$ ["lux" "TupleS"]) elems)
+
+ [true (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS ["" "~"])]) (#Cons [unquoted #Nil])]))])]
+ unquoted
+
+ [_ (#Meta [meta (#FormS elems)])]
+ (let [(#Meta [_ form']) (splice replace? (untemplate replace? subst) (tag$ ["lux" "FormS"]) elems)]
+ (#Meta [meta form']))
+
+ [_ (#Meta [_ (#RecordS fields)])]
+ (wrap-meta (form$ (list (tag$ ["lux" "RecordS"])
+ (untemplate-list (map (_lux_: (->' (#TupleT (list Syntax Syntax)) Syntax)
+ (lambda [kv]
+ (let [[k v] kv]
+ (tuple$ (list (untemplate replace? subst k) (untemplate replace? subst v))))))
+ fields)))))
+ ))
(defmacro (`' tokens)
- (case' tokens
- (#Cons [template #Nil])
- (return (:' SyntaxList
- (list (untemplate "" template))))
+ (_lux_case tokens
+ (#Cons [template #Nil])
+ (return (list (untemplate true "" template)))
+
+ _
+ (fail "Wrong syntax for `'")))
- _
- (fail "Wrong syntax for `'")))
+(defmacro (' tokens)
+ (_lux_case tokens
+ (#Cons [template #Nil])
+ (return (list (untemplate false "" template)))
+
+ _
+ (fail "Wrong syntax for '")))
(defmacro #export (|> tokens)
- (case' tokens
- (#Cons [init apps])
- (return (:' SyntaxList
- (list (fold (:' (->' Syntax Syntax Syntax)
- (lambda [acc app]
- (case' app
- (#Meta [_ (#Form parts)])
- ($form (list:++ parts (list acc)))
-
- _
- (`' ((~ app) (~ acc))))))
- init
- apps))))
-
- _
- (fail "Wrong syntax for |>")))
+ (_lux_case tokens
+ (#Cons [init apps])
+ (return (list (foldL (lambda [acc app]
+ (_lux_case app
+ (#Meta [_ (#TupleS parts)])
+ (tuple$ (list:++ parts (list acc)))
+
+ (#Meta [_ (#FormS parts)])
+ (form$ (list:++ parts (list acc)))
+
+ _
+ (`' ((~ app) (~ acc)))))
+ init
+ apps)))
+
+ _
+ (fail "Wrong syntax for |>")))
(defmacro #export (if tokens)
- (case' tokens
- (#Cons [test (#Cons [then (#Cons [else #Nil])])])
- (return (:' SyntaxList
- (list (`' (case' (~ test)
- true (~ then)
- false (~ else))))))
+ (_lux_case tokens
+ (#Cons [test (#Cons [then (#Cons [else #Nil])])])
+ (return (list (`' (_lux_case (~ test)
+ true (~ then)
+ false (~ else)))))
- _
- (fail "Wrong syntax for if")))
+ _
+ (fail "Wrong syntax for if")))
## (deftype (Lux a)
-## (-> CompilerState (Either Text (, CompilerState a))))
-(def__ #export Lux
+## (-> Compiler (Either Text (, Compiler a))))
+(def'' #export Lux
Type
(All' [a]
- (->' CompilerState ($' Either Text (#TupleT (list CompilerState (B' a)))))))
+ (->' Compiler ($' Either Text (#TupleT (list Compiler (B' a)))))))
## (defsig (Monad m)
## (: (All [a] (-> a (m a)))
## return)
## (: (All [a b] (-> (-> a (m b)) (m a) (m b)))
## bind))
-(def__ Monad
+(def'' Monad
Type
(All' [m]
(#RecordT (list ["lux;return" (All' [a] (->' (B' a) ($' (B' m) (B' a))))]
@@ -939,7 +938,7 @@
($' (B' m) (B' a))
($' (B' m) (B' b))))]))))
-(def__ Maybe:Monad
+(def'' Maybe/Monad
($' Monad Maybe)
{#lux;return
(lambda return [x]
@@ -947,79 +946,73 @@
#lux;bind
(lambda [f ma]
- (case' ma
- #None #None
- (#Some a) (f a)))})
+ (_lux_case ma
+ #None #None
+ (#Some a) (f a)))})
-(def__ Lux:Monad
+(def'' Lux/Monad
($' Monad Lux)
{#lux;return
- (lambda return [x]
- (lambda [state]
- (#Right [state x])))
+ (lambda [x]
+ (lambda [state]
+ (#Right [state x])))
#lux;bind
(lambda [f ma]
(lambda [state]
- (case' (ma state)
- (#Left msg)
- (#Left msg)
+ (_lux_case (ma state)
+ (#Left msg)
+ (#Left msg)
- (#Right [state' a])
- (f a state'))))})
+ (#Right [state' a])
+ (f a state'))))})
(defmacro #export (^ tokens)
- (case' tokens
- (#Cons [(#Meta [_ (#Symbol ["" class-name])]) #Nil])
- (return (:' SyntaxList
- (list (`' (#;DataT (~ (_meta (#Text class-name))))))))
+ (_lux_case tokens
+ (#Cons [(#Meta [_ (#SymbolS ["" class-name])]) #Nil])
+ (return (list (`' (#;DataT (~ (_meta (#TextS class-name)))))))
- _
- (fail "Wrong syntax for ^")))
+ _
+ (fail "Wrong syntax for ^")))
(defmacro #export (-> tokens)
- (case' (reverse tokens)
- (#Cons [output inputs])
- (return (:' SyntaxList
- (list (fold (:' (->' Syntax Syntax Syntax)
- (lambda [o i]
- (`' (#;LambdaT [(~ i) (~ o)]))))
- output
- inputs))))
-
- _
- (fail "Wrong syntax for ->")))
+ (_lux_case (reverse tokens)
+ (#Cons [output inputs])
+ (return (list (foldL (lambda [o i] (`' (#;LambdaT [(~ i) (~ o)])))
+ output
+ inputs)))
+
+ _
+ (fail "Wrong syntax for ->")))
(defmacro #export (, tokens)
- (return (:' SyntaxList
- (list (`' (#;TupleT (;list (~@ tokens))))))))
+ (return (list (`' (#;TupleT (~ (untemplate-list tokens)))))))
(defmacro (do tokens)
- (case' tokens
- (#Cons [monad (#Cons [(#Meta [_ (#Tuple bindings)]) (#Cons [body #Nil])])])
- (let [body' (fold (:' (-> Syntax (, Syntax Syntax) Syntax)
+ (_lux_case tokens
+ (#Cons [monad (#Cons [(#Meta [_ (#TupleS bindings)]) (#Cons [body #Nil])])])
+ (let [body' (foldL (_lux_: (-> Syntax (, Syntax Syntax) Syntax)
(lambda [body' binding]
(let [[var value] binding]
- (case' var
- (#Meta [_ (#Tag ["" "let"])])
- (`' (;let (~ value) (~ body')))
-
- _
- (`' (;bind (lambda' (~ ($symbol ["" ""]))
- (~ var)
- (~ body'))
- (~ value)))))))
- body
- (reverse (as-pairs bindings)))]
- (return (:' SyntaxList
- (list (`' (case' (~ monad)
- {#;return ;return #;bind ;bind}
- (~ body')))))))
-
- _
- (fail "Wrong syntax for do")))
-
-(def__ (map% m f xs)
+ (_lux_case var
+ (#Meta [_ (#TagS ["" "let"])])
+ (`' (;let (~ value) (~ body')))
+
+ _
+ (`' (;bind (_lux_lambda (~ (symbol$ ["" ""]))
+ (~ var)
+ (~ body'))
+ (~ value)))))))
+ body
+ (reverse (as-pairs bindings)))]
+ (return (list (`' (_lux_case (~ monad)
+ {#;return ;return #;bind ;bind}
+ (~ body'))))))
+
+ _
+ (fail "Wrong syntax for do")))
+
+(def'' (map% m f xs)
## (All [m a b]
## (-> (Monad m) (-> a (m b)) (List a) (m (List b))))
(All' [m a b]
@@ -1028,617 +1021,637 @@
($' List (B' a))
($' (B' m) ($' List (B' b)))))
(let [{#;return ;return #;bind _} m]
- (case' xs
- #Nil
- (;return (:' List #Nil))
-
- (#Cons [x xs'])
- (do m
- [y (f x)
- ys (map% m f xs')]
- (;return (:' List (#Cons [y ys]))))
- )))
-
-(def__ #export (. f g)
+ (_lux_case xs
+ #Nil
+ (;return #Nil)
+
+ (#Cons [x xs'])
+ (do m
+ [y (f x)
+ ys (map% m f xs')]
+ (;return (#Cons [y ys])))
+ )))
+
+(def'' #export (. f g)
(All' [a b c]
(-> (-> (B' b) (B' c)) (-> (B' a) (B' b)) (-> (B' a) (B' c))))
(lambda [x]
(f (g x))))
-(def__ (get-ident x)
+(def'' (get-ident x)
(-> Syntax ($' Maybe Text))
- (case' x
- (#Meta [_ (#Symbol ["" sname])])
- (#Some sname)
+ (_lux_case x
+ (#Meta [_ (#SymbolS ["" sname])])
+ (#Some sname)
- _
- #None))
+ _
+ #None))
-(def__ (tuple->list tuple)
+(def'' (tuple->list tuple)
(-> Syntax ($' Maybe ($' List Syntax)))
- (case' tuple
- (#Meta [_ (#Tuple members)])
- (#Some members)
+ (_lux_case tuple
+ (#Meta [_ (#TupleS members)])
+ (#Some members)
- _
- #None))
+ _
+ #None))
-(def__ RepEnv
+(def'' RepEnv
Type
($' List (, Text Syntax)))
-(def__ (make-env xs ys)
+(def'' (make-env xs ys)
(-> ($' List Text) ($' List Syntax) RepEnv)
- (case' (:' (, ($' List Text) ($' List Syntax))
- [xs ys])
- [(#Cons [x xs']) (#Cons [y ys'])]
- (#Cons [[x y] (make-env xs' ys')])
+ (_lux_case (_lux_: (, ($' List Text) ($' List Syntax))
+ [xs ys])
+ [(#Cons [x xs']) (#Cons [y ys'])]
+ (#Cons [[x y] (make-env xs' ys')])
- _
- #Nil))
+ _
+ #Nil))
-(def__ (text:= x y)
+(def'' (text:= x y)
(-> Text Text Bool)
- (jvm-invokevirtual java.lang.Object equals [java.lang.Object]
- x [y]))
+ (_jvm_invokevirtual "java.lang.Object" "equals" ["java.lang.Object"]
+ x [y]))
-(def__ (get-rep key env)
+(def'' (get-rep key env)
(-> Text RepEnv ($' Maybe Syntax))
- (case' env
- #Nil
- #None
+ (_lux_case env
+ #Nil
+ #None
- (#Cons [[k v] env'])
- (if (text:= k key)
- (#Some v)
- (get-rep key env'))))
+ (#Cons [[k v] env'])
+ (if (text:= k key)
+ (#Some v)
+ (get-rep key env'))))
-(def__ (apply-template env template)
+(def'' (apply-template env template)
(-> RepEnv Syntax Syntax)
- (case' template
- (#Meta [_ (#Symbol ["" sname])])
- (case' (get-rep sname env)
- (#Some subst)
- subst
+ (_lux_case template
+ (#Meta [_ (#SymbolS ["" sname])])
+ (_lux_case (get-rep sname env)
+ (#Some subst)
+ subst
- _
- template)
+ _
+ template)
- (#Meta [_ (#Tuple elems)])
- ($tuple (map (apply-template env) elems))
+ (#Meta [_ (#TupleS elems)])
+ (tuple$ (map (apply-template env) elems))
- (#Meta [_ (#Form elems)])
- ($form (map (apply-template env) elems))
+ (#Meta [_ (#FormS elems)])
+ (form$ (map (apply-template env) elems))
- (#Meta [_ (#Record members)])
- ($record (map (:' (-> (, Syntax Syntax) (, Syntax Syntax))
- (lambda [kv]
- (let [[slot value] kv]
- [(apply-template env slot) (apply-template env value)])))
- members))
+ (#Meta [_ (#RecordS members)])
+ (record$ (map (_lux_: (-> (, Syntax Syntax) (, Syntax Syntax))
+ (lambda [kv]
+ (let [[slot value] kv]
+ [(apply-template env slot) (apply-template env value)])))
+ members))
- _
- template))
+ _
+ template))
-(def__ (join-map f xs)
+(def'' (join-map f xs)
(All' [a b]
(-> (-> (B' a) ($' List (B' b))) ($' List (B' a)) ($' List (B' b))))
- (case' xs
- #Nil
- #Nil
-
- (#Cons [x xs'])
- (list:++ (f x) (join-map f xs'))))
+ (_lux_case xs
+ #Nil
+ #Nil
-(defmacro (do-template tokens)
- (case' tokens
- (#Cons [(#Meta [_ (#Tuple bindings)]) (#Cons [(#Meta [_ (#Tuple templates)]) data])])
- (case' (:' (, ($' Maybe ($' List Text)) ($' Maybe ($' List ($' List Syntax))))
- [(map% Maybe:Monad get-ident bindings)
- (map% Maybe:Monad tuple->list data)])
- [(#Some bindings') (#Some data')]
- (let [apply (:' (-> RepEnv ($' List Syntax))
- (lambda [env] (map (apply-template env) templates)))]
- (|> data'
- (join-map (. apply (make-env bindings')))
- return))
+ (#Cons [x xs'])
+ (list:++ (f x) (join-map f xs'))))
+
+(defmacro #export (do-template tokens)
+ (_lux_case tokens
+ (#Cons [(#Meta [_ (#TupleS bindings)]) (#Cons [(#Meta [_ (#TupleS templates)]) data])])
+ (_lux_case (_lux_: (, ($' Maybe ($' List Text)) ($' Maybe ($' List ($' List Syntax))))
+ [(map% Maybe/Monad get-ident bindings)
+ (map% Maybe/Monad tuple->list data)])
+ [(#Some bindings') (#Some data')]
+ (let [apply (_lux_: (-> RepEnv ($' List Syntax))
+ (lambda [env] (map (apply-template env) templates)))]
+ (|> data'
+ (join-map (. apply (make-env bindings')))
+ return))
- _
- (fail "All the do-template bindigns must be symbols."))
+ _
+ (fail "Wrong syntax for do-template"))
- _
- (fail "Wrong syntax for do-template")))
+ _
+ (fail "Wrong syntax for do-template")))
(do-template [<name> <cmp> <type>]
- [(def__ #export (<name> x y)
+ [(def'' #export (<name> x y)
(-> <type> <type> Bool)
(<cmp> x y))]
- [int:= jvm-leq Int]
- [int:> jvm-lgt Int]
- [int:< jvm-llt Int]
- [real:= jvm-deq Real]
- [real:> jvm-dgt Real]
- [real:< jvm-dlt Real]
+ [i= _jvm_leq Int]
+ [i> _jvm_lgt Int]
+ [i< _jvm_llt Int]
+ [r= _jvm_deq Real]
+ [r> _jvm_dgt Real]
+ [r< _jvm_dlt Real]
+ )
+
+(do-template [<name> <cmp> <eq> <type>]
+ [(def'' #export (<name> x y)
+ (-> <type> <type> Bool)
+ (if (<cmp> x y)
+ true
+ (<eq> x y)))]
+
+ [i>= i> i= Int]
+ [i<= i< i= Int]
+ [r>= r> r= Real]
+ [r<= r< r= Real]
)
(do-template [<name> <cmp> <type>]
- [(def__ #export (<name> x y)
+ [(def'' #export (<name> x y)
(-> <type> <type> <type>)
(<cmp> x y))]
- [int:+ jvm-ladd Int]
- [int:- jvm-lsub Int]
- [int:* jvm-lmul Int]
- [int:/ jvm-ldiv Int]
- [int:% jvm-lrem Int]
- [real:+ jvm-dadd Real]
- [real:- jvm-dsub Real]
- [real:* jvm-dmul Real]
- [real:/ jvm-ddiv Real]
- [real:% jvm-drem Real]
+ [i+ _jvm_ladd Int]
+ [i- _jvm_lsub Int]
+ [i* _jvm_lmul Int]
+ [i/ _jvm_ldiv Int]
+ [i% _jvm_lrem Int]
+ [r+ _jvm_dadd Real]
+ [r- _jvm_dsub Real]
+ [r* _jvm_dmul Real]
+ [r/ _jvm_ddiv Real]
+ [r% _jvm_drem Real]
)
-(def__ (multiple? div n)
+(def'' (multiple? div n)
(-> Int Int Bool)
- (int:= 0 (int:% n div)))
+ (i= 0 (i% n div)))
-(def__ #export (length list)
+(def'' (length list)
(-> List Int)
- (fold (lambda [acc _] (int:+ 1 acc)) 0 list))
+ (foldL (lambda [acc _] (i+ 1 acc)) 0 list))
-(def__ #export (not x)
+(def'' #export (not x)
(-> Bool Bool)
(if x false true))
-(def__ #export (text:++ x y)
+(def'' (text:++ x y)
(-> Text Text Text)
- (jvm-invokevirtual java.lang.String concat [java.lang.String]
- x [y]))
+ (_jvm_invokevirtual "java.lang.String" "concat" ["java.lang.String"]
+ x [y]))
-(def__ (ident->text ident)
+(def'' (ident->text ident)
(-> Ident Text)
(let [[module name] ident]
($ text:++ module ";" name)))
-(def__ (replace-syntax reps syntax)
+(def'' (replace-syntax reps syntax)
(-> RepEnv Syntax Syntax)
- (case' syntax
- (#Meta [_ (#Symbol ["" name])])
- (case' (get-rep name reps)
- (#Some replacement)
- replacement
+ (_lux_case syntax
+ (#Meta [_ (#SymbolS ["" name])])
+ (_lux_case (get-rep name reps)
+ (#Some replacement)
+ replacement
- #None
- syntax)
+ #None
+ syntax)
- (#Meta [_ (#Form parts)])
- (#Meta [_ (#Form (map (replace-syntax reps) parts))])
+ (#Meta [_ (#FormS parts)])
+ (#Meta [_ (#FormS (map (replace-syntax reps) parts))])
- (#Meta [_ (#Tuple members)])
- (#Meta [_ (#Tuple (map (replace-syntax reps) members))])
+ (#Meta [_ (#TupleS members)])
+ (#Meta [_ (#TupleS (map (replace-syntax reps) members))])
- (#Meta [_ (#Record slots)])
- (#Meta [_ (#Record (map (:' (-> (, Syntax Syntax) (, Syntax Syntax))
+ (#Meta [_ (#RecordS slots)])
+ (#Meta [_ (#RecordS (map (_lux_: (-> (, Syntax Syntax) (, Syntax Syntax))
(lambda [slot]
(let [[k v] slot]
[(replace-syntax reps k) (replace-syntax reps v)])))
- slots))])
-
- _
- syntax)
+ slots))])
+
+ _
+ syntax)
)
(defmacro #export (All tokens)
- (let [[self-ident tokens'] (:' (, Text SyntaxList)
- (case' tokens
- (#Cons [(#Meta [_ (#Symbol ["" self-ident])]) tokens'])
- [self-ident tokens']
-
- _
- ["" tokens]))]
- (case' tokens'
- (#Cons [(#Meta [_ (#Tuple args)]) (#Cons [body #Nil])])
- (case' (map% Maybe:Monad get-ident args)
- (#Some idents)
- (case' idents
- #Nil
- (return (:' SyntaxList (list body)))
-
- (#Cons [harg targs])
- (let [replacements (map (:' (-> Text (, Text Syntax))
- (lambda [ident] [ident (`' (#;BoundT (~ ($text ident))))]))
- (list& self-ident idents))
- body' (fold (:' (-> Syntax Text Syntax)
- (lambda [body' arg']
- (`' (#;AllT [#;None "" (~ ($text arg')) (~ body')]))))
- (replace-syntax replacements body)
- (reverse targs))]
- (return (:' SyntaxList
- (list (`' (#;AllT [#;None (~ ($text self-ident)) (~ ($text harg)) (~ body')])))))))
-
- #None
- (fail "'All' arguments must be symbols."))
-
- _
- (fail "Wrong syntax for All"))
+ (let [[self-ident tokens'] (_lux_: (, Text SyntaxList)
+ (_lux_case tokens
+ (#Cons [(#Meta [_ (#SymbolS ["" self-ident])]) tokens'])
+ [self-ident tokens']
+
+ _
+ ["" tokens]))]
+ (_lux_case tokens'
+ (#Cons [(#Meta [_ (#TupleS args)]) (#Cons [body #Nil])])
+ (_lux_case (map% Maybe/Monad get-ident args)
+ (#Some idents)
+ (_lux_case idents
+ #Nil
+ (return (list body))
+
+ (#Cons [harg targs])
+ (let [replacements (map (_lux_: (-> Text (, Text Syntax))
+ (lambda [ident] [ident (`' (#;BoundT (~ (text$ ident))))]))
+ (list& self-ident idents))
+ body' (foldL (lambda [body' arg']
+ (`' (#;AllT [#;None "" (~ (text$ arg')) (~ body')])))
+ (replace-syntax replacements body)
+ (reverse targs))]
+ ## (#;Some #;Nil)
+ (return (list (`' (#;AllT [#;None (~ (text$ self-ident)) (~ (text$ harg)) (~ body')]))))))
+
+ #None
+ (fail "'All' arguments must be symbols."))
+
+ _
+ (fail "Wrong syntax for All"))
))
-(def__ (get k plist)
+(def'' (get k plist)
(All [a]
(-> Text ($' List (, Text a)) ($' Maybe a)))
- (case' plist
- (#Cons [[k' v] plist'])
- (if (text:= k k')
- (#Some v)
- (get k plist'))
+ (_lux_case plist
+ (#Cons [[k' v] plist'])
+ (if (text:= k k')
+ (#Some v)
+ (get k plist'))
- #Nil
- #None))
+ #Nil
+ #None))
+
+(def'' (put k v dict)
+ (All [a]
+ (-> Text a ($' List (, Text a)) ($' List (, Text a))))
+ (_lux_case dict
+ #Nil
+ (list [k v])
+
+ (#Cons [[k' v'] dict'])
+ (if (text:= k k')
+ (#Cons [[k' v] dict'])
+ (#Cons [[k' v'] (put k v dict')]))))
-(def__ #export (get-module-name state)
+(def'' (get-module-name state)
($' Lux Text)
- (case' state
- {#source source #modules modules #module-aliases module-aliases
- #envs envs #types types #host host
- #seed seed}
- (case' (reverse envs)
- #Nil
- (#Left "Can't get the module name without a module!")
-
- (#Cons [{#name module-name #inner-closures _ #locals _ #closure _} _])
- (#Right [state module-name]))))
-
-(def__ (find-macro' modules current-module module name)
- (-> ($' List (, Text ($' List (, Text (, Bool ($' DefData' (-> ($' List Syntax) ($' StateE CompilerState ($' List Syntax)))))))))
+ (_lux_case state
+ {#source source #modules modules
+ #envs envs #types types #host host
+ #seed seed #eval? eval?}
+ (_lux_case (reverse envs)
+ #Nil
+ (#Left "Can't get the module name without a module!")
+
+ (#Cons [{#name module-name #inner-closures _ #locals _ #closure _} _])
+ (#Right [state module-name]))))
+
+(def'' (find-macro' modules current-module module name)
+ (-> ($' List (, Text ($' Module Compiler)))
Text Text Text
($' Maybe Macro))
- (do Maybe:Monad
- [bindings (get module modules)
- gdef (get name bindings)]
- (case' (:' (, Bool ($' DefData' Macro)) gdef)
- [exported? (#MacroD macro')]
- (if exported?
- (#Some macro')
- (if (text:= module current-module)
- (#Some macro')
- #None))
-
- [_ (#AliasD [r-module r-name])]
- (find-macro' modules current-module r-module r-name)
-
- _
- #None)))
-
-(def__ #export (find-macro ident)
+ (do Maybe/Monad
+ [$module (get module modules)
+ gdef (let [{#module-aliases _ #defs bindings #imports _} (_lux_: ($' Module Compiler) $module)]
+ (get name bindings))]
+ (_lux_case (_lux_: (, Bool ($' DefData' Macro)) gdef)
+ [exported? (#MacroD macro')]
+ (if exported?
+ (#Some macro')
+ (if (text:= module current-module)
+ (#Some macro')
+ #None))
+
+ [_ (#AliasD [r-module r-name])]
+ (find-macro' modules current-module r-module r-name)
+
+ _
+ #None)))
+
+(def'' (find-macro ident)
(-> Ident ($' Lux ($' Maybe Macro)))
- (do Lux:Monad
+ (do Lux/Monad
[current-module get-module-name]
(let [[module name] ident]
- (:' ($' Lux ($' Maybe Macro))
- (lambda [state]
- (case' state
- {#source source #modules modules #module-aliases module-aliases
- #envs envs #types types #host host
- #seed seed}
- (#Right [state (find-macro' modules current-module module name)])))))))
-
-(def__ (list:join xs)
+ (lambda [state]
+ (_lux_case state
+ {#source source #modules modules
+ #envs envs #types types #host host
+ #seed seed #eval? eval?}
+ (#Right [state (find-macro' modules current-module module name)]))))))
+
+(def'' (list:join xs)
(All [a]
(-> ($' List ($' List a)) ($' List a)))
- (fold list:++ #Nil xs))
+ (foldL list:++ #Nil xs))
-(def__ #export (normalize ident state)
+(def'' (normalize ident)
(-> Ident ($' Lux Ident))
- (case' ident
- ["" name]
- (case' state
- {#source source #modules modules #module-aliases module-aliases
- #envs envs #types types #host host
- #seed seed}
- (case' (reverse envs)
- #Nil
- (#Left "Can't normalize Ident without a global environment.")
+ (_lux_case ident
+ ["" name]
+ (do Lux/Monad
+ [module-name get-module-name]
+ (;return (_lux_: Ident [module-name name])))
- (#Cons [{#name prefix #inner-closures _ #locals _ #closure _} _])
- (#Right [state [prefix name]])))
-
- _
- (#Right [state ident])))
+ _
+ (return ident)))
(defmacro #export (| tokens)
- (do Lux:Monad
- [pairs (map% Lux:Monad
- (:' (-> Syntax ($' Lux Syntax))
- (lambda [token]
- (case' token
- (#Meta [_ (#Tag ident)])
- (do Lux:Monad
- [ident (normalize ident)]
- (;return (:' Syntax (`' [(~ ($text (ident->text ident))) (;,)]))))
-
- (#Meta [_ (#Form (#Cons [(#Meta [_ (#Tag ident)]) (#Cons [value #Nil])]))])
- (do Lux:Monad
- [ident (normalize ident)]
- (;return (:' Syntax (`' [(~ ($text (ident->text ident))) (~ value)]))))
-
- _
- (fail "Wrong syntax for |"))))
+ (do Lux/Monad
+ [pairs (map% Lux/Monad
+ (_lux_: (-> Syntax ($' Lux Syntax))
+ (lambda [token]
+ (_lux_case token
+ (#Meta [_ (#TagS ident)])
+ (do Lux/Monad
+ [ident (normalize ident)]
+ (;return (`' [(~ (text$ (ident->text ident))) (;,)])))
+
+ (#Meta [_ (#FormS (#Cons [(#Meta [_ (#TagS ident)]) (#Cons [value #Nil])]))])
+ (do Lux/Monad
+ [ident (normalize ident)]
+ (;return (`' [(~ (text$ (ident->text ident))) (~ value)])))
+
+ _
+ (fail "Wrong syntax for |"))))
tokens)]
- (;return (:' SyntaxList (list (`' (#;VariantT (;list (~@ pairs)))))))))
+ (;return (list (`' (#;VariantT (~ (untemplate-list pairs))))))))
(defmacro #export (& tokens)
(if (not (multiple? 2 (length tokens)))
(fail "& expects an even number of arguments.")
- (do Lux:Monad
- [pairs (map% Lux:Monad
- (:' (-> (, Syntax Syntax) ($' Lux Syntax))
- (lambda [pair]
- (case' pair
- [(#Meta [_ (#Tag ident)]) value]
- (do Lux:Monad
- [ident (normalize ident)]
- (;return (:' Syntax (`' [(~ ($text (ident->text ident))) (~ value)]))))
-
- _
- (fail "Wrong syntax for &"))))
+ (do Lux/Monad
+ [pairs (map% Lux/Monad
+ (_lux_: (-> (, Syntax Syntax) ($' Lux Syntax))
+ (lambda [pair]
+ (_lux_case pair
+ [(#Meta [_ (#TagS ident)]) value]
+ (do Lux/Monad
+ [ident (normalize ident)]
+ (;return (`' [(~ (text$ (ident->text ident))) (~ value)])))
+
+ _
+ (fail "Wrong syntax for &"))))
(as-pairs tokens))]
- (;return (:' SyntaxList (list (`' (#;RecordT (;list (~@ pairs))))))))))
+ (;return (list (`' (#;RecordT (~ (untemplate-list pairs)))))))))
-(def__ #export (->text x)
+(def'' #export (->text x)
(-> (^ java.lang.Object) Text)
- (jvm-invokevirtual java.lang.Object toString [] x []))
+ (_jvm_invokevirtual "java.lang.Object" "toString" [] x []))
-(def__ #export (interpose sep xs)
+(def'' (interpose sep xs)
(All [a]
(-> a ($' List a) ($' List a)))
- (case' xs
- #Nil
- xs
-
- (#Cons [x #Nil])
- xs
-
- (#Cons [x xs'])
- (list& x sep (interpose sep xs'))))
-
-(def__ #export (syntax:show syntax)
- (-> Syntax Text)
- (case' syntax
- (#Meta [_ (#Bool value)])
- (->text value)
-
- (#Meta [_ (#Int value)])
- (->text value)
-
- (#Meta [_ (#Real value)])
- (->text value)
+ (_lux_case xs
+ #Nil
+ xs
- (#Meta [_ (#Char value)])
- ($ text:++ "#\"" (->text value) "\"")
+ (#Cons [x #Nil])
+ xs
- (#Meta [_ (#Text value)])
- value
+ (#Cons [x xs'])
+ (list& x sep (interpose sep xs'))))
- (#Meta [_ (#Symbol ident)])
- (ident->text ident)
+(def'' (macro-expand syntax)
+ (-> Syntax ($' Lux ($' List Syntax)))
+ (_lux_case syntax
+ (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS macro-name)]) args]))])
+ (do Lux/Monad
+ [macro-name' (normalize macro-name)
+ ?macro (find-macro macro-name')]
+ (_lux_case ?macro
+ (#Some macro)
+ (do Lux/Monad
+ [expansion (macro args)
+ expansion' (map% Lux/Monad macro-expand expansion)]
+ (;return (list:join expansion')))
+
+ #None
+ (do Lux/Monad
+ [parts' (map% Lux/Monad macro-expand (list& (symbol$ macro-name) args))]
+ (;return (list (form$ (list:join parts')))))))
+
+ (#Meta [_ (#FormS (#Cons [harg targs]))])
+ (do Lux/Monad
+ [harg+ (macro-expand harg)
+ targs+ (map% Lux/Monad macro-expand targs)]
+ (;return (list (form$ (list:++ harg+ (list:join targs+))))))
+
+ (#Meta [_ (#TupleS members)])
+ (do Lux/Monad
+ [members' (map% Lux/Monad macro-expand members)]
+ (;return (list (tuple$ (list:join members')))))
- (#Meta [_ (#Tag ident)])
- (text:++ "#" (ident->text ident))
+ _
+ (return (list syntax))))
- (#Meta [_ (#Tuple members)])
- ($ text:++ "[" (|> members (map syntax:show) (interpose " ") (fold text:++ "")) "]")
+(def'' (walk-type type)
+ (-> Syntax Syntax)
+ (_lux_case type
+ (#Meta [_ (#FormS (#Cons [(#Meta [_ (#TagS tag)]) parts]))])
+ (form$ (#Cons [(tag$ tag) (map walk-type parts)]))
- (#Meta [_ (#Form members)])
- ($ text:++ "(" (|> members (map syntax:show) (interpose " ") (fold text:++ "")) ")")
+ (#Meta [_ (#TupleS members)])
+ (tuple$ (map walk-type members))
- (#Meta [_ (#Record slots)])
- ($ text:++ "{" (|> slots
- (map (:' (-> (, Syntax Syntax) Text)
- (lambda [slot]
- (let [[k v] slot]
- ($ text:++ (syntax:show k) " " (syntax:show v))))))
- (interpose " ") (fold text:++ "")) "}")
- ))
+ (#Meta [_ (#FormS (#Cons [type-fn args]))])
+ (foldL (lambda [type-fn arg] (`' (#;AppT [(~ type-fn) (~ arg)])))
+ (walk-type type-fn)
+ (map walk-type args))
+
+ _
+ type))
+
+(defmacro #export (type tokens)
+ (_lux_case tokens
+ (#Cons [type #Nil])
+ (do Lux/Monad
+ [type+ (macro-expand type)]
+ (_lux_case type+
+ (#Cons [type' #Nil])
+ (;return (list (walk-type type')))
+
+ _
+ (fail "The expansion of the type-syntax had to yield a single element.")))
-(def__ #export (macro-expand syntax)
- (-> Syntax ($' Lux ($' List Syntax)))
- (case' syntax
- (#Meta [_ (#Form (#Cons [(#Meta [_ (#Symbol macro-name)]) args]))])
- (do Lux:Monad
- [macro-name' (normalize macro-name)
- ?macro (find-macro macro-name')]
- (case' (:' ($' Maybe Macro) ?macro)
- (#Some macro)
- (do Lux:Monad
- [expansion (macro args)
- expansion' (map% Lux:Monad macro-expand expansion)]
- (;return (:' SyntaxList (list:join expansion'))))
-
- #None
- (do Lux:Monad
- [parts' (map% Lux:Monad macro-expand (list& ($symbol macro-name) args))]
- (;return (:' SyntaxList (list ($form (list:join parts'))))))))
-
- (#Meta [_ (#Form (#Cons [harg targs]))])
- (do Lux:Monad
- [harg+ (macro-expand harg)
- targs+ (map% Lux:Monad macro-expand targs)]
- (;return (:' SyntaxList (list ($form (list:++ harg+ (list:join (:' ($' List ($' List Syntax)) targs+))))))))
-
- (#Meta [_ (#Tuple members)])
- (do Lux:Monad
- [members' (map% Lux:Monad macro-expand members)]
- (;return (:' SyntaxList (list ($tuple (list:join members'))))))
-
- _
- (return (:' SyntaxList (list syntax)))))
-
-(def__ (walk-type type)
- (-> Syntax Syntax)
- (case' type
- (#Meta [_ (#Form (#Cons [(#Meta [_ (#Tag tag)]) parts]))])
- ($form (#Cons [($tag tag) (map walk-type parts)]))
-
- (#Meta [_ (#Tuple members)])
- ($tuple (map walk-type members))
-
- (#Meta [_ (#Form (#Cons [type-fn args]))])
- (fold (:' (-> Syntax Syntax Syntax)
- (lambda [type-fn arg]
- (`' (#;AppT [(~ type-fn) (~ arg)]))))
- (walk-type type-fn)
- (map walk-type args))
-
- _
- type))
-
-(defmacro #export (type` tokens)
- (case' tokens
- (#Cons [type #Nil])
- (do Lux:Monad
- [type+ (macro-expand type)]
- (case' (:' SyntaxList type+)
- (#Cons [type' #Nil])
- (;return (:' SyntaxList (list (walk-type type'))))
-
- _
- (fail "type`: The expansion of the type-syntax had to yield a single element.")))
-
- _
- (fail "Wrong syntax for type`")))
+ _
+ (fail "Wrong syntax for type")))
(defmacro #export (: tokens)
- (case' tokens
- (#Cons [type (#Cons [value #Nil])])
- (return (:' SyntaxList (list (`' (:' (;type` (~ type)) (~ value))))))
+ (_lux_case tokens
+ (#Cons [type (#Cons [value #Nil])])
+ (return (list (`' (_lux_: (;type (~ type)) (~ value)))))
- _
- (fail "Wrong syntax for :")))
+ _
+ (fail "Wrong syntax for :")))
(defmacro #export (:! tokens)
- (case' tokens
- (#Cons [type (#Cons [value #Nil])])
- (return (:' SyntaxList (list (`' (:!' (;type` (~ type)) (~ value))))))
+ (_lux_case tokens
+ (#Cons [type (#Cons [value #Nil])])
+ (return (list (`' (_lux_:! (;type (~ type)) (~ value)))))
+
+ _
+ (fail "Wrong syntax for :!")))
- _
- (fail "Wrong syntax for :!")))
+(def'' (empty? xs)
+ (All [a] (-> ($' List a) Bool))
+ (_lux_case xs
+ #Nil true
+ _ false))
(defmacro #export (deftype tokens)
(let [[export? tokens'] (: (, Bool (List Syntax))
- (case' tokens
- (#Cons [(#Meta [_ (#Tag ["" "export"])]) tokens'])
- [true tokens']
-
- _
- [false tokens]))
- parts (: (Maybe (, Syntax (List Syntax) Syntax))
- (case' tokens'
- (#Cons [(#Meta [_ (#Symbol name)]) (#Cons [type #Nil])])
- (#Some [($symbol name) #Nil type])
-
- (#Cons [(#Meta [_ (#Form (#Cons [(#Meta [_ (#Symbol name)]) args]))]) (#Cons [type #Nil])])
- (#Some [($symbol name) args type])
-
- _
- #None))
- ]
- ## (return (: (List Syntax) #Nil))
- (case' parts
- (#Some [name args type])
- (let [with-export (: (List Syntax)
- (if export?
- (list (`' (export' (~ name))))
- #Nil))
- type' (: Syntax
- (case' args
- #Nil
- type
-
- _
- (`' (;All (~ name) [(~@ args)] (~ type)))))]
- (return (: (List Syntax)
- (list& (`' (def' (~ name) (;type` (~ type'))))
- with-export))))
+ (_lux_case tokens
+ (#Cons [(#Meta [_ (#TagS ["" "export"])]) tokens'])
+ [true tokens']
- #None
- (fail "Wrong syntax for deftype"))
- ))
+ _
+ [false tokens]))
+ [rec? tokens'] (: (, Bool (List Syntax))
+ (_lux_case tokens'
+ (#Cons [(#Meta [_ (#TagS ["" "rec"])]) tokens'])
+ [true tokens']
+
+ _
+ [false tokens']))
+ parts (: (Maybe (, Text (List Syntax) Syntax))
+ (_lux_case tokens'
+ (#Cons [(#Meta [_ (#SymbolS ["" name])]) (#Cons [type #Nil])])
+ (#Some [name #Nil type])
+
+ (#Cons [(#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS ["" name])]) args]))]) (#Cons [type #Nil])])
+ (#Some [name args type])
+
+ _
+ #None))]
+ (_lux_case parts
+ (#Some [name args type])
+ (let [with-export (: (List Syntax)
+ (if export?
+ (list (`' (_lux_export (~ (symbol$ ["" name])))))
+ #Nil))
+ type' (: (Maybe Syntax)
+ (if rec?
+ (if (empty? args)
+ (let [g!param (symbol$ ["" ""])
+ prime-name (symbol$ ["" (text:++ name "'")])
+ type+ (replace-syntax (list [name (`' ((~ prime-name) (~ g!param)))]) type)]
+ (#Some (`' ((;All (~ prime-name) [(~ g!param)] (~ type+))
+ ;Void))))
+ #None)
+ (_lux_case args
+ #Nil
+ (#Some type)
-(deftype #export (IO a)
- (-> (,) a))
+ _
+ (#Some (`' (;All (~ (symbol$ ["" name])) [(~@ args)] (~ type)))))))]
+ (_lux_case type'
+ (#Some type'')
+ (return (list& (`' (_lux_def (~ (symbol$ ["" name])) (;type (~ type''))))
+ with-export))
-(defmacro #export (io tokens)
- (case' tokens
- (#Cons [value #Nil])
- (let [blank ($symbol ["" ""])]
- (return (: (List Syntax)
- (list (`' (lambda' (~ blank) (~ blank) (~ value)))))))
+ #None
+ (fail "Wrong syntax for deftype")))
- _
- (fail "Wrong syntax for io")))
+ #None
+ (fail "Wrong syntax for deftype"))
+ ))
+## (defmacro #export (deftype tokens)
+## (let [[export? tokens'] (: (, Bool (List Syntax))
+## (_lux_case (:! (List Syntax) tokens)
+## (#Cons [(#Meta [_ (#TagS ["" "export"])]) tokens'])
+## [true (:! (List Syntax) tokens')]
+
+## _
+## [false (:! (List Syntax) tokens)]))
+## parts (: (Maybe (, Syntax (List Syntax) Syntax))
+## (_lux_case tokens'
+## (#Cons [(#Meta [_ (#SymbolS name)]) (#Cons [type #Nil])])
+## (#Some [(symbol$ name) #Nil type])
+
+## (#Cons [(#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS name)]) args]))]) (#Cons [type #Nil])])
+## (#Some [(symbol$ name) args type])
+
+## _
+## #None))]
+## (_lux_case parts
+## (#Some [name args type])
+## (let [with-export (: (List Syntax)
+## (if export?
+## (list (`' (_lux_export (~ name))))
+## #Nil))
+## type' (: Syntax
+## (_lux_case args
+## #Nil
+## type
+
+## _
+## (`' (;All (~ name) [(~@ args)] (~ type)))))]
+## (return (list& (`' (_lux_def (~ name) (;type (~ type'))))
+## with-export)))
+
+## #None
+## (fail "Wrong syntax for deftype"))
+## ))
(defmacro #export (exec tokens)
- (case' (reverse tokens)
- (#Cons [value actions])
- (let [dummy ($symbol ["" ""])]
- (return (:' SyntaxList
- (list (fold (:' (-> Syntax Syntax Syntax)
- (lambda [post pre]
- (`' (case' (~ pre) (~ dummy) (~ post)))))
- value
- actions)))))
-
- _
- (fail "Wrong syntax for exec")))
+ (_lux_case (reverse tokens)
+ (#Cons [value actions])
+ (let [dummy (symbol$ ["" ""])]
+ (return (list (foldL (lambda [post pre] (`' (_lux_case (~ pre) (~ dummy) (~ post))))
+ value
+ actions))))
+
+ _
+ (fail "Wrong syntax for exec")))
(defmacro #export (def tokens)
(let [[export? tokens'] (: (, Bool (List Syntax))
- (case' tokens
- (#Cons [(#Meta [_ (#Tag ["" "export"])]) tokens'])
- [true tokens']
+ (_lux_case tokens
+ (#Cons [(#Meta [_ (#TagS ["" "export"])]) tokens'])
+ [true tokens']
- _
- [false tokens]))
+ _
+ [false tokens]))
parts (: (Maybe (, Syntax (List Syntax) (Maybe Syntax) Syntax))
- (case' tokens'
- (#Cons [(#Meta [_ (#Form (#Cons [name args]))]) (#Cons [type (#Cons [body #Nil])])])
- (#Some [name args (#Some type) body])
-
- (#Cons [name (#Cons [type (#Cons [body #Nil])])])
- (#Some [name #Nil (#Some type) body])
-
- (#Cons [(#Meta [_ (#Form (#Cons [name args]))]) (#Cons [body #Nil])])
- (#Some [name args #None body])
+ (_lux_case tokens'
+ (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) (#Cons [type (#Cons [body #Nil])])])
+ (#Some [name args (#Some type) body])
+
+ (#Cons [name (#Cons [type (#Cons [body #Nil])])])
+ (#Some [name #Nil (#Some type) body])
+
+ (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) (#Cons [body #Nil])])
+ (#Some [name args #None body])
+
+ (#Cons [name (#Cons [body #Nil])])
+ (#Some [name #Nil #None body])
+
+ _
+ #None))]
+ (_lux_case parts
+ (#Some [name args ?type body])
+ (let [body' (: Syntax
+ (_lux_case args
+ #Nil
+ body
+
+ _
+ (`' (;lambda (~ name) [(~@ args)] (~ body)))))
+ body'' (: Syntax
+ (_lux_case ?type
+ (#Some type)
+ (`' (: (~ type) (~ body')))
- (#Cons [name (#Cons [body #Nil])])
- (#Some [name #Nil #None body])
-
- _
- #None))]
- (case' parts
- (#Some [name args ?type body])
- (let [body' (: Syntax
- (case' args
- #Nil
- body
-
- _
- (`' (;lambda (~ name) [(~@ args)] (~ body)))))
- body'' (: Syntax
- (case' ?type
- (#Some type)
- (`' (: (~ type) (~ body')))
-
- #None
- body'))]
- (return (: (List Syntax) (list& (`' (def' (~ name) (~ body'')))
- (if export?
- (list (`' (export' (~ name))))
- #Nil)))))
-
- #None
- (fail "Wrong syntax for def"))))
+ #None
+ body'))]
+ (return (list& (`' (_lux_def (~ name) (~ body'')))
+ (if export?
+ (list (`' (_lux_export (~ name))))
+ #Nil))))
+
+ #None
+ (fail "Wrong syntax for def"))))
(def (rejoin-pair pair)
(-> (, Syntax Syntax) (List Syntax))
@@ -1646,39 +1659,37 @@
(list left right)))
(defmacro #export (case tokens)
- (case' tokens
- (#Cons [value branches])
- (do Lux:Monad
- [expansions (map% Lux:Monad
- (: (-> (, Syntax Syntax) (Lux (List (, Syntax Syntax))))
- (lambda expander [branch]
- (let [[pattern body] branch]
- (case' pattern
- (#Meta [_ (#Form (#Cons [(#Meta [_ (#Symbol macro-name)]) macro-args]))])
- (do Lux:Monad
- [expansion (macro-expand ($form (list& ($symbol macro-name) body macro-args)))
- expansions (map% Lux:Monad expander (as-pairs (: (List Syntax) expansion)))]
- (;return (list:join (: (List (List (, Syntax Syntax))) expansions))))
-
- _
- (;return (: (List (, Syntax Syntax)) (list branch)))))))
- (as-pairs branches))]
- (;return (: (List Syntax)
- (list (`' (case' (~ value)
- (~@ (|> (: (List (List (, Syntax Syntax))) expansions) list:join (map rejoin-pair) list:join))
- ))))))
-
- _
- (fail "Wrong syntax for case")))
+ (_lux_case tokens
+ (#Cons [value branches])
+ (do Lux/Monad
+ [expansions (map% Lux/Monad
+ (: (-> (, Syntax Syntax) (Lux (List (, Syntax Syntax))))
+ (lambda expander [branch]
+ (let [[pattern body] branch]
+ (_lux_case pattern
+ (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS macro-name)]) macro-args]))])
+ (do Lux/Monad
+ [expansion (macro-expand (form$ (list& (symbol$ macro-name) body macro-args)))
+ expansions (map% Lux/Monad expander (as-pairs expansion))]
+ (;return (list:join expansions)))
+
+ _
+ (;return (list branch))))))
+ (as-pairs branches))]
+ (;return (list (`' (_lux_case (~ value)
+ (~@ (|> expansions list:join (map rejoin-pair) list:join)))))))
+
+ _
+ (fail "Wrong syntax for case")))
(defmacro #export (\ tokens)
(case tokens
(#Cons [body (#Cons [pattern #Nil])])
- (do Lux:Monad
+ (do Lux/Monad
[pattern+ (macro-expand pattern)]
- (case (: (List Syntax) pattern+)
+ (case pattern+
(#Cons [pattern' #Nil])
- (;return (: (List Syntax) (list pattern' body)))
+ (;return (list pattern' body))
_
(fail "\\ can only expand to 1 pattern.")))
@@ -1694,54 +1705,46 @@
(fail "\\or can't have 0 patterns")
_
- (do Lux:Monad
- [patterns' (map% Lux:Monad macro-expand patterns)]
- (;return (: (List Syntax) (list:join (map (: (-> Syntax (List Syntax))
- (lambda [pattern]
- (list pattern body)))
- (list:join (: (List (List Syntax)) patterns'))))))))
+ (do Lux/Monad
+ [patterns' (map% Lux/Monad macro-expand patterns)]
+ (;return (list:join (map (lambda [pattern] (list pattern body))
+ (list:join patterns'))))))
_
(fail "Wrong syntax for \\or")))
(do-template [<name> <offset>]
- [(def #export <name> (int:+ <offset>))]
+ [(def #export <name> (i+ <offset>))]
[inc 1]
[dec -1])
-(def (int:show int)
- (-> Int Text)
- (jvm-invokevirtual java.lang.Object toString []
- int []))
-
(defmacro #export (` tokens)
- (do Lux:Monad
+ (do Lux/Monad
[module-name get-module-name]
(case tokens
(\ (list template))
- (;return (: (List Syntax)
- (list (untemplate (: Text module-name) template))))
+ (;return (list (untemplate true module-name template)))
_
(fail "Wrong syntax for `"))))
-(def #export (gensym prefix state)
+(def (gensym prefix state)
(-> Text (Lux Syntax))
(case state
- {#source source #modules modules #module-aliases module-aliases
+ {#source source #modules modules
#envs envs #types types #host host
- #seed seed}
- (#Right [{#source source #modules modules #module-aliases module-aliases
+ #seed seed #eval? eval?}
+ (#Right [{#source source #modules modules
#envs envs #types types #host host
- #seed (inc seed)}
- ($symbol ["__gensym__" (int:show seed)])])))
+ #seed (inc seed) #eval? eval?}
+ (symbol$ ["__gensym__" (->text seed)])])))
-(def #export (macro-expand-1 token)
+(def (macro-expand-1 token)
(-> Syntax (Lux Syntax))
- (do Lux:Monad
+ (do Lux/Monad
[token+ (macro-expand token)]
- (case (: (List Syntax) token+)
+ (case token+
(\ (list token'))
(;return token')
@@ -1749,39 +1752,38 @@
(fail "Macro expanded to more than 1 element."))))
(defmacro #export (sig tokens)
- (do Lux:Monad
- [tokens' (map% Lux:Monad macro-expand-1 tokens)
- members (map% Lux:Monad
+ (do Lux/Monad
+ [tokens' (map% Lux/Monad macro-expand tokens)
+ members (map% Lux/Monad
(: (-> Syntax (Lux (, Ident Syntax)))
(lambda [token]
(case token
- (\ (#Meta [_ (#Form (list (#Meta [_ (#Symbol ["" ":'"])]) type (#Meta [_ (#Symbol name)])))]))
- (do Lux:Monad
+ (\ (#Meta [_ (#FormS (list (#Meta [_ (#SymbolS ["" "_lux_:"])]) type (#Meta [_ (#SymbolS name)])))]))
+ (do Lux/Monad
[name' (normalize name)]
(;return (: (, Ident Syntax) [name' type])))
_
(fail "Signatures require typed members!"))))
- (: (List Syntax) tokens'))]
- (;return (: (List Syntax)
- (list (`' (#;RecordT (list (~@ (map (: (-> (, Ident Syntax) Syntax)
- (lambda [pair]
- (let [[name type] pair]
- (`' [(~ (|> name ident->text $text))
- (~ type)]))))
- (: (List (, Ident Syntax)) members)))))))))))
+ (list:join tokens'))]
+ (;return (list (`' (#;RecordT (~ (untemplate-list (map (: (-> (, Ident Syntax) Syntax)
+ (lambda [pair]
+ (let [[name type] pair]
+ (`' [(~ (|> name ident->text text$))
+ (~ type)]))))
+ members)))))))))
(defmacro #export (defsig tokens)
(let [[export? tokens'] (: (, Bool (List Syntax))
(case tokens
- (\ (list& (#Meta [_ (#Tag ["" "export"])]) tokens'))
+ (\ (list& (#Meta [_ (#TagS ["" "export"])]) tokens'))
[true tokens']
_
[false tokens]))
?parts (: (Maybe (, Syntax (List Syntax) (List Syntax)))
(case tokens'
- (\ (list& (#Meta [_ (#Form (list& name args))]) sigs))
+ (\ (list& (#Meta [_ (#FormS (list& name args))]) sigs))
(#Some [name args sigs])
(\ (list& name sigs))
@@ -1791,50 +1793,49 @@
#None))]
(case ?parts
(#Some [name args sigs])
- (let [sigs' (: Syntax (case args
- #Nil
- (`' (;sig (~@ sigs)))
-
- _
- (`' (;All (~ name) [(~@ args)] (;sig (~@ sigs))))))]
- (return (: (List Syntax)
- (list& (`' (def' (~ name) (~ sigs')))
- (if export?
- (list (`' (export' (~ name))))
- #Nil)))))
+ (let [sigs' (: Syntax
+ (case args
+ #Nil
+ (`' (;sig (~@ sigs)))
+
+ _
+ (`' (;All (~ name) [(~@ args)] (;sig (~@ sigs))))))]
+ (return (list& (`' (_lux_def (~ name) (~ sigs')))
+ (if export?
+ (list (`' (_lux_export (~ name))))
+ #Nil))))
#None
(fail "Wrong syntax for defsig"))))
(defmacro #export (struct tokens)
- (do Lux:Monad
- [tokens' (map% Lux:Monad macro-expand-1 tokens)
- members (map% Lux:Monad
+ (do Lux/Monad
+ [tokens' (map% Lux/Monad macro-expand tokens)
+ members (map% Lux/Monad
(: (-> Syntax (Lux (, Syntax Syntax)))
(lambda [token]
(case token
- (\ (#Meta [_ (#Form (list (#Meta [_ (#Symbol ["" "def'"])]) (#Meta [_ (#Symbol name)]) value))]))
- (do Lux:Monad
+ (\ (#Meta [_ (#FormS (list (#Meta [_ (#SymbolS ["" "_lux_def"])]) (#Meta [_ (#SymbolS name)]) value))]))
+ (do Lux/Monad
[name' (normalize name)]
- (;return (: (, Syntax Syntax) [($tag name') value])))
+ (;return (: (, Syntax Syntax) [(tag$ name') value])))
_
(fail "Structures require defined members!"))))
- (: (List Syntax) tokens'))]
- (;return (: (List Syntax)
- (list ($record members))))))
+ (list:join tokens'))]
+ (;return (list (record$ members)))))
(defmacro #export (defstruct tokens)
(let [[export? tokens'] (: (, Bool (List Syntax))
(case tokens
- (\ (list& (#Meta [_ (#Tag ["" "export"])]) tokens'))
+ (\ (list& (#Meta [_ (#TagS ["" "export"])]) tokens'))
[true tokens']
_
[false tokens]))
?parts (: (Maybe (, Syntax (List Syntax) Syntax (List Syntax)))
(case tokens'
- (\ (list& (#Meta [_ (#Form (list& name args))]) type defs))
+ (\ (list& (#Meta [_ (#FormS (list& name args))]) type defs))
(#Some [name args type defs])
(\ (list& name type defs))
@@ -1844,128 +1845,387 @@
#None))]
(case ?parts
(#Some [name args type defs])
- (let [defs' (: Syntax (case args
- #Nil
- (`' (;struct (~@ defs)))
-
- _
- (`' (;lambda (~ name) [(~@ args)] (;struct (~@ defs))))))]
- (return (: (List Syntax)
- (list& (`' (def (~ name) (~ type) (~ defs')))
- (if export?
- (list (`' (export' (~ name))))
- #Nil)))))
-
- #None
- (fail "Wrong syntax for defsig"))))
-
-(defsig #export (Eq a)
- (: (-> a a Bool)
- =))
+ (let [defs' (: Syntax
+ (case args
+ #Nil
+ (`' (;struct (~@ defs)))
-(do-template [<name> <type> <test>]
- [(defstruct #export <name> (Eq <type>)
- (def (= x y)
- (<test> x y)))]
+ _
+ (`' (;lambda (~ name) [(~@ args)] (;struct (~@ defs))))))]
+ (return (list& (`' (def (~ name) (~ type) (~ defs')))
+ (if export?
+ (list (`' (_lux_export (~ name))))
+ #Nil))))
- [Int:Eq Int jvm-leq]
- [Real:Eq Real jvm-deq])
+ #None
+ (fail "Wrong syntax for defstruct"))))
(def #export (id x)
(All [a] (-> a a))
x)
-(defsig #export (Show a)
- (: (-> a Text)
- show))
-
-(do-template [<name> <type> <body>]
- [(defstruct #export <name> (Show <type>)
- (def (show x)
- <body>))]
-
- [Bool:Show Bool (->text x)]
- [Int:Show Int (->text x)]
- [Real:Show Real (->text x)]
- [Char:Show Char ($ text:++ "#\"" (->text x) "\"")])
-
-(defsig #export (Ord a)
- (: (-> a a Bool)
- <)
- (: (-> a a Bool)
- <=)
- (: (-> a a Bool)
- >)
- (: (-> a a Bool)
- >=))
-
(do-template [<name> <form> <message>]
[(defmacro #export (<name> tokens)
(case (reverse tokens)
(\ (list& last init))
- (return (: (List Syntax)
- (list (fold (: (-> Syntax Syntax Syntax)
- (lambda [post pre] (` <form>)))
- last
- init))))
+ (return (list (foldL (lambda [post pre] (` <form>))
+ last
+ init)))
_
(fail <message>)))]
- [and (if (~ pre) true (~ post)) "and requires >=1 clauses."]
- [or (if (~ pre) (~ post) false) "or requires >=1 clauses."])
-
-(do-template [<name> <type> <lt> <gt> <eq>]
- [(defstruct #export <name> (Ord <type>)
- (def (< x y)
- (<lt> x y))
- (def (<= x y)
- (or (<lt> x y)
- (<eq> x y)))
- (def (> x y)
- (<gt> x y))
- (def (>= x y)
- (or (<gt> x y)
- (<eq> x y))))]
-
- [Int:Ord Int jvm-llt jvm-lgt jvm-leq]
- [Real:Ord Real jvm-dlt jvm-dgt jvm-deq])
-
-(defmacro #export (alias-lux tokens state)
+ [and (if (~ pre) (~ post) false) "and requires >=1 clauses."]
+ [or (if (~ pre) true (~ post)) "or requires >=1 clauses."])
+
+(deftype Referrals
+ (| #All
+ (#Only (List Text))
+ (#Exclude (List Text))
+ #Nothing))
+
+(deftype Openings
+ (, Text (List Ident)))
+
+(deftype Import
+ (, Text (Maybe Text) Referrals (Maybe Openings)))
+
+(def (extract-defs defs)
+ (-> (List Syntax) (Lux (List Text)))
+ (map% Lux/Monad
+ (: (-> Syntax (Lux Text))
+ (lambda [def]
+ (case def
+ (#Meta [_ (#SymbolS ["" name])])
+ (return name)
+
+ _
+ (fail "only/exclude requires symbols."))))
+ defs))
+
+(def (parse-alias tokens)
+ (-> (List Syntax) (Lux (, (Maybe Text) (List Syntax))))
+ (case tokens
+ (\ (list& (#Meta [_ (#TagS ["" "as"])]) (#Meta [_ (#SymbolS ["" alias])]) tokens'))
+ (return (: (, (Maybe Text) (List Syntax)) [(#Some alias) tokens']))
+
+ _
+ (return (: (, (Maybe Text) (List Syntax)) [#None tokens]))))
+
+(def (parse-referrals tokens)
+ (-> (List Syntax) (Lux (, Referrals (List Syntax))))
+ (case tokens
+ (\ (list& (#Meta [_ (#TagS ["" "refer"])]) referral tokens'))
+ (case referral
+ (#Meta [_ (#TagS ["" "all"])])
+ (return (: (, Referrals (List Syntax)) [#All tokens']))
+
+ (\ (#Meta [_ (#FormS (list& (#Meta [_ (#TagS ["" "only"])]) defs))]))
+ (do Lux/Monad
+ [defs' (extract-defs defs)]
+ (return (: (, Referrals (List Syntax)) [(#Only defs') tokens'])))
+
+ (\ (#Meta [_ (#FormS (list& (#Meta [_ (#TagS ["" "exclude"])]) defs))]))
+ (do Lux/Monad
+ [defs' (extract-defs defs)]
+ (return (: (, Referrals (List Syntax)) [(#Exclude defs') tokens'])))
+
+ _
+ (fail "Incorrect syntax for referral."))
+
+ _
+ (return (: (, Referrals (List Syntax)) [#Nothing tokens]))))
+
+(def (extract-symbol syntax)
+ (-> Syntax (Lux Ident))
+ (case syntax
+ (#Meta [_ (#SymbolS ident)])
+ (return ident)
+
+ _
+ (fail "Not a symbol.")))
+
+(def (parse-openings tokens)
+ (-> (List Syntax) (Lux (, (Maybe Openings) (List Syntax))))
+ (case tokens
+ (\ (list& (#Meta [_ (#TagS ["" "open"])]) (#Meta [_ (#FormS (list& (#Meta [_ (#TextS prefix)]) structs))]) tokens'))
+ (do Lux/Monad
+ [structs' (map% Lux/Monad extract-symbol structs)]
+ (return (: (, (Maybe Openings) (List Syntax)) [(#Some [prefix structs']) tokens'])))
+
+ _
+ (return (: (, (Maybe Openings) (List Syntax)) [#None tokens]))))
+
+(def (decorate-imports super-name tokens)
+ (-> Text (List Syntax) (Lux (List Syntax)))
+ (map% Lux/Monad
+ (: (-> Syntax (Lux Syntax))
+ (lambda [token]
+ (case token
+ (#Meta [_ (#SymbolS ["" sub-name])])
+ (return (symbol$ ["" ($ text:++ super-name "/" sub-name)]))
+
+ (\ (#Meta [_ (#FormS (list& (#Meta [_ (#SymbolS ["" sub-name])]) parts))]))
+ (return (form$ (list& (symbol$ ["" ($ text:++ super-name "/" sub-name)]) parts)))
+
+ _
+ (fail "Wrong import syntax."))))
+ tokens))
+
+(def (parse-imports imports)
+ (-> (List Syntax) (Lux (List Import)))
+ (do Lux/Monad
+ [imports' (map% Lux/Monad
+ (: (-> Syntax (Lux (List Import)))
+ (lambda [token]
+ (case token
+ (#Meta [_ (#SymbolS ["" m-name])])
+ (;return (list [m-name #None #All #None]))
+
+ (\ (#Meta [_ (#FormS (list& (#Meta [_ (#SymbolS ["" m-name])]) extra))]))
+ (do Lux/Monad
+ [alias+extra (parse-alias extra)
+ #let [[alias extra] alias+extra]
+ referral+extra (parse-referrals extra)
+ #let [[referral extra] referral+extra]
+ openings+extra (parse-openings extra)
+ #let [[openings extra] openings+extra]
+ extra (decorate-imports m-name extra)
+ sub-imports (parse-imports extra)]
+ (;return (case (: (, Referrals (Maybe Text) (Maybe Openings)) [referral alias openings])
+ [#Nothing #None #None] sub-imports
+ _ (list& [m-name alias referral openings] sub-imports))))
+
+ _
+ (fail "Wrong syntax for import"))))
+ imports)]
+ (;return (list:join imports'))))
+
+(def (module-exists? module state)
+ (-> Text (Lux Bool))
(case state
- {#source source #modules modules #module-aliases module-aliases
- #envs envs #types types #host host
- #seed seed}
- (case (get "lux" modules)
- (#Some lux)
- (let [to-alias (map (: (-> (, Text (, Bool (DefData' (-> (List Syntax) (StateE CompilerState (List Syntax))))))
+ {#source source #modules modules
+ #envs envs #types types #host host
+ #seed seed #eval? eval?}
+ (case (get module modules)
+ (#Some =module)
+ (#Right [state true])
+
+ #None
+ (#Right [state false]))
+ ))
+
+(def (exported-defs module state)
+ (-> Text (Lux (List Text)))
+ (case state
+ {#source source #modules modules
+ #envs envs #types types #host host
+ #seed seed #eval? eval?}
+ (case (get module modules)
+ (#Some =module)
+ (let [to-alias (map (: (-> (, Text (, Bool (DefData' (-> (List Syntax) (StateE Compiler (List Syntax))))))
(List Text))
(lambda [gdef]
(let [[name [export? _]] gdef]
(if export?
(list name)
(list)))))
- lux)]
- (#Right [state (map (: (-> Text Syntax)
- (lambda [name]
- (` ((~ ($symbol ["" "def'"])) (~ ($symbol ["" name]))
- (~ ($symbol ["lux" name]))))))
- (list:join to-alias))]))
+ (let [{#module-aliases _ #defs defs #imports _} =module]
+ defs))]
+ (#Right [state (list:join to-alias)]))
#None
- (#Left "Uh, oh... The universe is not working properly..."))
+ (#Left ($ text:++ "Unknown module: " module)))
))
-(def #export (print x)
- (-> Text (,))
- (jvm-invokevirtual java.io.PrintStream print [java.lang.Object]
- (jvm-getstatic java.lang.System out) [x]))
+(def (last-index-of part text)
+ (-> Text Text Int)
+ (_jvm_i2l (_jvm_invokevirtual "java.lang.String" "lastIndexOf" ["java.lang.String"]
+ text [part])))
+
+(def (index-of part text)
+ (-> Text Text Int)
+ (_jvm_i2l (_jvm_invokevirtual "java.lang.String" "indexOf" ["java.lang.String"]
+ text [part])))
+
+(def (substring1 idx text)
+ (-> Int Text Text)
+ (_jvm_invokevirtual "java.lang.String" "substring" ["int"]
+ text [(_jvm_l2i idx)]))
-(def #export (println x)
- (-> Text (,))
- (print (text:++ x "\n")))
+(def (substring2 idx1 idx2 text)
+ (-> Int Int Text Text)
+ (_jvm_invokevirtual "java.lang.String" "substring" ["int" "int"]
+ text [(_jvm_l2i idx1) (_jvm_l2i idx2)]))
+
+(def (split-module-contexts module)
+ (-> Text (List Text))
+ (#Cons [module (let [idx (last-index-of "/" module)]
+ (if (i< idx 0)
+ #Nil
+ (split-module-contexts (substring2 0 idx module))))]))
+
+(def (split-module module)
+ (-> Text (List Text))
+ (let [idx (index-of "/" module)]
+ (if (i< idx 0)
+ (#Cons [module #Nil])
+ (#Cons [(substring2 0 idx module)
+ (split-module (substring1 (inc idx) module))]))))
+
+(def (@ idx xs)
+ (All [a]
+ (-> Int (List a) (Maybe a)))
+ (case xs
+ #Nil
+ #None
+
+ (#Cons [x xs'])
+ (if (i= idx 0)
+ (#Some x)
+ (@ (dec idx) xs')
+ )))
-(def #export (some f xs)
+(def (split-with' p ys xs)
+ (All [a]
+ (-> (-> a Bool) (List a) (List a) (, (List a) (List a))))
+ (case xs
+ #Nil
+ [ys xs]
+
+ (#Cons [x xs'])
+ (if (p x)
+ (split-with' p (list& x ys) xs')
+ [ys xs])))
+
+(def (split-with p xs)
+ (All [a]
+ (-> (-> a Bool) (List a) (, (List a) (List a))))
+ (let [[ys' xs'] (split-with' p #Nil xs)]
+ [(reverse ys') xs']))
+
+(def (clean-module module)
+ (-> Text (Lux Text))
+ (do Lux/Monad
+ [module-name get-module-name]
+ (case (split-module module)
+ (\ (list& "." parts))
+ (return (|> (list& module-name parts) (interpose "/") (foldL text:++ "")))
+
+ parts
+ (let [[ups parts'] (split-with (text:= "..") parts)
+ num-ups (length ups)]
+ (if (i= num-ups 0)
+ (return module)
+ (case (@ num-ups (split-module-contexts module-name))
+ #None
+ (fail (text:++ "Can't clean module: " module))
+
+ (#Some top-module)
+ (return (|> (list& top-module parts') (interpose "/") (foldL text:++ ""))))
+ )))
+ ))
+
+(def (filter p xs)
+ (All [a] (-> (-> a Bool) (List a) (List a)))
+ (case xs
+ #;Nil
+ (list)
+
+ (#;Cons [x xs'])
+ (if (p x)
+ (#;Cons [x (filter p xs')])
+ (filter p xs'))))
+
+(def (is-member? cases name)
+ (-> (List Text) Text Bool)
+ (let [output (foldL (lambda [prev case]
+ (or prev
+ (text:= case name)))
+ false
+ cases)]
+ output))
+
+(defmacro #export (import tokens)
+ (do Lux/Monad
+ [imports (parse-imports tokens)
+ imports (map% Lux/Monad
+ (: (-> Import (Lux Import))
+ (lambda [import]
+ (case import
+ [m-name m-alias m-referrals m-openings]
+ (do Lux/Monad
+ [m-name (clean-module m-name)]
+ (;return (: Import [m-name m-alias m-referrals m-openings]))))))
+ imports)
+ unknowns' (map% Lux/Monad
+ (: (-> Import (Lux (List Text)))
+ (lambda [import]
+ (case import
+ [m-name _ _ _]
+ (do Lux/Monad
+ [? (module-exists? m-name)]
+ (;return (if ?
+ (list)
+ (list m-name)))))))
+ imports)
+ #let [unknowns (list:join unknowns')]]
+ (case unknowns
+ #Nil
+ (do Lux/Monad
+ [output' (map% Lux/Monad
+ (: (-> Import (Lux (List Syntax)))
+ (lambda [import]
+ (case import
+ [m-name m-alias m-referrals m-openings]
+ (do Lux/Monad
+ [defs (case m-referrals
+ #All
+ (exported-defs m-name)
+
+ (#Only +defs)
+ (do Lux/Monad
+ [*defs (exported-defs m-name)]
+ (;return (filter (is-member? +defs) *defs)))
+
+ (#Exclude -defs)
+ (do Lux/Monad
+ [*defs (exported-defs m-name)]
+ (;return (filter (. not (is-member? -defs)) *defs)))
+
+ #Nothing
+ (;return (list)))
+ #let [openings (: (List Syntax)
+ (case m-openings
+ #None
+ (list)
+
+ (#Some [prefix structs])
+ (map (: (-> Ident Syntax)
+ (lambda [struct]
+ (let [[_ name] struct]
+ (` (open (~ (symbol$ [m-name name])) (~ (text$ prefix)))))))
+ structs)))]]
+ (;return ($ list:++
+ (list (` (_lux_import (~ (text$ m-name)))))
+ (case m-alias
+ #None (list)
+ (#Some alias) (list (` (_lux_alias (~ (text$ alias)) (~ (text$ m-name))))))
+ (map (: (-> Text Syntax)
+ (lambda [def]
+ (` ((~ (symbol$ ["" "_lux_def"])) (~ (symbol$ ["" def])) (~ (symbol$ [m-name def]))))))
+ defs)
+ openings))))))
+ imports)]
+ (;return (list:join output')))
+
+ _
+ (;return (: (List Syntax)
+ (list:++ (map (lambda [m-name] (` (_lux_import (~ (text$ m-name)))))
+ unknowns)
+ (list (` (import (~@ tokens))))))))))
+
+(def (some f xs)
(All [a b]
(-> (-> a (Maybe b)) (List a) (Maybe b)))
(case xs
@@ -1980,22 +2240,6 @@
(#Some y)
(#Some y))))
-
-(def (index-of part text)
- (-> Text Text Int)
- (jvm-i2l (jvm-invokevirtual java.lang.String indexOf [java.lang.String]
- text [part])))
-
-(def (substring1 idx text)
- (-> Int Text Text)
- (jvm-invokevirtual java.lang.String substring [int]
- text [(jvm-l2i idx)]))
-
-(def (substring2 idx1 idx2 text)
- (-> Int Int Text Text)
- (jvm-invokevirtual java.lang.String substring [int int]
- text [(jvm-l2i idx1) (jvm-l2i idx2)]))
-
(def (split-slot slot)
(-> Text (, Text Text))
(let [idx (index-of ";" slot)
@@ -2003,6 +2247,154 @@
name (substring1 (inc idx) slot)]
[module name]))
+(def (type:show type)
+ (-> Type Text)
+ (case type
+ (#DataT name)
+ ($ text:++ "(^ " name ")")
+
+ (#TupleT elems)
+ (case elems
+ #;Nil
+ "(,)"
+
+ _
+ ($ text:++ "(, " (|> elems (map type:show) (interpose " ") (foldL text:++ "")) ")"))
+
+ (#VariantT cases)
+ (case cases
+ #;Nil
+ "(|)"
+
+ _
+ ($ text:++ "(| "
+ (|> cases
+ (map (: (-> (, Text Type) Text)
+ (lambda [kv]
+ (case kv
+ [k (#TupleT #;Nil)]
+ ($ text:++ "#" k)
+
+ [k v]
+ ($ text:++ "(#" k " " (type:show v) ")")))))
+ (interpose " ")
+ (foldL text:++ ""))
+ ")"))
+
+ (#RecordT fields)
+ (case fields
+ #;Nil
+ "(&)"
+
+ _
+ ($ text:++ "(& "
+ (|> fields
+ (map (: (-> (, Text Type) Text)
+ (: (-> (, Text Type) Text)
+ (lambda [kv]
+ (let [[k v] kv]
+ ($ text:++ "(#" k " " (type:show v) ")"))))))
+ (interpose " ")
+ (foldL text:++ ""))
+ ")"))
+
+ (#LambdaT [input output])
+ ($ text:++ "(-> " (type:show input) " " (type:show output) ")")
+
+ (#VarT id)
+ ($ text:++ "⌈" (->text id) "⌋")
+
+ (#BoundT name)
+ name
+
+ (#ExT ?id)
+ ($ text:++ "⟨" (->text ?id) "⟩")
+
+ (#AppT [?lambda ?param])
+ ($ text:++ "(" (type:show ?lambda) " " (type:show ?param) ")")
+
+ (#AllT [?env ?name ?arg ?body])
+ ($ text:++ "(All " ?name " [" ?arg "] " (type:show ?body) ")")
+ ))
+
+(def (beta-reduce env type)
+ (-> (List (, Text Type)) Type Type)
+ (case type
+ (#VariantT ?cases)
+ (#VariantT (map (: (-> (, Text Type) (, Text Type))
+ (lambda [kv]
+ (let [[k v] kv]
+ [k (beta-reduce env v)])))
+ ?cases))
+
+ (#RecordT ?fields)
+ (#RecordT (map (: (-> (, Text Type) (, Text Type))
+ (lambda [kv]
+ (let [[k v] kv]
+ [k (beta-reduce env v)])))
+ ?fields))
+
+ (#TupleT ?members)
+ (#TupleT (map (beta-reduce env) ?members))
+
+ (#AppT [?type-fn ?type-arg])
+ (#AppT [(beta-reduce env ?type-fn) (beta-reduce env ?type-arg)])
+
+ (#AllT [?local-env ?local-name ?local-arg ?local-def])
+ (case ?local-env
+ #None
+ (#AllT [(#Some env) ?local-name ?local-arg ?local-def])
+
+ (#Some _)
+ type)
+
+ (#LambdaT [?input ?output])
+ (#LambdaT [(beta-reduce env ?input) (beta-reduce env ?output)])
+
+ (#BoundT ?name)
+ (case (get ?name env)
+ (#Some bound)
+ bound
+
+ _
+ type)
+
+ _
+ type
+ ))
+
+(defmacro #export (? tokens)
+ (case tokens
+ (\ (list maybe else))
+ (do Lux/Monad
+ [g!value (gensym "")]
+ (return (list (` (case (~ maybe)
+ (#;Some (~ g!value))
+ (~ g!value)
+
+ _
+ (~ else))))))
+
+ _
+ (fail "Wrong syntax for ?")))
+
+(def (apply-type type-fn param)
+ (-> Type Type (Maybe Type))
+ (case type-fn
+ (#AllT [env name arg body])
+ (#Some (beta-reduce (|> (? env (list))
+ (put name type-fn)
+ (put arg param))
+ body))
+
+ (#AppT [F A])
+ (do Maybe/Monad
+ [type-fn* (apply-type F A)]
+ (apply-type type-fn* param))
+
+ _
+ #None))
+
(def (resolve-struct-type type)
(-> Type (Maybe Type))
(case type
@@ -2010,7 +2402,7 @@
(#Some type)
(#AppT [fun arg])
- (resolve-struct-type fun)
+ (apply-type fun arg)
(#AllT [_ _ _ body])
(resolve-struct-type body)
@@ -2018,106 +2410,415 @@
_
#None))
-(defmacro #export (using tokens state)
+(def (try-both f x1 x2)
+ (All [a b]
+ (-> (-> a (Maybe b)) a a (Maybe b)))
+ (case (f x1)
+ #;None (f x2)
+ (#;Some y) (#;Some y)))
+
+(def (find-in-env name state)
+ (-> Ident Compiler (Maybe Type))
+ (let [vname' (ident->text name)]
+ (case state
+ {#source source #modules modules
+ #envs envs #types types #host host
+ #seed seed #eval? eval?}
+ (some (: (-> (Env Text (, LuxVar Type)) (Maybe Type))
+ (lambda [env]
+ (case env
+ {#name _ #inner-closures _ #locals {#counter _ #mappings locals} #closure {#counter _ #mappings closure}}
+ (try-both (some (: (-> (, Text (, LuxVar Type)) (Maybe Type))
+ (lambda [binding]
+ (let [[bname [_ type]] binding]
+ (if (text:= vname' bname)
+ (#Some type)
+ #None)))))
+ locals
+ closure))))
+ envs))))
+
+(def (show-envs envs)
+ (-> (List (Env Text (, LuxVar Type))) Text)
+ (|> envs
+ (map (lambda [env]
+ (case env
+ {#name name #inner-closures _ #locals {#counter _ #mappings locals} #closure _}
+ ($ text:++ name ": " (|> locals
+ (map (: (All [a] (-> (, Text a) Text))
+ (lambda [b] (let [[label _] b] label))))
+ (interpose " ")
+ (foldL text:++ ""))))))
+ (interpose "\n")
+ (foldL text:++ "")))
+
+(def (find-in-defs name state)
+ (-> Ident Compiler (Maybe Type))
+ (let [[v-prefix v-name] name
+ {#source source #modules modules
+ #envs envs #types types #host host
+ #seed seed #eval? eval?} state]
+ (case (get v-prefix modules)
+ #None
+ #None
+
+ (#Some {#defs defs #module-aliases _ #imports _})
+ (case (get v-name defs)
+ #None
+ #None
+
+ (#Some [_ def-data])
+ (case def-data
+ #TypeD (#Some Type)
+ (#ValueD type) (#Some type)
+ (#MacroD m) (#Some Macro)
+ (#AliasD name') (find-in-defs name' state))))))
+## (def (find-in-defs name state)
+## (-> Ident Compiler (Maybe Type))
+## (exec (_jvm_invokevirtual java.io.PrintStream print [java.lang.Object]
+## (_jvm_getstatic java.lang.System out) [($ text:++ "find-in-defs #1: " (ident->text name) "\n")])
+## (let [[v-prefix v-name] name
+## {#source source #modules modules
+## #envs envs #types types #host host
+## #seed seed #eval? eval?} state]
+## (do Maybe/Monad
+## [module (get v-prefix modules)
+## #let [{#defs defs #module-aliases _ #imports _} module]
+## def (get v-name defs)
+## #let [[_ def-data] def]]
+## (case def-data
+## #TypeD (;return Type)
+## (#ValueD type) (;return type)
+## (#MacroD m) (;return Macro)
+## (#AliasD name') (find-in-defs name' state))))))
+
+(def (find-var-type name)
+ (-> Ident (Lux Type))
+ (do Lux/Monad
+ [name' (normalize name)]
+ (lambda [state]
+ (case (find-in-env name state)
+ (#Some struct-type)
+ (#Right [state struct-type])
+
+ _
+ (case (find-in-defs name' state)
+ (#Some struct-type)
+ (#Right [state struct-type])
+
+ _
+ (let [{#source source #modules modules
+ #envs envs #types types #host host
+ #seed seed #eval? eval?} state]
+ (#Left ($ text:++ "Unknown var: " (ident->text name) "\n\n" (show-envs envs)))))))))
+
+(defmacro #export (using tokens)
(case tokens
(\ (list struct body))
(case struct
- (#Meta [_ (#Symbol vname)])
- (let [vname' (ident->text vname)]
- (case state
- {#source source #modules modules #module-aliases module-aliases
- #envs envs #types types #host host
- #seed seed}
- (let [?struct-type (some (: (-> (Env Text (, LuxVar Type)) (Maybe Type))
- (lambda [env]
- (case env
- {#name _ #inner-closures _ #locals {#counter _ #mappings mappings} #closure _}
- (some (: (-> (, Text (, LuxVar Type)) (Maybe Type))
- (lambda [binding]
- (let [[bname [_ type]] binding]
- (if (text:= vname' bname)
- (#Some type)
- #None))))
- mappings))))
- envs)]
- (case ?struct-type
- #None
- (#Left ($ text:++ "Unknown structure: " vname'))
-
- (#Some struct-type)
- (case (resolve-struct-type struct-type)
- (#Some (#RecordT slots))
- (let [pattern ($record (map (: (-> (, Text Type) (, Syntax Syntax))
- (lambda [slot]
- (let [[sname stype] slot
- [module name] (split-slot sname)]
- [($tag [module name]) ($symbol ["" name])])))
- slots))
- _ (println (text:++ "Using pattern: " (syntax:show pattern)))]
- (#Right [state (list (` (case' (~ struct) (~ pattern) (~ body))))]))
-
- _
- (#Left "Can only \"use\" records."))))))
+ (#Meta [_ (#SymbolS name)])
+ (do Lux/Monad
+ [struct-type (find-var-type name)]
+ (case (resolve-struct-type struct-type)
+ (#Some (#RecordT slots))
+ (let [pattern (record$ (map (: (-> (, Text Type) (, Syntax Syntax))
+ (lambda [slot]
+ (let [[sname stype] slot
+ [module name] (split-slot sname)]
+ [(tag$ [module name]) (symbol$ ["" name])])))
+ slots))]
+ (return (list (` (_lux_case (~ struct) (~ pattern) (~ body))))))
+
+ _
+ (fail "Can only \"use\" records.")))
+
+ _
+ (let [dummy (symbol$ ["" ""])]
+ (return (list (` (_lux_case (~ struct)
+ (~ dummy)
+ (using (~ dummy)
+ (~ body))))))))
+ _
+ (fail "Wrong syntax for using")))
+
+(def #export (flip f)
+ (All [a b c]
+ (-> (-> a b c) (-> b a c)))
+ (lambda [y x]
+ (f x y)))
+
+(def #export (curry f)
+ (All [a b c]
+ (-> (-> (, a b) c)
+ (-> a b c)))
+ (lambda [x y]
+ (f [x y])))
+
+(def #export (uncurry f)
+ (All [a b c]
+ (-> (-> a b c)
+ (-> (, a b) c)))
+ (lambda [xy]
+ (let [[x y] xy]
+ (f x y))))
+
+(defmacro #export (cond tokens)
+ (if (i= 0 (i% (length tokens) 2))
+ (fail "cond requires an even number of arguments.")
+ (case (reverse tokens)
+ (\ (list& else branches'))
+ (return (list (foldL (: (-> Syntax (, Syntax Syntax) Syntax)
+ (lambda [else branch]
+ (let [[right left] branch]
+ (` (if (~ left) (~ right) (~ else))))))
+ else
+ (as-pairs branches'))))
+
+ _
+ (fail "Wrong syntax for cond"))))
+
+(defmacro #export (get@ tokens)
+ (case tokens
+ (\ (list (#Meta [_ (#TagS slot')]) record))
+ (case record
+ (#Meta [_ (#SymbolS name)])
+ (do Lux/Monad
+ [type (find-var-type name)
+ g!blank (gensym "")
+ g!output (gensym "")]
+ (case (resolve-struct-type type)
+ (#Some (#RecordT slots))
+ (do Lux/Monad
+ [slot (normalize slot')]
+ (let [[s-prefix s-name] (: Ident slot)
+ pattern (record$ (map (: (-> (, Text Type) (, Syntax Syntax))
+ (lambda [slot]
+ (let [[r-slot-name r-type] slot
+ [r-prefix r-name] (split-slot r-slot-name)]
+ [(tag$ [r-prefix r-name]) (if (and (text:= s-prefix r-prefix)
+ (text:= s-name r-name))
+ g!output
+ g!blank)])))
+ slots))]
+ (return (list (` (_lux_case (~ record) (~ pattern) (~ g!output)))))))
+
+ _
+ (fail "get@ can only use records.")))
+
_
- (let [dummy ($symbol ["" ""])]
- (#Right [state (list (` (case' (~ struct)
- (~ dummy)
- (using (~ dummy) (~ body)))))])))
+ (do Lux/Monad
+ [_record (gensym "")]
+ (return (list (` (let [(~ _record) (~ record)]
+ (get@ (~ (tag$ slot')) (~ _record))))))))
+
+ _
+ (fail "Wrong syntax for get@")))
+
+(defmacro #export (open tokens)
+ (case tokens
+ (\ (list& (#Meta [_ (#SymbolS struct-name)]) tokens'))
+ (do Lux/Monad
+ [#let [prefix (case tokens'
+ (\ (list (#Meta [_ (#TextS prefix)])))
+ prefix
+
+ _
+ "")]
+ struct-type (find-var-type struct-name)]
+ (case (resolve-struct-type struct-type)
+ (#Some (#RecordT slots))
+ (return (map (: (-> (, Text Type) Syntax)
+ (lambda [slot]
+ (let [[sname stype] slot
+ [module name] (split-slot sname)]
+ (` (_lux_def (~ (symbol$ ["" (text:++ prefix name)]))
+ (get@ (~ (tag$ [module name])) (~ (symbol$ struct-name))))))))
+ slots))
+ _
+ (fail "Can only \"open\" records.")))
+
+ _
+ (fail "Wrong syntax for open")))
+
+(def (foldL% M f x ys)
+ (All [m a b]
+ (-> (Monad m) (-> a b (m a)) a (List b)
+ (m a)))
+ (case ys
+ (#Cons [y ys'])
+ (do M
+ [x' (f x y)]
+ (foldL% M f x' ys'))
+
+ #Nil
+ ((get@ #return M) x)))
+
+(defmacro #export (:: tokens)
+ (case tokens
+ (\ (list& start parts))
+ (do Lux/Monad
+ [output (foldL% Lux/Monad
+ (: (-> Syntax Syntax (Lux Syntax))
+ (lambda [so-far part]
+ (case part
+ (#Meta [_ (#SymbolS slot)])
+ (return (` (get@ (~ (tag$ slot)) (~ so-far))))
+
+ (\ (#Meta [_ (#FormS (list& (#Meta [_ (#SymbolS slot)]) args))]))
+ (return (` ((get@ (~ (tag$ slot)) (~ so-far))
+ (~@ args))))
+
+ _
+ (fail "Wrong syntax for ::"))))
+ start parts)]
+ (return (list output)))
+
+ _
+ (fail "Wrong syntax for ::")))
+
+(defmacro #export (set@ tokens)
+ (case tokens
+ (\ (list (#Meta [_ (#TagS slot')]) value record))
+ (case record
+ (#Meta [_ (#SymbolS name)])
+ (do Lux/Monad
+ [type (find-var-type name)]
+ (case (resolve-struct-type type)
+ (#Some (#RecordT slots))
+ (do Lux/Monad
+ [pattern' (map% Lux/Monad
+ (: (-> (, Text Type) (Lux (, Text Syntax)))
+ (lambda [slot]
+ (let [[r-slot-name r-type] slot]
+ (do Lux/Monad
+ [g!slot (gensym "")]
+ (return [r-slot-name g!slot])))))
+ slots)
+ slot (normalize slot')]
+ (let [[s-prefix s-name] (: Ident slot)
+ pattern (record$ (map (: (-> (, Text Syntax) (, Syntax Syntax))
+ (lambda [slot]
+ (let [[r-slot-name r-var] slot]
+ [(tag$ (split-slot r-slot-name)) r-var])))
+ pattern'))
+ output (record$ (map (: (-> (, Text Syntax) (, Syntax Syntax))
+ (lambda [slot]
+ (let [[r-slot-name r-var] slot
+ [r-prefix r-name] (split-slot r-slot-name)]
+ [(tag$ [r-prefix r-name]) (if (and (text:= s-prefix r-prefix)
+ (text:= s-name r-name))
+ value
+ r-var)])))
+ pattern'))]
+ (return (list (` (_lux_case (~ record) (~ pattern) (~ output)))))))
+
+ _
+ (fail "set@ can only use records.")))
+
+ _
+ (do Lux/Monad
+ [_record (gensym "")]
+ (return (list (` (let [(~ _record) (~ record)]
+ (set@ (~ (tag$ slot')) (~ value) (~ _record))))))))
+
+ _
+ (fail "Wrong syntax for set@")))
+
+(defmacro #export (update@ tokens)
+ (case tokens
+ (\ (list (#Meta [_ (#TagS slot')]) fun record))
+ (case record
+ (#Meta [_ (#SymbolS name)])
+ (do Lux/Monad
+ [type (find-var-type name)]
+ (case (resolve-struct-type type)
+ (#Some (#RecordT slots))
+ (do Lux/Monad
+ [pattern' (map% Lux/Monad
+ (: (-> (, Text Type) (Lux (, Text Syntax)))
+ (lambda [slot]
+ (let [[r-slot-name r-type] slot]
+ (do Lux/Monad
+ [g!slot (gensym "")]
+ (return [r-slot-name g!slot])))))
+ slots)
+ slot (normalize slot')]
+ (let [[s-prefix s-name] (: Ident slot)
+ pattern (record$ (map (: (-> (, Text Syntax) (, Syntax Syntax))
+ (lambda [slot]
+ (let [[r-slot-name r-var] slot]
+ [(tag$ (split-slot r-slot-name)) r-var])))
+ pattern'))
+ output (record$ (map (: (-> (, Text Syntax) (, Syntax Syntax))
+ (lambda [slot]
+ (let [[r-slot-name r-var] slot
+ [r-prefix r-name] (split-slot r-slot-name)]
+ [(tag$ [r-prefix r-name]) (if (and (text:= s-prefix r-prefix)
+ (text:= s-name r-name))
+ (` ((~ fun) (~ r-var)))
+ r-var)])))
+ pattern'))]
+ (return (list (` (_lux_case (~ record) (~ pattern) (~ output)))))))
+
+ _
+ (fail "update@ can only use records.")))
+
+ _
+ (do Lux/Monad
+ [_record (gensym "")]
+ (return (list (` (let [(~ _record) (~ record)]
+ (update@ (~ (tag$ slot')) (~ fun) (~ _record))))))))
+
+ _
+ (fail "Wrong syntax for update@")))
+
+(defmacro #export (\template tokens)
+ (case tokens
+ (\ (list (#Meta [_ (#TupleS data)])
+ (#Meta [_ (#TupleS bindings)])
+ (#Meta [_ (#TupleS templates)])))
+ (case (: (Maybe (List Syntax))
+ (do Maybe/Monad
+ [bindings' (map% Maybe/Monad get-ident bindings)
+ data' (map% Maybe/Monad tuple->list data)]
+ (let [apply (: (-> RepEnv (List Syntax))
+ (lambda [env] (map (apply-template env) templates)))]
+ (|> data'
+ (join-map (. apply (make-env bindings')))
+ ;return))))
+ (#Some output)
+ (return output)
+
+ #None
+ (fail "Wrong syntax for \\template"))
+
_
- (#Left "Wrong syntax for defsig")))
-
-## (defmacro (loop tokens)
-## (case' tokens
-## (#Cons [bindings (#Cons [body #Nil])])
-## (let [pairs (as-pairs bindings)]
-## (return (list (#Form (#Cons [(` (lambda (~ (#Symbol ["" "recur"])) (~ (#Tuple (map first pairs)))
-## (~ body)))
-## (map second pairs)])))))))
-
-## (defmacro (get@ tokens)
-## (let [output (case' tokens
-## (#Cons [tag (#Cons [record #Nil])])
-## (` (get@' (~ tag) (~ record)))
-
-## (#Cons [tag #Nil])
-## (` (lambda [record] (get@' (~ tag) record))))]
-## (return (list output))))
-
-## (defmacro (set@ tokens)
-## (let [output (case' tokens
-## (#Cons [tag (#Cons [value (#Cons [record #Nil])])])
-## (` (set@' (~ tag) (~ value) (~ record)))
-
-## (#Cons [tag (#Cons [value #Nil])])
-## (` (lambda [record] (set@' (~ tag) (~ value) record)))
-
-## (#Cons [tag #Nil])
-## (` (lambda [value record] (set@' (~ tag) value record))))]
-## (return (list output))))
-
-## (defmacro (update@ tokens)
-## (let [output (case' tokens
-## (#Cons [tag (#Cons [func (#Cons [record #Nil])])])
-## (` (let [_record_ (~ record)]
-## (set@' (~ tag) ((~ func) (get@' (~ tag) _record_)) _record_)))
-
-## (#Cons [tag (#Cons [func #Nil])])
-## (` (lambda [record]
-## (` (set@' (~ tag) ((~ func) (get@' (~ tag) record)) record))))
-
-## (#Cons [tag #Nil])
-## (` (lambda [func record]
-## (set@' (~ tag) (func (get@' (~ tag) record)) record))))]
-## (return (list output))))
-
-## (do-template [<name> <member> <type>]
-## (def (<name> pair)
-## (All [a b] (-> (, a b) <type>))
-## (case pair
-## [f s]
-## <member>))
-
-## [first f a]
-## [second s b])
+ (fail "Wrong syntax for \\template")))
+
+(def #export complement
+ (All [a] (-> (-> a Bool) (-> a Bool)))
+ (. not))
+
+## (defmacro #export (loop tokens)
+## (case tokens
+## (\ (list bindings body))
+## (let [pairs (as-pairs bindings)
+## vars (map first pairs)
+## inits (map second pairs)]
+## (if (every? symbol? inits)
+## (do Lux/Monad
+## [inits' (map% Maybe/Monad get-ident inits)
+## init-types (map% Maybe/Monad find-var-type inits')]
+## (return (list (` ((lambda (~ (#SymbolS ["" "recur"])) [(~@ vars)]
+## (~ body))
+## (~@ inits))))))
+## (do Lux/Monad
+## [aliases (map% Maybe/Monad (lambda [_] (gensym "")) inits)]
+## (return (list (` (let [(~@ (interleave aliases inits))]
+## (loop [(~@ (interleave vars aliases))]
+## (~ body)))))))))
+
+## _
+## (fail "Wrong syntax for loop")))
generated by cgit v1.2.3 (git 2.25.1) at 2024-07-07 19:53:48 +0000