aboutsummaryrefslogtreecommitdiff
path: root/source/lux.lux
diff options
context:
space:
mode:
Diffstat (limited to 'source/lux.lux')
-rw-r--r--source/lux.lux4353
1 files changed, 2416 insertions, 1937 deletions
diff --git a/source/lux.lux b/source/lux.lux
index 8861bc241..4d1c3fdef 100644
--- a/source/lux.lux
+++ b/source/lux.lux
@@ -1,105 +1,139 @@
-## Copyright (c) Eduardo Julian. All rights reserved.
-## The use and distribution terms for this software are covered by the
-## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
-## which can be found in the file epl-v10.html at the root of this distribution.
-## By using this software in any fashion, you are agreeing to be bound by
-## the terms of this license.
-## You must not remove this notice, or any other, from this software.
+## Copyright (c) Eduardo Julian. All rights reserved.
+## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
+## If a copy of the MPL was not distributed with this file,
+## You can obtain one at http://mozilla.org/MPL/2.0/.
## First things first, must define functions
-(_jvm_interface "Function" []
- ("apply" ["java.lang.Object"] "java.lang.Object" ["public" "abstract"]))
+(_jvm_interface "Function" [] []
+ ("apply" ["public" "abstract"] [] [] ["java.lang.Object"] "java.lang.Object"))
## Basic types
-(_lux_def Bool (#DataT "java.lang.Boolean"))
+(_lux_def Bool (10 ["lux" "Bool"]
+ (0 "java.lang.Boolean" (0))))
(_lux_export Bool)
-(_lux_def Int (#DataT "java.lang.Long"))
+(_lux_def Int (10 ["lux" "Int"]
+ (0 "java.lang.Long" (0))))
(_lux_export Int)
-(_lux_def Real (#DataT "java.lang.Double"))
+(_lux_def Real (10 ["lux" "Real"]
+ (0 "java.lang.Double" (0))))
(_lux_export Real)
-(_lux_def Char (#DataT "java.lang.Character"))
+(_lux_def Char (10 ["lux" "Char"]
+ (0 "java.lang.Character" (0))))
(_lux_export Char)
-(_lux_def Text (#DataT "java.lang.String"))
+(_lux_def Text (10 ["lux" "Text"]
+ (0 "java.lang.String" (0))))
(_lux_export Text)
-(_lux_def Unit (#TupleT #Nil))
+(_lux_def Unit (10 ["lux" "Unit"]
+ (2 (0))))
(_lux_export Unit)
-(_lux_def Void (#VariantT #Nil))
+(_lux_def Void (10 ["lux" "Void"]
+ (1 (0))))
(_lux_export Void)
-(_lux_def Ident (#TupleT (#Cons [Text (#Cons [Text #Nil])])))
+(_lux_def Ident (10 ["lux" "Ident"]
+ (2 (1 Text (1 Text (0))))))
(_lux_export Ident)
## (deftype (List a)
## (| #Nil
-## (#Cons (, a (List a)))))
+## (#Cons a (List a))))
(_lux_def List
- (#AllT [(#Some #Nil) "lux;List" "a"
- (#VariantT (#Cons [["lux;Nil" (#TupleT #Nil)]
- (#Cons [["lux;Cons" (#TupleT (#Cons [(#BoundT "a")
- (#Cons [(#AppT [(#BoundT "lux;List") (#BoundT "a")])
- #Nil])]))]
- #Nil])]))]))
+ (10 ["lux" "List"]
+ (7 (0)
+ (1 (1 ## "lux;Nil"
+ (2 (0))
+ (1 ## "lux;Cons"
+ (2 (1 (4 1)
+ (1 (9 (4 0) (4 1))
+ (0))))
+ (0)))))))
(_lux_export List)
+(_lux_declare-tags [#Nil #Cons] List)
## (deftype (Maybe a)
## (| #None
-## (#Some a)))
+## (1 a)))
(_lux_def Maybe
- (#AllT [(#Some #Nil) "lux;Maybe" "a"
- (#VariantT (#Cons [["lux;None" (#TupleT #Nil)]
- (#Cons [["lux;Some" (#BoundT "a")]
- #Nil])]))]))
+ (10 ["lux" "Maybe"]
+ (7 (0)
+ (1 (1 ## "lux;None"
+ (2 (0))
+ (1 ## "lux;Some"
+ (4 1)
+ (0)))))))
(_lux_export Maybe)
+(_lux_declare-tags [#None #Some] Maybe)
## (deftype #rec Type
-## (| (#DataT Text)
+## (| (#DataT (, Text (List Type)))
+## (#VariantT (List Type))
## (#TupleT (List Type))
-## (#VariantT (List (, Text Type)))
-## (#RecordT (List (, Text Type)))
-## (#LambdaT (, Type Type))
-## (#BoundT Text)
+## (#LambdaT Type Type)
+## (#BoundT Int)
## (#VarT Int)
-## (#AllT (, (Maybe (List (, Text Type))) Text Text Type))
-## (#AppT (, Type Type))))
+## (#ExT Int)
+## (#UnivQ (List Type) Type)
+## (#ExQ (List Type) Type)
+## (#AppT Type Type)
+## (#NamedT Ident 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]))))
+ (10 ["lux" "Type"]
+ (_lux_case (9 (4 0) (4 1))
+ Type
+ (_lux_case (9 List Type)
+ TypeList
+ (9 (7 (0)
+ (1 (1 ## "lux;DataT"
+ (2 (1 Text (1 TypeList (0))))
+ (1 ## "lux;VariantT"
+ TypeList
+ (1 ## "lux;TupleT"
+ TypeList
+ (1 ## "lux;LambdaT"
+ (2 (1 Type (1 Type (0))))
+ (1 ## "lux;BoundT"
+ Int
+ (1 ## "lux;VarT"
+ Int
+ (1 ## "lux;ExT"
+ Int
+ (1 ## "lux;UnivQ"
+ (2 (1 TypeList (1 Type (0))))
+ (1 ## "lux;ExQ"
+ (2 (1 TypeList (1 Type (0))))
+ (1 ## "lux;AppT"
+ (2 (1 Type (1 Type (0))))
+ (1 ## "lux;NamedT"
+ (2 (1 Ident (1 Type (0))))
+ (0))))))))))))))
+ Void)))))
(_lux_export Type)
+(_lux_declare-tags [#DataT #VariantT #TupleT #LambdaT #BoundT #VarT #ExT #UnivQ #ExQ #AppT #NamedT] Type)
## (deftype (Bindings k v)
## (& #counter Int
## #mappings (List (, k v))))
(_lux_def Bindings
- (#AllT [(#Some #Nil) "lux;Bindings" "k"
- (#AllT [#None "" "v"
- (#RecordT (#Cons [["lux;counter" Int]
- (#Cons [["lux;mappings" (#AppT [List
- (#TupleT (#Cons [(#BoundT "k")
- (#Cons [(#BoundT "v")
- #Nil])]))])]
- #Nil])]))])]))
+ (#NamedT ["lux" "Bindings"]
+ (#UnivQ #Nil
+ (#UnivQ #Nil
+ (#TupleT (#Cons ## "lux;counter"
+ Int
+ (#Cons ## "lux;mappings"
+ (#AppT List
+ (#TupleT (#Cons (#BoundT 3)
+ (#Cons (#BoundT 1)
+ #Nil))))
+ #Nil)))))))
(_lux_export Bindings)
+(_lux_declare-tags [#counter #mappings] Bindings)
## (deftype (Env k v)
## (& #name Text
@@ -107,191 +141,264 @@
## #locals (Bindings k v)
## #closure (Bindings k v)))
(_lux_def Env
- (#AllT [(#Some #Nil) "lux;Env" "k"
- (#AllT [#None "" "v"
- (#RecordT (#Cons [["lux;name" Text]
- (#Cons [["lux;inner-closures" Int]
- (#Cons [["lux;locals" (#AppT [(#AppT [Bindings (#BoundT "k")])
- (#BoundT "v")])]
- (#Cons [["lux;closure" (#AppT [(#AppT [Bindings (#BoundT "k")])
- (#BoundT "v")])]
- #Nil])])])]))])]))
+ (#NamedT ["lux" "Env"]
+ (#UnivQ #Nil
+ (#UnivQ #Nil
+ (#TupleT (#Cons ## "lux;name"
+ Text
+ (#Cons ## "lux;inner-closures"
+ Int
+ (#Cons ## "lux;locals"
+ (#AppT (#AppT Bindings (#BoundT 3))
+ (#BoundT 1))
+ (#Cons ## "lux;closure"
+ (#AppT (#AppT Bindings (#BoundT 3))
+ (#BoundT 1))
+ #Nil)))))))))
(_lux_export Env)
+(_lux_declare-tags [#name #inner-closures #locals #closure] Env)
## (deftype Cursor
-## (, Text Int Int))
+## (& #module Text
+## #line Int
+## #column Int))
(_lux_def Cursor
- (#TupleT (#Cons [Text (#Cons [Int (#Cons [Int #Nil])])])))
+ (#NamedT ["lux" "Cursor"]
+ (#TupleT (#Cons Text (#Cons Int (#Cons Int #Nil))))))
(_lux_export Cursor)
+(_lux_declare-tags [#module #line #column] Cursor)
## (deftype (Meta m v)
-## (| (#Meta (, m v))))
+## (& #meta m
+## #datum v))
(_lux_def Meta
- (#AllT [(#Some #Nil) "lux;Meta" "m"
- (#AllT [#None "" "v"
- (#VariantT (#Cons [["lux;Meta" (#TupleT (#Cons [(#BoundT "m")
- (#Cons [(#BoundT "v")
- #Nil])]))]
- #Nil]))])]))
+ (#NamedT ["lux" "Meta"]
+ (#UnivQ #Nil
+ (#UnivQ #Nil
+ (#TupleT (#Cons (#BoundT 3)
+ (#Cons (#BoundT 1)
+ #Nil)))))))
(_lux_export Meta)
+(_lux_declare-tags [#meta #datum] Meta)
-## (deftype (Syntax' w)
+## (deftype (AST' w)
## (| (#BoolS Bool)
## (#IntS Int)
## (#RealS Real)
## (#CharS Char)
## (#TextS Text)
-## (#SymbolS (, Text Text))
-## (#TagS (, Text Text))
-## (#FormS (List (w (Syntax' w))))
-## (#TupleS (List (w (Syntax' w))))
-## (#RecordS (List (, (w (Syntax' w)) (w (Syntax' w)))))))
-(_lux_def Syntax'
- (_lux_case (#AppT [(#BoundT "w")
- (#AppT [(#BoundT "lux;Syntax'")
- (#BoundT "w")])])
- Syntax
- (_lux_case (#AppT [List Syntax])
- SyntaxList
- (#AllT [(#Some #Nil) "lux;Syntax'" "w"
- (#VariantT (#Cons [["lux;BoolS" Bool]
- (#Cons [["lux;IntS" Int]
- (#Cons [["lux;RealS" Real]
- (#Cons [["lux;CharS" Char]
- (#Cons [["lux;TextS" Text]
- (#Cons [["lux;SymbolS" Ident]
- (#Cons [["lux;TagS" Ident]
- (#Cons [["lux;FormS" SyntaxList]
- (#Cons [["lux;TupleS" SyntaxList]
- (#Cons [["lux;RecordS" (#AppT [List (#TupleT (#Cons [Syntax (#Cons [Syntax #Nil])]))])]
- #Nil])
- ])])])])])])])])])
- )]))))
-(_lux_export Syntax')
-
-## (deftype Syntax
-## (Meta Cursor (Syntax' (Meta Cursor))))
-(_lux_def Syntax
- (_lux_case (#AppT [Meta Cursor])
- w
- (#AppT [w (#AppT [Syntax' w])])))
-(_lux_export Syntax)
-
-(_lux_def SyntaxList (#AppT [List Syntax]))
+## (#SymbolS Text Text)
+## (#TagS Text Text)
+## (#FormS (List (w (AST' w))))
+## (#TupleS (List (w (AST' w))))
+## (#RecordS (List (, (w (AST' w)) (w (AST' w)))))))
+(_lux_def AST'
+ (#NamedT ["lux" "AST'"]
+ (_lux_case (#AppT (#BoundT 1)
+ (#AppT (#BoundT 0)
+ (#BoundT 1)))
+ AST
+ (_lux_case (#AppT [List AST])
+ ASTList
+ (#UnivQ #Nil
+ (#VariantT (#Cons ## "lux;BoolS"
+ Bool
+ (#Cons ## "lux;IntS"
+ Int
+ (#Cons ## "lux;RealS"
+ Real
+ (#Cons ## "lux;CharS"
+ Char
+ (#Cons ## "lux;TextS"
+ Text
+ (#Cons ## "lux;SymbolS"
+ Ident
+ (#Cons ## "lux;TagS"
+ Ident
+ (#Cons ## "lux;FormS"
+ ASTList
+ (#Cons ## "lux;TupleS"
+ ASTList
+ (#Cons ## "lux;RecordS"
+ (#AppT List (#TupleT (#Cons AST (#Cons AST #Nil))))
+ #Nil)
+ )))))))))
+ ))))))
+(_lux_export AST')
+(_lux_declare-tags [#BoolS #IntS #RealS #CharS #TextS #SymbolS #TagS #FormS #TupleS #RecordS] AST')
+
+## (deftype AST
+## (Meta Cursor (AST' (Meta Cursor))))
+(_lux_def AST
+ (#NamedT ["lux" "AST"]
+ (_lux_case (#AppT Meta Cursor)
+ w
+ (#AppT w (#AppT AST' w)))))
+(_lux_export AST)
+
+(_lux_def ASTList (#AppT List AST))
## (deftype (Either l r)
## (| (#Left l)
## (#Right r)))
(_lux_def Either
- (#AllT [(#Some #Nil) "lux;Either" "l"
- (#AllT [#None "" "r"
- (#VariantT (#Cons [["lux;Left" (#BoundT "l")]
- (#Cons [["lux;Right" (#BoundT "r")]
- #Nil])]))])]))
+ (#NamedT ["lux" "Either"]
+ (#UnivQ #Nil
+ (#UnivQ #Nil
+ (#VariantT (#Cons ## "lux;Left"
+ (#BoundT 3)
+ (#Cons ## "lux;Right"
+ (#BoundT 1)
+ #Nil)))))))
(_lux_export Either)
+(_lux_declare-tags [#Left #Right] Either)
## (deftype (StateE s a)
## (-> s (Either Text (, s a))))
(_lux_def StateE
- (#AllT [(#Some #Nil) "lux;StateE" "s"
- (#AllT [#None "" "a"
- (#LambdaT [(#BoundT "s")
- (#AppT [(#AppT [Either Text])
- (#TupleT (#Cons [(#BoundT "s")
- (#Cons [(#BoundT "a")
- #Nil])]))])])])]))
-
-## (deftype Reader
+ (#UnivQ #Nil
+ (#UnivQ #Nil
+ (#LambdaT (#BoundT 3)
+ (#AppT (#AppT Either Text)
+ (#TupleT (#Cons (#BoundT 3)
+ (#Cons (#BoundT 1)
+ #Nil))))))))
+
+## (deftype Source
## (List (Meta Cursor Text)))
-(_lux_def Reader
- (#AppT [List
- (#AppT [(#AppT [Meta Cursor])
- Text])]))
-(_lux_export Reader)
-
-## (deftype HostState
-## (& #writer (^ org.objectweb.asm.ClassWriter)
-## #loader (^ java.net.URLClassLoader)
-## #classes (^ clojure.lang.Atom)))
-(_lux_def HostState
- (#RecordT (#Cons [["lux;writer" (#DataT "org.objectweb.asm.ClassWriter")]
- (#Cons [["lux;loader" (#DataT "java.lang.ClassLoader")]
- (#Cons [["lux;classes" (#DataT "clojure.lang.Atom")]
- #Nil])])])))
+(_lux_def Source
+ (#NamedT ["lux" "Source"]
+ (#AppT [List
+ (#AppT [(#AppT [Meta Cursor])
+ Text])])))
+(_lux_export Source)
## (deftype (DefData' m)
-## (| #TypeD
-## (#ValueD Type)
+## (| (#TypeD Type)
+## (#ValueD (, Type Unit))
## (#MacroD m)
## (#AliasD Ident)))
(_lux_def DefData'
- (#AllT [(#Some #Nil) "lux;DefData'" ""
- (#VariantT (#Cons [["lux;TypeD" (#TupleT #Nil)]
- (#Cons [["lux;ValueD" Type]
- (#Cons [["lux;MacroD" (#BoundT "")]
- (#Cons [["lux;AliasD" Ident]
- #Nil])])])]))]))
+ (#NamedT ["lux" "DefData'"]
+ (#UnivQ #Nil
+ (#VariantT (#Cons ## "lux;ValueD"
+ (#TupleT (#Cons Type (#Cons Unit #Nil)))
+ (#Cons ## "lux;TypeD"
+ Type
+ (#Cons ## "lux;MacroD"
+ (#BoundT 1)
+ (#Cons ## "lux;AliasD"
+ Ident
+ #Nil))))))))
(_lux_export DefData')
-## (deftype LuxVar
-## (| (#Local Int)
-## (#Global Ident)))
-(_lux_def LuxVar
- (#VariantT (#Cons [["lux;Local" Int]
- (#Cons [["lux;Global" Ident]
- #Nil])])))
-(_lux_export LuxVar)
+(_lux_def Analysis
+ (#NamedT ["lux" "Analysis"]
+ Void))
+(_lux_export Analysis)
## (deftype (Module Compiler)
## (& #module-aliases (List (, Text Text))
-## #defs (List (, Text (, Bool (DefData' (-> (List Syntax) (StateE Compiler (List Syntax)))))))
-## #imports (List Text)
+## #defs (List (, Text (, Bool (DefData' (-> (List AST) (StateE Compiler (List AST)))))))
+## #imports (List Text)
+## #tags (List (, Text (, Int (List Ident) Type)))
+## #types (List (, Text (, (List Ident) Type)))
## ))
(_lux_def Module
- (#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])])]))]))
+ (#NamedT ["lux" "Module"]
+ (#UnivQ #Nil
+ (#TupleT (#Cons ## "lux;module-aliases"
+ (#AppT List (#TupleT (#Cons Text (#Cons Text #Nil))))
+ (#Cons ## "lux;defs"
+ (#AppT List (#TupleT (#Cons Text
+ (#Cons (#TupleT (#Cons Bool (#Cons (#AppT DefData' (#LambdaT ASTList
+ (#AppT (#AppT StateE (#BoundT 1))
+ ASTList)))
+ #Nil)))
+ #Nil))))
+ (#Cons ## "lux;imports"
+ (#AppT List Text)
+ (#Cons ## "lux;tags"
+ (#AppT List
+ (#TupleT (#Cons Text
+ (#Cons (#TupleT (#Cons Int
+ (#Cons (#AppT List Ident)
+ (#Cons Type
+ #Nil))))
+ #Nil))))
+ (#Cons ## "lux;types"
+ (#AppT List
+ (#TupleT (#Cons Text
+ (#Cons (#TupleT (#Cons (#AppT List Ident)
+ (#Cons Type
+ #Nil)))
+ #Nil))))
+ #Nil)))))))))
(_lux_export Module)
+(_lux_declare-tags [#module-aliases #defs #imports #tags #types] Module)
## (deftype #rec Compiler
-## (& #source Reader
+## (& #source Source
+## #cursor Cursor
## #modules (List (, Text (Module Compiler)))
-## #envs (List (Env Text (, LuxVar Type)))
-## #types (Bindings Int Type)
-## #host HostState
+## #envs (List (Env Text (Meta (, Type Cursor) Analysis)))
+## #type-vars (Bindings Int Type)
+## #expected Type
## #seed Int
-## #eval? Bool))
+## #eval? Bool
+## #host Void
+## ))
(_lux_def Compiler
- (#AppT [(#AllT [(#Some #Nil) "lux;Compiler" ""
- (#RecordT (#Cons [["lux;source" Reader]
- (#Cons [["lux;modules" (#AppT [List (#TupleT (#Cons [Text
- (#Cons [(#AppT [Module (#AppT [(#BoundT "lux;Compiler") (#BoundT "")])])
- #Nil])]))])]
- (#Cons [["lux;envs" (#AppT [List (#AppT [(#AppT [Env Text])
- (#TupleT (#Cons [LuxVar (#Cons [Type #Nil])]))])])]
- (#Cons [["lux;types" (#AppT [(#AppT [Bindings Int]) Type])]
- (#Cons [["lux;host" HostState]
- (#Cons [["lux;seed" Int]
- (#Cons [["lux;eval?" Bool]
- #Nil])])])])])])]))])
- Void]))
+ (#NamedT ["lux" "Compiler"]
+ (#AppT (#UnivQ #Nil
+ (#TupleT (#Cons ## "lux;source"
+ Source
+ (#Cons ## "lux;cursor"
+ Cursor
+ (#Cons ## "lux;modules"
+ (#AppT List (#TupleT (#Cons Text
+ (#Cons (#AppT Module (#AppT (#BoundT 0) (#BoundT 1)))
+ #Nil))))
+ (#Cons ## "lux;envs"
+ (#AppT List (#AppT (#AppT Env Text)
+ (#AppT (#AppT Meta
+ (#TupleT (#Cons Type (#Cons Cursor #Nil))))
+ Analysis)))
+ (#Cons ## "lux;type-vars"
+ (#AppT (#AppT Bindings Int) Type)
+ (#Cons ## "lux;expected"
+ Type
+ (#Cons ## "lux;seed"
+ Int
+ (#Cons ## "lux;eval?"
+ Bool
+ (#Cons ## "lux;host"
+ Void
+ #Nil)))))))))))
+ Void)))
(_lux_export Compiler)
+(_lux_declare-tags [#source #cursor #modules #envs #type-vars #expected #seed #eval? #host] Compiler)
## (deftype Macro
-## (-> (List Syntax) (StateE Compiler (List Syntax))))
+## (-> (List AST) (StateE Compiler (List AST))))
(_lux_def Macro
- (#LambdaT [SyntaxList
- (#AppT [(#AppT [StateE Compiler])
- SyntaxList])]))
+ (#NamedT ["lux" "Macro"]
+ (#LambdaT ASTList
+ (#AppT (#AppT StateE Compiler)
+ ASTList))))
(_lux_export Macro)
+(_lux_def DefData
+ (#NamedT ["lux" "DefData"]
+ (#AppT DefData' Macro)))
+(_lux_export DefData)
+(_lux_declare-tags [#ValueD #TypeD #MacroD #AliasD] DefData)
+
+(_lux_def Definition
+ (#NamedT ["lux" "Definition"]
+ (#AppT (#AppT Meta Bool) DefData)))
+(_lux_export Definition)
+
## Base functions & macros
## (def _cursor
## Cursor
@@ -300,14 +407,14 @@
(_lux_: Cursor ["" -1 -1]))
## (def (_meta data)
-## (-> (Syntax' (Meta Cursor)) Syntax)
-## (#Meta [["" -1 -1] data]))
+## (-> (AST' (Meta Cursor)) AST)
+## [["" -1 -1] data])
(_lux_def _meta
- (_lux_: (#LambdaT [(#AppT [Syntax'
- (#AppT [Meta Cursor])])
- Syntax])
+ (_lux_: (#LambdaT (#AppT AST'
+ (#AppT Meta Cursor))
+ AST)
(_lux_lambda _ data
- (#Meta [_cursor data]))))
+ [_cursor data])))
## (def (return x)
## (All [a]
@@ -315,16 +422,16 @@
## (Either Text (, Compiler a))))
## ...)
(_lux_def return
- (_lux_: (#AllT [(#Some #Nil) "" "a"
- (#LambdaT [(#BoundT "a")
- (#LambdaT [Compiler
- (#AppT [(#AppT [Either Text])
- (#TupleT (#Cons [Compiler
- (#Cons [(#BoundT "a")
- #Nil])]))])])])])
+ (_lux_: (#UnivQ #Nil
+ (#LambdaT (#BoundT 1)
+ (#LambdaT Compiler
+ (#AppT (#AppT Either Text)
+ (#TupleT (#Cons Compiler
+ (#Cons (#BoundT 1)
+ #Nil)))))))
(_lux_lambda _ val
(_lux_lambda _ state
- (#Right [state val])))))
+ (#Right state val)))))
## (def (fail msg)
## (All [a]
@@ -332,163 +439,183 @@
## (Either Text (, Compiler a))))
## ...)
(_lux_def fail
- (_lux_: (#AllT [(#Some #Nil) "" "a"
- (#LambdaT [Text
- (#LambdaT [Compiler
- (#AppT [(#AppT [Either Text])
- (#TupleT (#Cons [Compiler
- (#Cons [(#BoundT "a")
- #Nil])]))])])])])
+ (_lux_: (#UnivQ #Nil
+ (#LambdaT Text
+ (#LambdaT Compiler
+ (#AppT (#AppT Either Text)
+ (#TupleT (#Cons Compiler
+ (#Cons (#BoundT 1)
+ #Nil)))))))
(_lux_lambda _ msg
(_lux_lambda _ state
(#Left msg)))))
+(_lux_def bool$
+ (_lux_: (#LambdaT Bool AST)
+ (_lux_lambda _ value
+ (_meta (#BoolS value)))))
+
+(_lux_def int$
+ (_lux_: (#LambdaT Int AST)
+ (_lux_lambda _ value
+ (_meta (#IntS value)))))
+
+(_lux_def real$
+ (_lux_: (#LambdaT Real AST)
+ (_lux_lambda _ value
+ (_meta (#RealS value)))))
+
+(_lux_def char$
+ (_lux_: (#LambdaT Char AST)
+ (_lux_lambda _ value
+ (_meta (#CharS value)))))
+
(_lux_def text$
- (_lux_: (#LambdaT [Text Syntax])
+ (_lux_: (#LambdaT Text AST)
(_lux_lambda _ text
(_meta (#TextS text)))))
(_lux_def symbol$
- (_lux_: (#LambdaT [Ident Syntax])
+ (_lux_: (#LambdaT Ident AST)
(_lux_lambda _ ident
(_meta (#SymbolS ident)))))
(_lux_def tag$
- (_lux_: (#LambdaT [Ident Syntax])
+ (_lux_: (#LambdaT Ident AST)
(_lux_lambda _ ident
(_meta (#TagS ident)))))
(_lux_def form$
- (_lux_: (#LambdaT [(#AppT [List Syntax]) Syntax])
+ (_lux_: (#LambdaT (#AppT List AST) AST)
(_lux_lambda _ tokens
(_meta (#FormS tokens)))))
(_lux_def tuple$
- (_lux_: (#LambdaT [(#AppT [List Syntax]) Syntax])
+ (_lux_: (#LambdaT (#AppT List AST) AST)
(_lux_lambda _ tokens
(_meta (#TupleS tokens)))))
(_lux_def record$
- (_lux_: (#LambdaT [(#AppT [List (#TupleT (#Cons [Syntax (#Cons [Syntax #Nil])]))]) Syntax])
+ (_lux_: (#LambdaT (#AppT List (#TupleT (#Cons AST (#Cons AST #Nil)))) AST)
(_lux_lambda _ tokens
(_meta (#RecordS tokens)))))
-(_lux_def let'
+(_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]))
+ (#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')
+ (fail "Wrong syntax for let''")))))
+(_lux_declare-macro let'')
-(_lux_def lambda'
+(_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]))
+ (#Cons [_ (#TupleS (#Cons arg args'))] (#Cons body #Nil))
+ (return (#Cons (_meta (#FormS (#Cons (_meta (#SymbolS "" "_lux_lambda"))
+ (#Cons (_meta (#SymbolS "" ""))
+ (#Cons arg
+ (#Cons (_lux_case args'
+ #Nil
+ body
+
+ _
+ (_meta (#FormS (#Cons (_meta (#SymbolS "lux" "lambda''"))
+ (#Cons (_meta (#TupleS args'))
+ (#Cons body #Nil))))))
+ #Nil))))))
+ #Nil))
+
+ (#Cons [_ (#SymbolS "" self)] (#Cons [_ (#TupleS (#Cons arg args'))] (#Cons body #Nil)))
+ (return (#Cons (_meta (#FormS (#Cons (_meta (#SymbolS "" "_lux_lambda"))
+ (#Cons (_meta (#SymbolS "" self))
+ (#Cons arg
+ (#Cons (_lux_case args'
+ #Nil
+ body
+
+ _
+ (_meta (#FormS (#Cons (_meta (#SymbolS "lux" "lambda''"))
+ (#Cons (_meta (#TupleS args'))
+ (#Cons body #Nil))))))
+ #Nil))))))
+ #Nil))
_
- (fail "Wrong syntax for lambda")))))
-(_lux_declare-macro lambda')
+ (fail "Wrong syntax for lambda''")))))
+(_lux_declare-macro lambda'')
-(_lux_def def'
+(_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]))
+ (lambda'' [tokens]
+ (_lux_case tokens
+ (#Cons [[_ (#TagS ["" "export"])]
+ (#Cons [[_ (#FormS (#Cons [name args]))]
+ (#Cons [type (#Cons [body #Nil])])])])
+ (return (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_def"]))
+ (#Cons [name
+ (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_:"]))
+ (#Cons [type
+ (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "lambda''"]))
+ (#Cons [name
+ (#Cons [(_meta (#TupleS args))
+ (#Cons [body #Nil])])])])))
+ #Nil])])])))
+ #Nil])])])))
+ (#Cons [(_meta (#FormS (#Cons [(symbol$ ["" "_lux_export"]) (#Cons [name #Nil])])))
+ #Nil])]))
+
+ (#Cons [[_ (#TagS ["" "export"])] (#Cons [name (#Cons [type (#Cons [body #Nil])])])])
+ (return (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_def"]))
+ (#Cons [name
+ (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_:"]))
+ (#Cons [type
+ (#Cons [body
+ #Nil])])])))
+ #Nil])])])))
+ (#Cons [(_meta (#FormS (#Cons [(symbol$ ["" "_lux_export"]) (#Cons [name #Nil])])))
+ #Nil])]))
+
+ (#Cons [[_ (#FormS (#Cons [name args]))]
+ (#Cons [type (#Cons [body #Nil])])])
+ (return (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_def"]))
+ (#Cons [name
+ (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_:"]))
+ (#Cons [type
+ (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "lambda''"]))
+ (#Cons [name
+ (#Cons [(_meta (#TupleS args))
+ (#Cons [body #Nil])])])])))
+ #Nil])])])))
+ #Nil])])])))
+ #Nil]))
+
+ (#Cons [name (#Cons [type (#Cons [body #Nil])])])
+ (return (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_def"]))
+ (#Cons [name
+ (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_:"]))
+ (#Cons [type
+ (#Cons [body
+ #Nil])])])))
+ #Nil])])])))
+ #Nil]))
- _
- (fail "Wrong syntax for def")
- ))))
-(_lux_declare-macro def')
+ _
+ (fail "Wrong syntax for def''"))
+ )))
+(_lux_declare-macro def'')
-(def' (defmacro tokens)
+(def'' (defmacro' tokens)
Macro
(_lux_case tokens
- (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) (#Cons [body #Nil])])
- (return (#Cons [(form$ (#Cons [(symbol$ ["lux" "def'"])
+ (#Cons [[_ (#FormS (#Cons [name args]))] (#Cons [body #Nil])])
+ (return (#Cons [(form$ (#Cons [(symbol$ ["lux" "def''"])
(#Cons [(form$ (#Cons [name args]))
(#Cons [(symbol$ ["lux" "Macro"])
(#Cons [body
@@ -497,8 +624,8 @@
(#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 [[_ (#TagS ["" "export"])] (#Cons [[_ (#FormS (#Cons [name args]))] (#Cons [body #Nil])])])
+ (return (#Cons [(form$ (#Cons [(symbol$ ["lux" "def''"])
(#Cons [(tag$ ["" "export"])
(#Cons [(form$ (#Cons [name args]))
(#Cons [(symbol$ ["lux" "Macro"])
@@ -509,587 +636,812 @@
#Nil])]))
_
- (fail "Wrong syntax for defmacro")))
-(_lux_declare-macro defmacro)
+ (fail "Wrong syntax for defmacro'")))
+(_lux_declare-macro defmacro')
-(defmacro #export (comment tokens)
+(defmacro' #export (comment tokens)
(return #Nil))
-(defmacro (->' tokens)
+(defmacro' ($' tokens)
(_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]))
+ (#Cons x #Nil)
+ (return tokens)
+
+ (#Cons x (#Cons y xs))
+ (return (#Cons (form$ (#Cons (symbol$ ["lux" "$'"])
+ (#Cons (form$ (#Cons (tag$ ["lux" "AppT"])
+ (#Cons x (#Cons y #Nil))))
+ xs)))
+ #Nil))
_
- (fail "Wrong syntax for ->'")))
+ (fail "Wrong syntax for $'")))
-(defmacro (All' tokens)
- (_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]))
+(def'' (map f xs)
+ (#UnivQ #Nil
+ (#UnivQ #Nil
+ (#LambdaT (#LambdaT (#BoundT 3) (#BoundT 1))
+ (#LambdaT ($' List (#BoundT 3))
+ ($' List (#BoundT 1))))))
+ (_lux_case xs
+ #Nil
+ #Nil
- _
- (fail "Wrong syntax for All'")))
+ (#Cons x xs')
+ (#Cons (f x) (map f xs'))))
-(defmacro (B' tokens)
- (_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]))
+(def'' RepEnv
+ Type
+ ($' List (#TupleT (#Cons Text (#Cons AST #Nil)))))
+
+(def'' (make-env xs ys)
+ (#LambdaT ($' List Text) (#LambdaT ($' List AST) RepEnv))
+ (_lux_case [xs ys]
+ [(#Cons x xs') (#Cons y ys')]
+ (#Cons [x y] (make-env xs' ys'))
_
- (fail "Wrong syntax for B'")))
+ #Nil))
-(defmacro ($' tokens)
- (_lux_case tokens
- (#Cons [x #Nil])
- (return tokens)
+(def'' (text:= x y)
+ (#LambdaT Text (#LambdaT Text Bool))
+ (_jvm_invokevirtual "java.lang.Object" "equals" ["java.lang.Object"]
+ x [y]))
- (#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]))
+(def'' (get-rep key env)
+ (#LambdaT Text (#LambdaT RepEnv ($' Maybe AST)))
+ (_lux_case env
+ #Nil
+ #None
+ (#Cons [k v] env')
+ (_lux_case (text:= k key)
+ true
+ (#Some v)
+
+ false
+ (get-rep key env'))))
+
+(def'' (replace-syntax reps syntax)
+ (#LambdaT RepEnv (#LambdaT AST AST))
+ (_lux_case syntax
+ [_ (#SymbolS "" name)]
+ (_lux_case (get-rep name reps)
+ (#Some replacement)
+ replacement
+
+ #None
+ syntax)
+
+ [meta (#FormS parts)]
+ [meta (#FormS (map (replace-syntax reps) parts))]
+
+ [meta (#TupleS members)]
+ [meta (#TupleS (map (replace-syntax reps) members))]
+
+ [meta (#RecordS slots)]
+ [meta (#RecordS (map (_lux_: (#LambdaT (#TupleT (#Cons AST (#Cons AST #Nil))) (#TupleT (#Cons AST (#Cons AST #Nil))))
+ (lambda'' [slot]
+ (_lux_case slot
+ [k v]
+ [(replace-syntax reps k) (replace-syntax reps v)])))
+ slots))]
+
_
- (fail "Wrong syntax for $'")))
+ syntax)
+ )
+
+(def'' (update-bounds ast)
+ (#LambdaT AST AST)
+ (_lux_case ast
+ [_ (#BoolS value)]
+ (bool$ value)
-(def' (foldL f init xs)
- (All' [a b]
- (->' (->' (B' a) (B' b) (B' a))
- (B' a)
- ($' List (B' b))
- (B' a)))
+ [_ (#IntS value)]
+ (int$ value)
+
+ [_ (#RealS value)]
+ (real$ value)
+
+ [_ (#CharS value)]
+ (char$ value)
+
+ [_ (#TextS value)]
+ (text$ value)
+
+ [_ (#SymbolS value)]
+ (symbol$ value)
+
+ [_ (#TagS value)]
+ (tag$ value)
+
+ [_ (#TupleS members)]
+ (tuple$ (map update-bounds members))
+
+ [_ (#RecordS pairs)]
+ (record$ (map (_lux_: (#LambdaT (#TupleT (#Cons AST (#Cons AST #Nil))) (#TupleT (#Cons AST (#Cons AST #Nil))))
+ (lambda'' [pair]
+ (let'' [name val] pair
+ [name (update-bounds val)])))
+ pairs))
+
+ [_ (#FormS (#Cons [_ (#TagS "lux" "BoundT")] (#Cons [_ (#IntS idx)] #Nil)))]
+ (form$ (#Cons (tag$ ["lux" "BoundT"]) (#Cons (int$ (_jvm_ladd 2 idx)) #Nil)))
+
+ [_ (#FormS members)]
+ (form$ (map update-bounds members)))
+ )
+
+(def'' (parse-univq-args args next)
+ ## (All [a] (-> (List AST) (-> (List Text) (Lux a)) (Lux a)))
+ (#UnivQ #Nil (#LambdaT ($' List AST)
+ (#LambdaT (#LambdaT ($' List Text) (#AppT (#AppT StateE Compiler) (#BoundT 1)))
+ (#AppT (#AppT StateE Compiler) (#BoundT 1)))))
+ (_lux_case args
+ #Nil
+ (next #Nil)
+
+ (#Cons [_ (#SymbolS "" arg-name)] args')
+ (parse-univq-args args' (lambda'' [names] (next (#Cons arg-name names))))
+
+ _
+ (fail "Expected symbol.")))
+
+(def'' (make-bound idx)
+ (#LambdaT Int AST)
+ (form$ (#Cons (tag$ ["lux" "BoundT"]) (#Cons (int$ idx) #Nil))))
+
+(def'' (foldL f init xs)
+ ## (All [a b] (-> (-> a b a) a (List b) a))
+ (#UnivQ #Nil (#UnivQ #Nil (#LambdaT (#LambdaT (#BoundT 3)
+ (#LambdaT (#BoundT 1)
+ (#BoundT 3)))
+ (#LambdaT (#BoundT 3)
+ (#LambdaT ($' List (#BoundT 1))
+ (#BoundT 3))))))
(_lux_case xs
#Nil
init
- (#Cons [x xs'])
+ (#Cons x xs')
(foldL f (f init x) xs')))
-(def' (reverse list)
- (All' [a]
- (->' ($' List (B' a)) ($' List (B' a))))
- (foldL (lambda' [tail head] (#Cons [head tail]))
+(defmacro' #export (All tokens)
+ (let'' [self-name tokens] (_lux_case tokens
+ (#Cons [_ (#SymbolS "" self-name)] tokens)
+ [self-name tokens]
+
+ _
+ ["" tokens])
+ (_lux_case tokens
+ (#Cons [_ (#TupleS args)] (#Cons body #Nil))
+ (parse-univq-args args
+ (lambda'' [names]
+ (let'' body' (foldL (_lux_: (#LambdaT AST (#LambdaT Text AST))
+ (lambda'' [body' name']
+ (form$ (#Cons (tag$ ["lux" "UnivQ"])
+ (#Cons (tag$ ["lux" "Nil"])
+ (#Cons (replace-syntax (#Cons [name' (make-bound 1)] #Nil)
+ (update-bounds body')) #Nil))))))
+ (replace-syntax (#Cons [self-name (make-bound -2)] #Nil)
+ body)
+ names)
+ (return (#Cons body' #Nil)))))
+
+ _
+ (fail "Wrong syntax for All"))
+ ))
+
+(defmacro' #export (Ex tokens)
+ (let'' [self-name tokens] (_lux_case tokens
+ (#Cons [_ (#SymbolS "" self-name)] tokens)
+ [self-name tokens]
+
+ _
+ ["" tokens])
+ (_lux_case tokens
+ (#Cons [_ (#TupleS args)] (#Cons body #Nil))
+ (parse-univq-args args
+ (lambda'' [names]
+ (let'' body' (foldL (_lux_: (#LambdaT AST (#LambdaT Text AST))
+ (lambda'' [body' name']
+ (form$ (#Cons (tag$ ["lux" "ExQ"])
+ (#Cons (tag$ ["lux" "Nil"])
+ (#Cons (replace-syntax (#Cons [name' (make-bound 1)] #Nil)
+ (update-bounds body')) #Nil))))))
+ (replace-syntax (#Cons [self-name (make-bound -2)] #Nil)
+ body)
+ names)
+ (return (#Cons body' #Nil)))))
+
+ _
+ (fail "Wrong syntax for Ex"))
+ ))
+
+(def'' (reverse list)
+ (All [a] (#LambdaT ($' List a) ($' List a)))
+ (foldL (lambda'' [tail head] (#Cons head tail))
#Nil
list))
-(defmacro (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' #export (-> tokens)
+ (_lux_case (reverse tokens)
+ (#Cons output inputs)
+ (return (#Cons (foldL (_lux_: (#LambdaT AST (#LambdaT AST AST))
+ (lambda'' [o i] (form$ (#Cons (tag$ ["lux" "LambdaT"]) (#Cons i (#Cons o #Nil))))))
+ output
+ inputs)
+ #Nil))
+
+ _
+ (fail "Wrong syntax for ->")))
+
+(defmacro' (@list xs)
+ (return (#Cons (foldL (lambda'' [tail head]
+ (form$ (#Cons (tag$ ["lux" "Cons"])
+ (#Cons (tuple$ (#Cons [head (#Cons [tail #Nil])]))
+ #Nil))))
+ (tag$ ["lux" "Nil"])
+ (reverse xs))
+ #Nil)))
-(defmacro (list& xs)
+(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)))
+ (#Cons last init)
+ (return (@list (foldL (lambda'' [tail head]
+ (form$ (@list (tag$ ["lux" "Cons"])
+ (tuple$ (@list head tail)))))
+ last
+ init)))
_
- (fail "Wrong syntax for list&")))
-
-(defmacro #export (lambda tokens)
- (let' [name tokens'] (_lux_: (#TupleT (list Ident ($' List Syntax)))
- (_lux_case tokens
- (#Cons [(#Meta [_ (#SymbolS name)]) tokens'])
- [name tokens']
-
- _
- [["" ""] tokens]))
- (_lux_case tokens'
- (#Cons [(#Meta [_ (#TupleS args)]) (#Cons [body #Nil])])
- (_lux_case args
- #Nil
- (fail "lambda requires a non-empty arguments tuple.")
-
- (#Cons [harg targs])
- (return (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 @list&")))
- _
- (fail "Wrong syntax for lambda"))))
+(defmacro' #export (, tokens)
+ (return (@list (form$ (@list (tag$ ["lux" "TupleT"])
+ (foldL (lambda'' [tail head] (form$ (@list (tag$ ["lux" "Cons"]) head tail)))
+ (tag$ ["lux" "Nil"])
+ (reverse tokens)))))))
+
+(defmacro' (lambda' tokens)
+ (let'' [name tokens'] (_lux_case tokens
+ (#Cons [[_ (#SymbolS ["" name])] tokens'])
+ [name tokens']
-(defmacro (def'' tokens)
+ _
+ ["" tokens])
+ (_lux_case tokens'
+ (#Cons [[_ (#TupleS args)] (#Cons [body #Nil])])
+ (_lux_case args
+ #Nil
+ (fail "lambda' requires a non-empty arguments tuple.")
+
+ (#Cons [harg targs])
+ (return (@list (form$ (@list (symbol$ ["" "_lux_lambda"])
+ (symbol$ ["" name])
+ harg
+ (foldL (lambda'' [body' arg]
+ (form$ (@list (symbol$ ["" "_lux_lambda"])
+ (symbol$ ["" ""])
+ arg
+ body')))
+ body
+ (reverse targs)))))))
+
+ _
+ (fail "Wrong syntax for lambda'"))))
+
+(defmacro' (def''' tokens)
(_lux_case tokens
- (#Cons [(#Meta [_ (#TagS ["" "export"])])
- (#Cons [(#Meta [_ (#FormS (#Cons [name args]))])
+ (#Cons [[_ (#TagS ["" "export"])]
+ (#Cons [[_ (#FormS (#Cons [name args]))]
(#Cons [type (#Cons [body #Nil])])])])
- (return (list (form$ (list (symbol$ ["" "_lux_def"])
- name
- (form$ (list (symbol$ ["" "_lux_:"])
- type
- (form$ (list (symbol$ ["lux" "lambda"])
- name
- (tuple$ args)
- body))))))
- (form$ (list (symbol$ ["" "_lux_export"]) name))))
-
- (#Cons [(#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]))])
+ (return (@list (form$ (@list (symbol$ ["" "_lux_def"])
+ name
+ (form$ (@list (symbol$ ["" "_lux_:"])
+ type
+ (form$ (@list (symbol$ ["lux" "lambda'"])
+ name
+ (tuple$ args)
+ body))))))
+ (form$ (@list (symbol$ ["" "_lux_export"]) name))))
+
+ (#Cons [[_ (#TagS ["" "export"])] (#Cons [name (#Cons [type (#Cons [body #Nil])])])])
+ (return (@list (form$ (@list (symbol$ ["" "_lux_def"])
+ name
+ (form$ (@list (symbol$ ["" "_lux_:"])
+ type
+ body))))
+ (form$ (@list (symbol$ ["" "_lux_export"]) name))))
+
+ (#Cons [[_ (#FormS (#Cons [name args]))]
(#Cons [type (#Cons [body #Nil])])])
- (return (list (form$ (list (symbol$ ["" "_lux_def"])
- name
- (form$ (list (symbol$ ["" "_lux_:"])
- type
- (form$ (list (symbol$ ["lux" "lambda"])
- name
- (tuple$ args)
- body))))))))
+ (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))))))
+ (return (@list (form$ (@list (symbol$ ["" "_lux_def"])
+ name
+ (form$ (@list (symbol$ ["" "_lux_:"]) type body))))))
_
- (fail "Wrong syntax for def")
+ (fail "Wrong syntax for def'")
))
-(def'' (as-pairs xs)
- (All' [a]
- (->' ($' List (B' a)) ($' List (#TupleT (list (B' a) (B' a))))))
+(def''' (as-pairs xs)
+ (All [a] (-> ($' List a) ($' List (, a a))))
(_lux_case xs
- (#Cons [x (#Cons [y xs'])])
- (#Cons [[x y] (as-pairs xs')])
+ (#Cons x (#Cons y xs'))
+ (#Cons [x y] (as-pairs xs'))
_
#Nil))
-(defmacro #export (let tokens)
+(defmacro' (let' tokens)
(_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)))))
+ (#Cons [[_ (#TupleS bindings)] (#Cons [body #Nil])])
+ (return (@list (foldL (_lux_: (-> AST (, AST AST)
+ AST)
+ (lambda' [body binding]
+ (_lux_case binding
+ [label value]
+ (form$ (@list (symbol$ ["" "_lux_case"]) value label body)))))
+ body
+ (reverse (as-pairs bindings)))))
_
- (fail "Wrong syntax for let")))
+ (fail "Wrong syntax for let'")))
-(def'' (map f xs)
- (All' [a b]
- (->' (->' (B' a) (B' b)) ($' List (B' a)) ($' List (B' b))))
- (_lux_case xs
- #Nil
- #Nil
-
- (#Cons [x xs'])
- (#Cons [(f x) (map f xs')])))
-
-(def'' (any? p xs)
- (All' [a]
- (->' (->' (B' a) Bool) ($' List (B' a)) Bool))
+(def''' (any? p xs)
+ (All [a]
+ (-> (-> a Bool) ($' List a) Bool))
(_lux_case xs
#Nil
false
- (#Cons [x xs'])
+ (#Cons x xs')
(_lux_case (p x)
true true
false (any? p xs'))))
-(def'' (spliced? token)
- (->' Syntax Bool)
+(def''' (spliced? token)
+ (-> AST Bool)
(_lux_case token
- (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS ["" "~@"])]) (#Cons [_ #Nil])]))])
+ [_ (#FormS (#Cons [[_ (#SymbolS ["" "~@"])] (#Cons [_ #Nil])]))]
true
_
false))
-(def'' (wrap-meta content)
- (->' Syntax Syntax)
- (_meta (#FormS (list (_meta (#TagS ["lux" "Meta"]))
- (_meta (#TupleS (list (_meta (#TupleS (list (_meta (#TextS "")) (_meta (#IntS -1)) (_meta (#IntS -1)))))
- content)))))))
+(def''' (wrap-meta content)
+ (-> AST AST)
+ (tuple$ (@list (tuple$ (@list (text$ "") (int$ -1) (int$ -1)))
+ content)))
-(def'' (untemplate-list tokens)
- (->' ($' List Syntax) Syntax)
+(def''' (untemplate-list tokens)
+ (-> ($' List AST) AST)
(_lux_case tokens
#Nil
(_meta (#TagS ["lux" "Nil"]))
(#Cons [token tokens'])
- (_meta (#FormS (list (_meta (#TagS ["lux" "Cons"]))
- (_meta (#TupleS (list token (untemplate-list tokens')))))))))
+ (_meta (#FormS (@list (_meta (#TagS ["lux" "Cons"])) token (untemplate-list tokens'))))))
-(def'' #export (list:++ xs ys)
- (All' [a] (->' ($' List (B' a)) ($' List (B' a)) ($' List (B' a))))
+(def''' (list:++ xs ys)
+ (All [a] (-> ($' List a) ($' List a) ($' List a)))
(_lux_case xs
- (#Cons [x xs'])
- (#Cons [x (list:++ xs' ys)])
+ (#Cons x xs')
+ (#Cons x (list:++ xs' ys))
#Nil
ys))
-(defmacro #export ($ tokens)
+(def''' #export (splice-helper xs ys)
+ (-> ($' List AST) ($' List AST) ($' List AST))
+ (_lux_case xs
+ (#Cons x xs')
+ (#Cons x (splice-helper xs' ys))
+
+ #Nil
+ ys))
+
+(defmacro' #export ($ tokens)
(_lux_case tokens
- (#Cons [op (#Cons [init args])])
- (return (list (foldL (lambda [a1 a2] (form$ (list op a1 a2)))
- init
- args)))
+ (#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)
+## (deftype (Lux a)
+## (-> Compiler (Either Text (, Compiler a))))
+(def''' #export Lux
+ Type
+ (#NamedT ["lux" "Lux"]
+ (All [a]
+ (-> Compiler ($' Either Text (, Compiler a))))))
+
+## (defsig (Monad m)
+## (: (All [a] (-> a (m a)))
+## return)
+## (: (All [a b] (-> (-> a (m b)) (m a) (m b)))
+## bind))
+(def''' Monad
+ Type
+ (#NamedT ["lux" "Monad"]
+ (All [m]
+ (, (All [a] (-> a ($' m a)))
+ (All [a b] (-> (-> a ($' m b))
+ ($' m a)
+ ($' m b)))))))
+(_lux_declare-tags [#return #bind] Monad)
+
+(def''' Maybe/Monad
+ ($' Monad Maybe)
+ {#return
+ (lambda' return [x]
+ (#Some x))
+
+ #bind
+ (lambda' [f ma]
+ (_lux_case ma
+ #None #None
+ (#Some a) (f a)))})
+
+(def''' Lux/Monad
+ ($' Monad Lux)
+ {#return
+ (lambda' [x]
+ (lambda' [state]
+ (#Right state x)))
+
+ #bind
+ (lambda' [f ma]
+ (lambda' [state]
+ (_lux_case (ma state)
+ (#Left msg)
+ (#Left msg)
+
+ (#Right state' a)
+ (f a state'))))})
+
+(defmacro' (do tokens)
+ (_lux_case tokens
+ (#Cons monad (#Cons [_ (#TupleS bindings)] (#Cons body #Nil)))
+ (let' [g!wrap (symbol$ ["" "wrap"])
+ g!bind (symbol$ ["" "12bind34"])
+ body' (foldL (_lux_: (-> AST (, AST AST) AST)
+ (lambda' [body' binding]
+ (let' [[var value] binding]
+ (_lux_case var
+ [_ (#TagS "" "let")]
+ (form$ (@list (symbol$ ["lux" "let'"]) value body'))
+
+ _
+ (form$ (@list g!bind
+ (form$ (@list (symbol$ ["" "_lux_lambda"]) (symbol$ ["" ""]) var body'))
+ value))))))
+ body
+ (reverse (as-pairs bindings)))]
+ (return (@list (form$ (@list (symbol$ ["" "_lux_case"])
+ monad
+ (record$ (@list [(tag$ ["lux" "return"]) g!wrap] [(tag$ ["lux" "bind"]) g!bind]))
+ body')))))
+
+ _
+ (fail "Wrong syntax for do")))
+
+(def''' (map% m f xs)
+ ## (All [m a b]
+ ## (-> (Monad m) (-> a (m b)) (List a) (m (List b))))
+ (All [m a b]
+ (-> ($' Monad m)
+ (-> a ($' m b))
+ ($' List a)
+ ($' m ($' List b))))
+ (let' [{#;return wrap #;bind _} m]
+ (_lux_case xs
+ #Nil
+ (wrap #Nil)
+
+ (#Cons x xs')
+ (do m
+ [y (f x)
+ ys (map% m f xs')]
+ (wrap (#Cons y ys)))
+ )))
+
+(defmacro' #export (if tokens)
+ (_lux_case tokens
+ (#Cons test (#Cons then (#Cons else #Nil)))
+ (return (@list (form$ (@list (symbol$ ["" "_lux_case"]) test
+ (bool$ true) then
+ (bool$ false) else))))
+
+ _
+ (fail "Wrong syntax for if")))
+
+(def''' (get k plist)
+ (All [a]
+ (-> Text ($' List (, Text a)) ($' Maybe a)))
+ (_lux_case plist
+ (#Cons [[k' v] plist'])
+ (if (text:= k k')
+ (#Some v)
+ (get k plist'))
+
+ #Nil
+ #None))
+
+(def''' (put k v dict)
+ (All [a]
+ (-> Text a ($' List (, Text a)) ($' List (, Text a))))
+ (_lux_case dict
+ #Nil
+ (@list [k v])
+
+ (#Cons [[k' v'] dict'])
+ (if (text:= k k')
+ (#Cons [[k' v] dict'])
+ (#Cons [[k' v'] (put k v dict')]))))
+
+(def''' (text:++ x y)
+ (-> Text Text Text)
+ (_jvm_invokevirtual "java.lang.String" "concat" ["java.lang.String"]
+ x [y]))
+
+(def''' (ident->text ident)
+ (-> Ident Text)
+ (let' [[module name] ident]
+ ($ text:++ module ";" name)))
+
+(def''' (resolve-global-symbol ident state)
+ (-> Ident ($' Lux Ident))
+ (let' [[module name] ident
+ {#source source #modules modules
+ #envs envs #type-vars types #host host
+ #seed seed #eval? eval? #expected expected
+ #cursor cursor} state]
+ (_lux_case (get module modules)
+ (#Some {#module-aliases _ #defs defs #imports _ #tags tags #types types})
+ (_lux_case (get name defs)
+ (#Some [_ def-data])
+ (_lux_case def-data
+ (#AliasD real-name)
+ (#Right [state real-name])
+
+ _
+ (#Right [state ident]))
+
+ #None
+ (#Left ($ text:++ "Unknown definition: " (ident->text ident))))
+
+ #None
+ (#Left ($ text:++ "Unknown module: " module " @ " (ident->text ident))))))
+
+(def''' (splice replace? untemplate tag elems)
+ (-> Bool (-> AST ($' Lux AST)) AST ($' List AST) ($' Lux AST))
(_lux_case replace?
true
(_lux_case (any? spliced? elems)
true
- (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'))))))
+ (do Lux/Monad
+ [elems' (_lux_: ($' Lux ($' List AST))
+ (map% Lux/Monad
+ (_lux_: (-> AST ($' Lux AST))
+ (lambda' [elem]
+ (_lux_case elem
+ [_ (#FormS (#Cons [[_ (#SymbolS ["" "~@"])] (#Cons [spliced #Nil])]))]
+ (wrap spliced)
+
+ _
+ (do Lux/Monad
+ [=elem (untemplate elem)]
+ (wrap (form$ (@list (symbol$ ["" "_lux_:"])
+ (form$ (@list (tag$ ["lux" "AppT"]) (tuple$ (@list (symbol$ ["lux" "List"]) (symbol$ ["lux" "AST"])))))
+ (form$ (@list (tag$ ["lux" "Cons"]) (tuple$ (@list =elem (tag$ ["lux" "Nil"]))))))))))))
+ elems))]
+ (wrap (wrap-meta (form$ (@list tag
+ (form$ (@list& (symbol$ ["lux" "$"])
+ (symbol$ ["lux" "splice-helper"])
+ elems')))))))
false
- (wrap-meta (form$ (list tag (untemplate-list (map untemplate elems))))))
+ (do Lux/Monad
+ [=elems (map% Lux/Monad untemplate elems)]
+ (wrap (wrap-meta (form$ (@list tag (untemplate-list =elems)))))))
false
- (wrap-meta (form$ (list tag (untemplate-list (map untemplate elems)))))))
+ (do Lux/Monad
+ [=elems (map% Lux/Monad untemplate elems)]
+ (wrap (wrap-meta (form$ (@list tag (untemplate-list =elems))))))))
-(def'' (untemplate replace? subst token)
- (->' Bool Text Syntax Syntax)
- (_lux_case (_lux_: (#TupleT (list Bool Syntax)) [replace? token])
- [_ (#Meta [_ (#BoolS value)])]
- (wrap-meta (form$ (list (tag$ ["lux" "BoolS"]) (_meta (#BoolS value)))))
+(def''' (untemplate replace? subst token)
+ (-> Bool Text AST ($' Lux AST))
+ (_lux_case [replace? token]
+ [_ [_ (#BoolS value)]]
+ (return (wrap-meta (form$ (@list (tag$ ["lux" "BoolS"]) (bool$ value)))))
- [_ (#Meta [_ (#IntS value)])]
- (wrap-meta (form$ (list (tag$ ["lux" "IntS"]) (_meta (#IntS value)))))
+ [_ [_ (#IntS value)]]
+ (return (wrap-meta (form$ (@list (tag$ ["lux" "IntS"]) (int$ value)))))
- [_ (#Meta [_ (#RealS value)])]
- (wrap-meta (form$ (list (tag$ ["lux" "RealS"]) (_meta (#RealS value)))))
+ [_ [_ (#RealS value)]]
+ (return (wrap-meta (form$ (@list (tag$ ["lux" "RealS"]) (real$ value)))))
- [_ (#Meta [_ (#CharS value)])]
- (wrap-meta (form$ (list (tag$ ["lux" "CharS"]) (_meta (#CharS value)))))
+ [_ [_ (#CharS value)]]
+ (return (wrap-meta (form$ (@list (tag$ ["lux" "CharS"]) (char$ value)))))
- [_ (#Meta [_ (#TextS value)])]
- (wrap-meta (form$ (list (tag$ ["lux" "TextS"]) (_meta (#TextS value)))))
+ [_ [_ (#TextS value)]]
+ (return (wrap-meta (form$ (@list (tag$ ["lux" "TextS"]) (text$ value)))))
- [_ (#Meta [_ (#TagS [module name])])]
- (let [module' (_lux_case module
- ""
- subst
+ [_ [_ (#TagS [module name])]]
+ (let' [module' (_lux_case module
+ ""
+ subst
- _
- module)]
- (wrap-meta (form$ (list (tag$ ["lux" "TagS"]) (tuple$ (list (text$ module') (text$ name)))))))
+ _
+ module)]
+ (return (wrap-meta (form$ (@list (tag$ ["lux" "TagS"]) (tuple$ (@list (text$ module') (text$ name))))))))
- [_ (#Meta [_ (#SymbolS [module name])])]
- (let [module' (_lux_case module
- ""
- subst
+ [true [_ (#SymbolS [module name])]]
+ (do Lux/Monad
+ [real-name (_lux_case module
+ ""
+ (resolve-global-symbol [subst name])
- _
- module)]
- (wrap-meta (form$ (list (tag$ ["lux" "SymbolS"]) (tuple$ (list (text$ module') (text$ name)))))))
+ _
+ (wrap [module name]))
+ #let [[module name] real-name]]
+ (return (wrap-meta (form$ (@list (tag$ ["lux" "SymbolS"]) (tuple$ (@list (text$ module) (text$ name))))))))
- [_ (#Meta [_ (#TupleS elems)])]
+ [false [_ (#SymbolS [module name])]]
+ (return (wrap-meta (form$ (@list (tag$ ["lux" "SymbolS"]) (tuple$ (@list (text$ module) (text$ name)))))))
+
+ [_ [_ (#TupleS elems)]]
(splice replace? (untemplate replace? subst) (tag$ ["lux" "TupleS"]) elems)
- [true (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS ["" "~"])]) (#Cons [unquoted #Nil])]))])]
- unquoted
+ [true [_ (#FormS (#Cons [[_ (#SymbolS ["" "~"])] (#Cons [unquoted #Nil])]))]]
+ (return unquoted)
- [_ (#Meta [meta (#FormS elems)])]
- (let [(#Meta [_ form']) (splice replace? (untemplate replace? subst) (tag$ ["lux" "FormS"]) elems)]
- (#Meta [meta form']))
+ [_ [meta (#FormS elems)]]
+ (do Lux/Monad
+ [output (splice replace? (untemplate replace? subst) (tag$ ["lux" "FormS"]) elems)
+ #let [[_ form'] output]]
+ (return [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)))))
+ [_ [_ (#RecordS fields)]]
+ (do Lux/Monad
+ [=fields (map% Lux/Monad
+ (_lux_: (-> (, AST AST) ($' Lux AST))
+ (lambda' [kv]
+ (let' [[k v] kv]
+ (do Lux/Monad
+ [=k (untemplate replace? subst k)
+ =v (untemplate replace? subst v)]
+ (wrap (tuple$ (@list =k =v)))))))
+ fields)]
+ (wrap (wrap-meta (form$ (@list (tag$ ["lux" "RecordS"]) (untemplate-list =fields))))))
))
-(defmacro (`' tokens)
+(defmacro' #export (^ tokens)
(_lux_case tokens
- (#Cons [template #Nil])
- (return (list (untemplate true "" template)))
-
- _
- (fail "Wrong syntax for `'")))
+ (#Cons [_ (#SymbolS "" class-name)] #Nil)
+ (return (@list (form$ (@list (tag$ ["lux" "DataT"]) (text$ class-name) (tag$ ["lux" "Nil"])))))
-(defmacro (' tokens)
- (_lux_case tokens
- (#Cons [template #Nil])
- (return (list (untemplate false "" template)))
+ (#Cons [_ (#SymbolS "" class-name)] params)
+ (return (@list (form$ (@list (tag$ ["lux" "DataT"]) (text$ class-name) (untemplate-list params)))))
_
- (fail "Wrong syntax for '")))
+ (fail "Wrong syntax for ^")))
-(defmacro #export (|> tokens)
- (_lux_case tokens
- (#Cons [init apps])
- (return (list (foldL (lambda [acc app]
- (_lux_case app
- (#Meta [_ (#TupleS parts)])
- (tuple$ (list:++ parts (list acc)))
+(def'' (get-module-name state)
+ ($' Lux Text)
+ (_lux_case state
+ {#source source #modules modules
+ #envs envs #type-vars types #host host
+ #seed seed #eval? eval? #expected expected
+ #cursor cursor}
+ (_lux_case (reverse envs)
+ #Nil
+ (#Left "Can't get the module name without a module!")
- (#Meta [_ (#FormS parts)])
- (form$ (list:++ parts (list acc)))
+ (#Cons {#name module-name #inner-closures _ #locals _ #closure _} _)
+ (#Right [state module-name]))))
- _
- (`' ((~ app) (~ acc)))))
- init
- apps)))
+(defmacro' #export (` tokens)
+ (_lux_case tokens
+ (#Cons template #Nil)
+ (do Lux/Monad
+ [current-module get-module-name
+ =template (untemplate true current-module template)]
+ (wrap (@list (form$ (@list (symbol$ ["" "_lux_:"]) (symbol$ ["lux" "AST"]) =template)))))
_
- (fail "Wrong syntax for |>")))
+ (fail "Wrong syntax for `")))
-(defmacro #export (if tokens)
+(defmacro' #export (' tokens)
(_lux_case tokens
- (#Cons [test (#Cons [then (#Cons [else #Nil])])])
- (return (list (`' (_lux_case (~ test)
- true (~ then)
- false (~ else)))))
+ (#Cons template #Nil)
+ (do Lux/Monad
+ [=template (untemplate false "" template)]
+ (wrap (@list (form$ (@list (symbol$ ["" "_lux_:"]) (symbol$ ["lux" "AST"]) =template)))))
_
- (fail "Wrong syntax for if")))
-
-## (deftype (Lux a)
-## (-> Compiler (Either Text (, Compiler a))))
-(def'' #export Lux
- Type
- (All' [a]
- (->' Compiler ($' Either Text (#TupleT (list Compiler (B' a)))))))
-
-## (defsig (Monad m)
-## (: (All [a] (-> a (m a)))
-## return)
-## (: (All [a b] (-> (-> a (m b)) (m a) (m b)))
-## bind))
-(def'' Monad
- Type
- (All' [m]
- (#RecordT (list ["lux;return" (All' [a] (->' (B' a) ($' (B' m) (B' a))))]
- ["lux;bind" (All' [a b] (->' (->' (B' a) ($' (B' m) (B' b)))
- ($' (B' m) (B' a))
- ($' (B' m) (B' b))))]))))
-
-(def'' Maybe/Monad
- ($' Monad Maybe)
- {#lux;return
- (lambda return [x]
- (#Some x))
-
- #lux;bind
- (lambda [f ma]
- (_lux_case ma
- #None #None
- (#Some a) (f a)))})
-
-(def'' Lux/Monad
- ($' Monad Lux)
- {#lux;return
- (lambda [x]
- (lambda [state]
- (#Right [state x])))
-
- #lux;bind
- (lambda [f ma]
- (lambda [state]
- (_lux_case (ma state)
- (#Left msg)
- (#Left msg)
-
- (#Right [state' a])
- (f a state'))))})
+ (fail "Wrong syntax for '")))
-(defmacro #export (^ tokens)
+(defmacro' #export (|> tokens)
(_lux_case tokens
- (#Cons [(#Meta [_ (#SymbolS ["" class-name])]) #Nil])
- (return (list (`' (#;DataT (~ (_meta (#TextS class-name)))))))
+ (#Cons [init apps])
+ (return (@list (foldL (_lux_: (-> AST AST AST)
+ (lambda' [acc app]
+ (_lux_case app
+ [_ (#TupleS parts)]
+ (tuple$ (list:++ parts (@list acc)))
- _
- (fail "Wrong syntax for ^")))
+ [_ (#FormS parts)]
+ (form$ (list:++ parts (@list acc)))
+
+ _
+ (` ((~ app) (~ acc))))))
+ init
+ apps)))
-(defmacro #export (-> tokens)
- (_lux_case (reverse tokens)
- (#Cons [output inputs])
- (return (list (foldL (lambda [o i] (`' (#;LambdaT [(~ i) (~ o)])))
- output
- inputs)))
-
_
- (fail "Wrong syntax for ->")))
+ (fail "Wrong syntax for |>")))
-(defmacro #export (, tokens)
- (return (list (`' (#;TupleT (~ (untemplate-list tokens)))))))
+(def''' (. f g)
+ (All [a b c]
+ (-> (-> b c) (-> a b) (-> a c)))
+ (lambda' [x]
+ (f (g x))))
-(defmacro (do tokens)
- (_lux_case tokens
- (#Cons [monad (#Cons [(#Meta [_ (#TupleS bindings)]) (#Cons [body #Nil])])])
- (let [body' (foldL (_lux_: (-> Syntax (, Syntax Syntax) Syntax)
- (lambda [body' binding]
- (let [[var value] binding]
- (_lux_case var
- (#Meta [_ (#TagS ["" "let"])])
- (`' (;let (~ value) (~ body')))
-
- _
- (`' (;bind (_lux_lambda (~ (symbol$ ["" ""]))
- (~ var)
- (~ body'))
- (~ value)))))))
- body
- (reverse (as-pairs bindings)))]
- (return (list (`' (_lux_case (~ monad)
- {#;return ;return #;bind ;bind}
- (~ body'))))))
+(def''' (get-ident x)
+ (-> AST ($' Maybe Ident))
+ (_lux_case x
+ [_ (#SymbolS sname)]
+ (#Some sname)
_
- (fail "Wrong syntax for do")))
+ #None))
-(def'' (map% m f xs)
- ## (All [m a b]
- ## (-> (Monad m) (-> a (m b)) (List a) (m (List b))))
- (All' [m a b]
- (-> ($' Monad (B' m))
- (-> (B' a) ($' (B' m) (B' b)))
- ($' List (B' a))
- ($' (B' m) ($' List (B' b)))))
- (let [{#;return ;return #;bind _} m]
- (_lux_case xs
- #Nil
- (;return #Nil)
-
- (#Cons [x xs'])
- (do m
- [y (f x)
- ys (map% m f xs')]
- (;return (#Cons [y ys])))
- )))
+(def''' (get-tag x)
+ (-> AST ($' Maybe Ident))
+ (_lux_case x
+ [_ (#TagS sname)]
+ (#Some sname)
-(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))))
+ _
+ #None))
-(def'' (get-ident x)
- (-> Syntax ($' Maybe Text))
+(def''' (get-name x)
+ (-> AST ($' Maybe Text))
(_lux_case x
- (#Meta [_ (#SymbolS ["" sname])])
+ [_ (#SymbolS "" sname)]
(#Some sname)
_
#None))
-(def'' (tuple->list tuple)
- (-> Syntax ($' Maybe ($' List Syntax)))
+(def''' (tuple->list tuple)
+ (-> AST ($' Maybe ($' List AST)))
(_lux_case tuple
- (#Meta [_ (#TupleS members)])
+ [_ (#TupleS members)]
(#Some members)
_
#None))
-(def'' RepEnv
- Type
- ($' List (, Text Syntax)))
-
-(def'' (make-env xs ys)
- (-> ($' List Text) ($' List Syntax) RepEnv)
- (_lux_case (_lux_: (, ($' List Text) ($' List Syntax))
- [xs ys])
- [(#Cons [x xs']) (#Cons [y ys'])]
- (#Cons [[x y] (make-env xs' ys')])
-
- _
- #Nil))
-
-(def'' (text:= x y)
- (-> Text Text Bool)
- (_jvm_invokevirtual "java.lang.Object" "equals" ["java.lang.Object"]
- x [y]))
-
-(def'' (get-rep key env)
- (-> Text RepEnv ($' Maybe Syntax))
- (_lux_case env
- #Nil
- #None
-
- (#Cons [[k v] env'])
- (if (text:= k key)
- (#Some v)
- (get-rep key env'))))
-
-(def'' (apply-template env template)
- (-> RepEnv Syntax Syntax)
+(def''' (apply-template env template)
+ (-> RepEnv AST AST)
(_lux_case template
- (#Meta [_ (#SymbolS ["" sname])])
+ [_ (#SymbolS "" sname)]
(_lux_case (get-rep sname env)
(#Some subst)
subst
@@ -1097,25 +1449,25 @@
_
template)
- (#Meta [_ (#TupleS elems)])
+ [_ (#TupleS elems)]
(tuple$ (map (apply-template env) elems))
- (#Meta [_ (#FormS elems)])
+ [_ (#FormS elems)]
(form$ (map (apply-template env) elems))
- (#Meta [_ (#RecordS members)])
- (record$ (map (_lux_: (-> (, Syntax Syntax) (, Syntax Syntax))
- (lambda [kv]
- (let [[slot value] kv]
- [(apply-template env slot) (apply-template env value)])))
+ [_ (#RecordS members)]
+ (record$ (map (_lux_: (-> (, AST AST) (, AST AST))
+ (lambda' [kv]
+ (let' [[slot value] kv]
+ [(apply-template env slot) (apply-template env value)])))
members))
_
template))
-(def'' (join-map f xs)
- (All' [a b]
- (-> (-> (B' a) ($' List (B' b))) ($' List (B' a)) ($' List (B' b))))
+(def''' (join-map f xs)
+ (All [a b]
+ (-> (-> a ($' List b)) ($' List a) ($' List b)))
(_lux_case xs
#Nil
#Nil
@@ -1123,18 +1475,17 @@
(#Cons [x xs'])
(list:++ (f x) (join-map f xs'))))
-(defmacro #export (do-template tokens)
+(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)])
+ (#Cons [[_ (#TupleS bindings)] (#Cons [[_ (#TupleS templates)] data])])
+ (_lux_case [(map% Maybe/Monad get-name bindings)
+ (map% Maybe/Monad tuple->list data)]
[(#Some bindings') (#Some data')]
- (let [apply (_lux_: (-> RepEnv ($' List Syntax))
- (lambda [env] (map (apply-template env) templates)))]
- (|> data'
- (join-map (. apply (make-env bindings')))
- return))
+ (let' [apply (_lux_: (-> RepEnv ($' List AST))
+ (lambda' [env] (map (apply-template env) templates)))]
+ (|> data'
+ (join-map (. apply (make-env bindings')))
+ return))
_
(fail "Wrong syntax for do-template"))
@@ -1143,20 +1494,17 @@
(fail "Wrong syntax for do-template")))
(do-template [<name> <cmp> <type>]
- [(def'' #export (<name> x y)
+ [(def''' (<name> x y)
(-> <type> <type> Bool)
(<cmp> x y))]
[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)
+ [(def''' (<name> x y)
(-> <type> <type> Bool)
(if (<cmp> x y)
true
@@ -1164,12 +1512,10 @@
[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''' (<name> x y)
(-> <type> <type> <type>)
(<cmp> x y))]
@@ -1178,143 +1524,33 @@
[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)
(i= 0 (i% n div)))
-(def'' (length list)
- (-> List Int)
- (foldL (lambda [acc _] (i+ 1 acc)) 0 list))
+(def''' (length list)
+ (All [a] (-> ($' List a) Int))
+ (foldL (lambda' [acc _] (_jvm_ladd 1 acc)) 0 list))
-(def'' #export (not x)
+(def''' #export (not x)
(-> Bool Bool)
(if x false true))
-(def'' (text:++ x y)
- (-> Text Text Text)
- (_jvm_invokevirtual "java.lang.String" "concat" ["java.lang.String"]
- x [y]))
-
-(def'' (ident->text ident)
- (-> Ident Text)
- (let [[module name] ident]
- ($ text:++ module ";" name)))
-
-(def'' (replace-syntax reps syntax)
- (-> RepEnv Syntax Syntax)
- (_lux_case syntax
- (#Meta [_ (#SymbolS ["" name])])
- (_lux_case (get-rep name reps)
- (#Some replacement)
- replacement
-
- #None
- syntax)
-
- (#Meta [_ (#FormS parts)])
- (#Meta [_ (#FormS (map (replace-syntax reps) parts))])
-
- (#Meta [_ (#TupleS members)])
- (#Meta [_ (#TupleS (map (replace-syntax reps) members))])
-
- (#Meta [_ (#RecordS slots)])
- (#Meta [_ (#RecordS (map (_lux_: (-> (, Syntax Syntax) (, Syntax Syntax))
- (lambda [slot]
- (let [[k v] slot]
- [(replace-syntax reps k) (replace-syntax reps v)])))
- slots))])
-
- _
- syntax)
- )
-
-(defmacro #export (All tokens)
- (let [[self-ident tokens'] (_lux_: (, Text SyntaxList)
- (_lux_case tokens
- (#Cons [(#Meta [_ (#SymbolS ["" self-ident])]) tokens'])
- [self-ident tokens']
-
- _
- ["" tokens]))]
- (_lux_case tokens'
- (#Cons [(#Meta [_ (#TupleS args)]) (#Cons [body #Nil])])
- (_lux_case (map% Maybe/Monad get-ident args)
- (#Some idents)
- (_lux_case idents
- #Nil
- (return (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)
- (All [a]
- (-> Text ($' List (, Text a)) ($' Maybe a)))
- (_lux_case plist
- (#Cons [[k' v] plist'])
- (if (text:= k k')
- (#Some v)
- (get k plist'))
-
- #Nil
- #None))
-
-(def'' (put k v dict)
- (All [a]
- (-> Text a ($' List (, Text a)) ($' List (, Text a))))
- (_lux_case dict
- #Nil
- (list [k v])
-
- (#Cons [[k' v'] dict'])
- (if (text:= k k')
- (#Cons [[k' v] dict'])
- (#Cons [[k' v'] (put k v dict')]))))
-
-(def'' (get-module-name state)
- ($' Lux Text)
- (_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''' (->text x)
+ (-> (^ java.lang.Object) Text)
+ (_jvm_invokevirtual "java.lang.Object" "toString" [] x []))
-(def'' (find-macro' modules current-module module name)
+(def''' (find-macro' modules current-module module name)
(-> ($' List (, Text ($' Module Compiler)))
Text Text Text
($' Maybe Macro))
(do Maybe/Monad
[$module (get module modules)
- gdef (let [{#module-aliases _ #defs bindings #imports _} (_lux_: ($' Module Compiler) $module)]
- (get name bindings))]
- (_lux_case (_lux_: (, Bool ($' DefData' Macro)) gdef)
+ gdef (let' [{#module-aliases _ #defs bindings #imports _ #tags tags #types types} (_lux_: ($' Module Compiler) $module)]
+ (get name bindings))]
+ (_lux_case (_lux_: Definition gdef)
[exported? (#MacroD macro')]
(if exported?
(#Some macro')
@@ -1328,78 +1564,45 @@
_
#None)))
-(def'' (find-macro ident)
- (-> Ident ($' Lux ($' Maybe Macro)))
- (do Lux/Monad
- [current-module get-module-name]
- (let [[module name] ident]
- (lambda [state]
- (_lux_case state
- {#source source #modules modules
- #envs envs #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)))
- (foldL list:++ #Nil xs))
-
-(def'' (normalize ident)
+(def''' (normalize ident)
(-> Ident ($' Lux Ident))
(_lux_case ident
["" name]
(do Lux/Monad
[module-name get-module-name]
- (;return (_lux_: Ident [module-name name])))
+ (wrap [module-name name]))
_
(return ident)))
-(defmacro #export (| tokens)
+(def''' (find-macro ident)
+ (-> Ident ($' Lux ($' Maybe Macro)))
(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 (list (`' (#;VariantT (~ (untemplate-list pairs))))))))
+ [current-module get-module-name]
+ (let' [[module name] ident]
+ (lambda' [state]
+ (_lux_case state
+ {#source source #modules modules
+ #envs envs #type-vars types #host host
+ #seed seed #eval? eval? #expected expected
+ #cursor cursor}
+ (#Right state (find-macro' modules current-module module name)))))))
+
+(def''' (macro? ident)
+ (-> Ident ($' Lux Bool))
+ (do Lux/Monad
+ [ident (normalize ident)
+ output (find-macro ident)]
+ (wrap (_lux_case output
+ (#Some _) true
+ #None false))))
-(defmacro #export (& tokens)
- (if (not (multiple? 2 (length tokens)))
- (fail "& expects an even number of arguments.")
- (do Lux/Monad
- [pairs (map% Lux/Monad
- (_lux_: (-> (, Syntax Syntax) ($' Lux Syntax))
- (lambda [pair]
- (_lux_case pair
- [(#Meta [_ (#TagS ident)]) value]
- (do Lux/Monad
- [ident (normalize ident)]
- (;return (`' [(~ (text$ (ident->text ident))) (~ value)])))
-
- _
- (fail "Wrong syntax for &"))))
- (as-pairs tokens))]
- (;return (list (`' (#;RecordT (~ (untemplate-list pairs)))))))))
-
-(def'' #export (->text x)
- (-> (^ java.lang.Object) Text)
- (_jvm_invokevirtual "java.lang.Object" "toString" [] x []))
+(def''' (list:join xs)
+ (All [a]
+ (-> ($' List ($' List a)) ($' List a)))
+ (foldL list:++ #Nil xs))
-(def'' (interpose sep xs)
+(def''' (interpose sep xs)
(All [a]
(-> a ($' List a) ($' List a)))
(_lux_case xs
@@ -1410,12 +1613,12 @@
xs
(#Cons [x xs'])
- (list& x sep (interpose sep xs'))))
+ (@list& x sep (interpose sep xs'))))
-(def'' (macro-expand syntax)
- (-> Syntax ($' Lux ($' List Syntax)))
- (_lux_case syntax
- (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS macro-name)]) args]))])
+(def''' (macro-expand token)
+ (-> AST ($' Lux ($' List AST)))
+ (_lux_case token
+ [_ (#FormS (#Cons [_ (#SymbolS macro-name)] args))]
(do Lux/Monad
[macro-name' (normalize macro-name)
?macro (find-macro macro-name')]
@@ -1424,272 +1627,347 @@
(do Lux/Monad
[expansion (macro args)
expansion' (map% Lux/Monad macro-expand expansion)]
- (;return (list:join expansion')))
+ (wrap (list:join expansion')))
+
+ #None
+ (return (@list token))))
+
+ _
+ (return (@list token))))
+
+(def''' (macro-expand-all syntax)
+ (-> AST ($' Lux ($' List AST)))
+ (_lux_case syntax
+ [_ (#FormS (#Cons [_ (#SymbolS macro-name)] args))]
+ (do Lux/Monad
+ [macro-name' (normalize macro-name)
+ ?macro (find-macro macro-name')]
+ (_lux_case ?macro
+ (#Some macro)
+ (do Lux/Monad
+ [expansion (macro args)
+ expansion' (map% Lux/Monad macro-expand-all expansion)]
+ (wrap (list:join expansion')))
#None
(do Lux/Monad
- [parts' (map% Lux/Monad macro-expand (list& (symbol$ macro-name) args))]
- (;return (list (form$ (list:join parts')))))))
+ [args' (map% Lux/Monad macro-expand-all args)]
+ (wrap (@list (form$ (#Cons (symbol$ macro-name) (list:join args'))))))))
- (#Meta [_ (#FormS (#Cons [harg targs]))])
+ [_ (#FormS members)]
(do Lux/Monad
- [harg+ (macro-expand harg)
- targs+ (map% Lux/Monad macro-expand targs)]
- (;return (list (form$ (list:++ harg+ (list:join targs+))))))
+ [members' (map% Lux/Monad macro-expand-all members)]
+ (wrap (@list (form$ (list:join members')))))
- (#Meta [_ (#TupleS members)])
+ [_ (#TupleS members)]
(do Lux/Monad
- [members' (map% Lux/Monad macro-expand members)]
- (;return (list (tuple$ (list:join members')))))
+ [members' (map% Lux/Monad macro-expand-all members)]
+ (wrap (@list (tuple$ (list:join members')))))
_
- (return (list syntax))))
+ (return (@list syntax))))
-(def'' (walk-type type)
- (-> Syntax Syntax)
+(def''' (walk-type type)
+ (-> AST AST)
(_lux_case type
- (#Meta [_ (#FormS (#Cons [(#Meta [_ (#TagS tag)]) parts]))])
+ [_ (#FormS (#Cons [[_ (#TagS tag)] parts]))]
(form$ (#Cons [(tag$ tag) (map walk-type parts)]))
- (#Meta [_ (#TupleS members)])
+ [_ (#TupleS members)]
(tuple$ (map walk-type members))
- (#Meta [_ (#FormS (#Cons [type-fn args]))])
- (foldL (lambda [type-fn arg] (`' (#;AppT [(~ type-fn) (~ arg)])))
+ [_ (#FormS (#Cons [type-fn args]))]
+ (foldL (_lux_: (-> AST AST AST)
+ (lambda' [type-fn arg] (` (#;AppT [(~ type-fn) (~ arg)]))))
(walk-type type-fn)
(map walk-type args))
_
type))
-(defmacro #export (type tokens)
+(defmacro' #export (@type tokens)
(_lux_case tokens
- (#Cons [type #Nil])
+ (#Cons type #Nil)
(do Lux/Monad
- [type+ (macro-expand type)]
+ [type+ (macro-expand-all type)]
(_lux_case type+
- (#Cons [type' #Nil])
- (;return (list (walk-type type')))
+ (#Cons type' #Nil)
+ (wrap (@list (walk-type type')))
_
(fail "The expansion of the type-syntax had to yield a single element.")))
_
- (fail "Wrong syntax for type")))
+ (fail "Wrong syntax for @type")))
-(defmacro #export (: tokens)
+(defmacro' #export (: tokens)
(_lux_case tokens
- (#Cons [type (#Cons [value #Nil])])
- (return (list (`' (_lux_: (;type (~ type)) (~ value)))))
+ (#Cons type (#Cons value #Nil))
+ (return (@list (` (;_lux_: (@type (~ type)) (~ value)))))
_
(fail "Wrong syntax for :")))
-(defmacro #export (:! tokens)
+(defmacro' #export (:! tokens)
(_lux_case tokens
- (#Cons [type (#Cons [value #Nil])])
- (return (list (`' (_lux_:! (;type (~ type)) (~ value)))))
+ (#Cons type (#Cons value #Nil))
+ (return (@list (` (;_lux_:! (@type (~ type)) (~ value)))))
_
(fail "Wrong syntax for :!")))
-(def'' (empty? xs)
+(def''' (empty? xs)
(All [a] (-> ($' List a) Bool))
(_lux_case xs
#Nil true
_ false))
-(defmacro #export (deftype tokens)
- (let [[export? tokens'] (: (, Bool (List Syntax))
- (_lux_case tokens
- (#Cons [(#Meta [_ (#TagS ["" "export"])]) tokens'])
- [true tokens']
-
- _
- [false tokens]))
- [rec? tokens'] (: (, Bool (List Syntax))
- (_lux_case tokens'
- (#Cons [(#Meta [_ (#TagS ["" "rec"])]) tokens'])
- [true tokens']
+(do-template [<name> <type> <value>]
+ [(def''' (<name> xy)
+ (All [a b] (-> (, a b) <type>))
+ (let' [[x y] xy] <value>))]
- _
- [false tokens']))
- parts (: (Maybe (, Text (List Syntax) Syntax))
- (_lux_case tokens'
- (#Cons [(#Meta [_ (#SymbolS ["" name])]) (#Cons [type #Nil])])
- (#Some [name #Nil type])
+ [first a x]
+ [second b y])
+
+(def''' (unfold-type-def type)
+ (-> AST ($' Lux (, AST ($' Maybe ($' List AST)))))
+ (_lux_case type
+ [_ (#FormS (#Cons [_ (#SymbolS "" "|")] cases))]
+ (do Lux/Monad
+ [members (map% Lux/Monad
+ (: (-> AST ($' Lux (, Text AST)))
+ (lambda' [case]
+ (_lux_case case
+ [_ (#TagS "" member-name)]
+ (return [member-name (` Unit)])
+
+ [_ (#FormS (#Cons [_ (#TagS "" member-name)] (#Cons member-type #Nil)))]
+ (return [member-name member-type])
+
+ _
+ (fail "Wrong syntax for variant case."))))
+ cases)]
+ (return [(` (#;VariantT (~ (untemplate-list (map second members)))))
+ (#Some (|> members
+ (map first)
+ (map (: (-> Text AST)
+ (lambda' [name] (tag$ ["" name]))))))]))
+
+ [_ (#FormS (#Cons [_ (#SymbolS "" "&")] pairs))]
+ (do Lux/Monad
+ [members (map% Lux/Monad
+ (: (-> (, AST AST) ($' Lux (, Text AST)))
+ (lambda' [pair]
+ (_lux_case pair
+ [[_ (#TagS "" member-name)] member-type]
+ (return [member-name member-type])
+
+ _
+ (fail "Wrong syntax for variant case."))))
+ (as-pairs pairs))]
+ (return [(` (#TupleT (~ (untemplate-list (map second members)))))
+ (#Some (|> members
+ (map first)
+ (map (: (-> Text AST)
+ (lambda' [name] (tag$ ["" name]))))))]))
+
+ _
+ (return [type #None])))
- (#Cons [(#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS ["" name])]) args]))]) (#Cons [type #Nil])])
- (#Some [name args type])
+(def''' (gensym prefix state)
+ (-> Text ($' Lux AST))
+ (_lux_case state
+ {#source source #modules modules
+ #envs envs #type-vars types #host host
+ #seed seed #eval? eval? #expected expected
+ #cursor cursor}
+ (#Right {#source source #modules modules
+ #envs envs #type-vars types #host host
+ #seed (i+ 1 seed) #eval? eval? #expected expected
+ #cursor cursor}
+ (symbol$ ["" ($ text:++ "__gensym__" prefix (->text seed))]))))
+
+(defmacro' #export (Rec tokens)
+ (_lux_case tokens
+ (#Cons [_ (#SymbolS "" name)] (#Cons body #Nil))
+ (let' [body' (replace-syntax (@list [name (` (#AppT (~ (make-bound 0)) (~ (make-bound 1))))]) body)]
+ (return (@list (` (#AppT (#UnivQ #Nil (~ body')) Void)))))
+
+ _
+ (fail "Wrong syntax for Rec")))
- _
- #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)
+(defmacro' #export (deftype tokens)
+ (let' [[export? tokens'] (_lux_case tokens
+ (#Cons [_ (#TagS "" "export")] tokens')
+ [true tokens']
- _
- (#Some (`' (;All (~ (symbol$ ["" name])) [(~@ args)] (~ type)))))))]
- (_lux_case type'
- (#Some type'')
- (return (list& (`' (_lux_def (~ (symbol$ ["" name])) (;type (~ type''))))
- with-export))
+ _
+ [false tokens])
+ [rec? tokens'] (_lux_case tokens'
+ (#Cons [_ (#TagS "" "rec")] tokens')
+ [true tokens']
+
+ _
+ [false tokens'])
+ parts (: (Maybe (, Text (List AST) AST))
+ (_lux_case tokens'
+ (#Cons [_ (#SymbolS "" name)] (#Cons type #Nil))
+ (#Some name #Nil type)
+
+ (#Cons [_ (#FormS (#Cons [_ (#SymbolS "" name)] args))] (#Cons type #Nil))
+ (#Some name args type)
+
+ _
+ #None))]
+ (_lux_case parts
+ (#Some name args type)
+ (do Lux/Monad
+ [type+tags?? (unfold-type-def type)
+ module-name get-module-name]
+ (let' [type-name (symbol$ ["" name])
+ [type tags??] type+tags??
+ with-export (: (List AST)
+ (if export?
+ (@list (` (;_lux_export (~ type-name))))
+ #Nil))
+ with-tags (: (List AST)
+ (_lux_case tags??
+ (#Some tags)
+ (@list (` (;_lux_declare-tags [(~@ tags)] (~ type-name))))
+
+ _
+ (@list)))
+ type' (: (Maybe AST)
+ (if rec?
+ (if (empty? args)
+ (let' [g!param (symbol$ ["" ""])
+ prime-name (symbol$ ["" (text:++ name "'")])
+ type+ (replace-syntax (@list [name (` ((~ prime-name) (~ g!param)))]) type)]
+ (#Some (` ((All (~ prime-name) [(~ g!param)] (~ type+))
+ Void))))
+ #None)
+ (_lux_case args
+ #Nil
+ (#Some type)
+
+ _
+ (#Some (` (All (~ type-name) [(~@ args)] (~ type)))))))]
+ (_lux_case type'
+ (#Some type'')
+ (return (@list& (` (;_lux_def (~ type-name) (@type (#;NamedT [(~ (text$ module-name))
+ (~ (text$ name))]
+ (~ type'')))))
+ (list:++ with-export with-tags)))
+
+ #None
+ (fail "Wrong syntax for deftype"))))
#None
- (fail "Wrong syntax for deftype")))
+ (fail "Wrong syntax for deftype"))
+ ))
- #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)
+(defmacro' #export (exec tokens)
(_lux_case (reverse tokens)
- (#Cons [value actions])
- (let [dummy (symbol$ ["" ""])]
- (return (list (foldL (lambda [post pre] (`' (_lux_case (~ pre) (~ dummy) (~ post))))
- value
- actions))))
+ (#Cons value actions)
+ (let' [dummy (symbol$ ["" ""])]
+ (return (@list (foldL (_lux_: (-> AST AST AST)
+ (lambda' [post pre] (` (;_lux_case (~ pre) (~ dummy) (~ post)))))
+ value
+ actions))))
_
(fail "Wrong syntax for exec")))
-(defmacro #export (def tokens)
- (let [[export? tokens'] (: (, Bool (List Syntax))
- (_lux_case tokens
- (#Cons [(#Meta [_ (#TagS ["" "export"])]) tokens'])
- [true tokens']
-
- _
- [false tokens]))
- parts (: (Maybe (, Syntax (List Syntax) (Maybe Syntax) Syntax))
- (_lux_case tokens'
- (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) (#Cons [type (#Cons [body #Nil])])])
- (#Some [name args (#Some type) body])
-
- (#Cons [name (#Cons [type (#Cons [body #Nil])])])
- (#Some [name #Nil (#Some type) body])
-
- (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) (#Cons [body #Nil])])
- (#Some [name args #None body])
-
- (#Cons [name (#Cons [body #Nil])])
- (#Some [name #Nil #None body])
+(defmacro' (def' tokens)
+ (let' [[export? tokens'] (_lux_case tokens
+ (#Cons [_ (#TagS "" "export")] tokens')
+ [true tokens']
- _
- #None))]
- (_lux_case parts
- (#Some [name args ?type body])
- (let [body' (: Syntax
- (_lux_case args
- #Nil
- body
+ _
+ [false tokens])
+ parts (: (Maybe (, AST (List AST) (Maybe AST) AST))
+ (_lux_case tokens'
+ (#Cons [_ (#FormS (#Cons name args))] (#Cons type (#Cons body #Nil)))
+ (#Some name args (#Some type) body)
+
+ (#Cons name (#Cons type (#Cons body #Nil)))
+ (#Some name #Nil (#Some type) body)
+
+ (#Cons [_ (#FormS (#Cons name args))] (#Cons body #Nil))
+ (#Some name args #None body)
+
+ (#Cons name (#Cons body #Nil))
+ (#Some name #Nil #None body)
- _
- (`' (;lambda (~ name) [(~@ args)] (~ body)))))
- body'' (: Syntax
- (_lux_case ?type
- (#Some type)
- (`' (: (~ type) (~ body')))
-
- #None
- body'))]
- (return (list& (`' (_lux_def (~ name) (~ body'')))
- (if export?
- (list (`' (_lux_export (~ name))))
- #Nil))))
-
- #None
- (fail "Wrong syntax for def"))))
+ _
+ #None))]
+ (_lux_case parts
+ (#Some name args ?type body)
+ (let' [body' (_lux_case args
+ #Nil
+ body
-(def (rejoin-pair pair)
- (-> (, Syntax Syntax) (List Syntax))
- (let [[left right] pair]
- (list left right)))
+ _
+ (` (lambda' (~ name) [(~@ args)] (~ body))))
+ body'' (_lux_case ?type
+ (#Some type)
+ (` (: (~ type) (~ body')))
+
+ #None
+ body')]
+ (return (@list& (` (;_lux_def (~ name) (~ body'')))
+ (if export?
+ (@list (` (;_lux_export (~ name))))
+ #Nil))))
+
+ #None
+ (fail "Wrong syntax for def'"))))
-(defmacro #export (case tokens)
- (_lux_case tokens
- (#Cons [value branches])
- (do Lux/Monad
- [expansions (map% Lux/Monad
- (: (-> (, Syntax Syntax) (Lux (List (, Syntax Syntax))))
- (lambda expander [branch]
- (let [[pattern body] branch]
- (_lux_case pattern
- (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS macro-name)]) macro-args]))])
- (do Lux/Monad
- [expansion (macro-expand (form$ (list& (symbol$ macro-name) body macro-args)))
- expansions (map% Lux/Monad expander (as-pairs expansion))]
- (;return (list:join expansions)))
+(def' (rejoin-pair pair)
+ (-> (, AST AST) (List AST))
+ (let' [[left right] pair]
+ (@list left right)))
- _
- (;return (list branch))))))
- (as-pairs branches))]
- (;return (list (`' (_lux_case (~ value)
- (~@ (|> expansions list:join (map rejoin-pair) list:join)))))))
+(defmacro' #export (case tokens)
+ (_lux_case tokens
+ (#Cons value branches)
+ (if (multiple? 2 (length branches))
+ (do Lux/Monad
+ [expansions (map% Lux/Monad
+ (: (-> (, AST AST) (Lux (List (, AST AST))))
+ (lambda' expander [branch]
+ (let' [[pattern body] branch]
+ (_lux_case pattern
+ [_ (#FormS (#Cons [_ (#SymbolS macro-name)] macro-args))]
+ (do Lux/Monad
+ [??? (macro? macro-name)]
+ (if ???
+ (do Lux/Monad
+ [expansion (macro-expand (form$ (@list& (symbol$ macro-name) body macro-args)))
+ expansions (map% Lux/Monad expander (as-pairs expansion))]
+ (wrap (list:join expansions)))
+ (wrap (@list branch))))
+
+ _
+ (wrap (@list branch))))))
+ (as-pairs branches))]
+ (wrap (@list (` (;_lux_case (~ value)
+ (~@ (|> expansions list:join (map rejoin-pair) list:join)))))))
+ (fail "case expects an even number of tokens"))
_
(fail "Wrong syntax for case")))
-(defmacro #export (\ tokens)
+(defmacro' #export (\ tokens)
(case tokens
- (#Cons [body (#Cons [pattern #Nil])])
+ (#Cons body (#Cons pattern #Nil))
(do Lux/Monad
- [pattern+ (macro-expand pattern)]
+ [module-name get-module-name
+ pattern+ (macro-expand-all pattern)]
(case pattern+
- (#Cons [pattern' #Nil])
- (;return (list pattern' body))
+ (#Cons pattern' #Nil)
+ (wrap (@list pattern' body))
_
(fail "\\ can only expand to 1 pattern.")))
@@ -1697,165 +1975,492 @@
_
(fail "Wrong syntax for \\")))
-(defmacro #export (\or tokens)
+(defmacro' #export (\or tokens)
(case tokens
- (#Cons [body patterns])
+ (#Cons body patterns)
(case patterns
#Nil
(fail "\\or can't have 0 patterns")
_
(do Lux/Monad
- [patterns' (map% Lux/Monad macro-expand patterns)]
- (;return (list:join (map (lambda [pattern] (list pattern body))
- (list:join patterns'))))))
+ [patterns' (map% Lux/Monad macro-expand-all patterns)]
+ (wrap (list:join (map (lambda' [pattern] (@list pattern body))
+ (list:join patterns'))))))
_
(fail "Wrong syntax for \\or")))
-(do-template [<name> <offset>]
- [(def #export <name> (i+ <offset>))]
+(def' (symbol? ast)
+ (-> AST Bool)
+ (case ast
+ [_ (#SymbolS _)]
+ true
- [inc 1]
- [dec -1])
+ _
+ false))
-(defmacro #export (` tokens)
- (do Lux/Monad
- [module-name get-module-name]
- (case tokens
- (\ (list template))
- (;return (list (untemplate true module-name template)))
+(defmacro' #export (let tokens)
+ (case tokens
+ (\ (@list [_ (#TupleS bindings)] body))
+ (if (multiple? 2 (length bindings))
+ (|> bindings as-pairs reverse
+ (foldL (: (-> AST (, AST AST) AST)
+ (lambda' [body' lr]
+ (let' [[l r] lr]
+ (if (symbol? l)
+ (` (;_lux_case (~ r) (~ l) (~ body')))
+ (` (case (~ r) (~ l) (~ body')))))))
+ body)
+ @list
+ return)
+ (fail "let requires an even number of parts"))
- _
- (fail "Wrong syntax for `"))))
+ _
+ (fail "Wrong syntax for let")))
-(def (gensym prefix state)
- (-> Text (Lux Syntax))
- (case state
- {#source source #modules modules
- #envs envs #types types #host host
- #seed seed #eval? eval?}
- (#Right [{#source source #modules modules
- #envs envs #types types #host host
- #seed (inc seed) #eval? eval?}
- (symbol$ ["__gensym__" (->text seed)])])))
-
-(def (macro-expand-1 token)
- (-> Syntax (Lux Syntax))
- (do Lux/Monad
- [token+ (macro-expand token)]
- (case token+
- (\ (list token'))
- (;return token')
+(defmacro' #export (lambda tokens)
+ (case (: (Maybe (, Ident AST (List AST) AST))
+ (case tokens
+ (\ (@list [_ (#TupleS (#Cons head tail))] body))
+ (#Some ["" ""] head tail body)
+
+ (\ (@list [_ (#SymbolS ["" name])] [_ (#TupleS (#Cons head tail))] body))
+ (#Some ["" name] head tail body)
+
+ _
+ #None))
+ (#Some ident head tail body)
+ (let [g!blank (symbol$ ["" ""])
+ g!name (symbol$ ident)
+ body+ (foldL (: (-> AST AST AST)
+ (lambda' [body' arg]
+ (if (symbol? arg)
+ (` (;_lux_lambda (~ g!blank) (~ arg) (~ body')))
+ (` (;_lux_lambda (~ g!blank) (~ g!blank)
+ (case (~ g!blank) (~ arg) (~ body')))))))
+ body
+ (reverse tail))]
+ (return (@list (if (symbol? head)
+ (` (;_lux_lambda (~ g!name) (~ head) (~ body+)))
+ (` (;_lux_lambda (~ g!name) (~ g!blank) (case (~ g!blank) (~ head) (~ body+))))))))
- _
- (fail "Macro expanded to more than 1 element."))))
+ #None
+ (fail "Wrong syntax for lambda")))
-(defmacro #export (sig tokens)
- (do Lux/Monad
- [tokens' (map% Lux/Monad macro-expand tokens)
- members (map% Lux/Monad
- (: (-> Syntax (Lux (, Ident Syntax)))
- (lambda [token]
- (case token
- (\ (#Meta [_ (#FormS (list (#Meta [_ (#SymbolS ["" "_lux_:"])]) type (#Meta [_ (#SymbolS name)])))]))
- (do Lux/Monad
- [name' (normalize name)]
- (;return (: (, Ident Syntax) [name' type])))
+(defmacro' #export (def tokens)
+ (let [[export? tokens'] (case tokens
+ (#Cons [_ (#TagS "" "export")] tokens')
+ [true tokens']
- _
- (fail "Signatures require typed 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)))))))))
+ _
+ [false tokens])
+ parts (: (Maybe (, AST (List AST) (Maybe AST) AST))
+ (case tokens'
+ (\ (@list [_ (#FormS (#Cons name args))] type body))
+ (#Some name args (#Some type) body)
+
+ (\ (@list name type body))
+ (#Some name #Nil (#Some type) body)
+
+ (\ (@list [_ (#FormS (#Cons name args))] body))
+ (#Some name args #None body)
+
+ (\ (@list name body))
+ (#Some name #Nil #None body)
+
+ _
+ #None))]
+ (case parts
+ (#Some name args ?type body)
+ (let [body (case args
+ #Nil
+ body
+
+ _
+ (` (lambda (~ name) [(~@ args)] (~ body))))
+ body (case ?type
+ (#Some type)
+ (` (: (~ type) (~ body)))
+
+ #None
+ body)]
+ (return (@list& (` (;_lux_def (~ name) (~ body)))
+ (if export?
+ (@list (` (;_lux_export (~ name))))
+ (@list)))))
+
+ #None
+ (fail "Wrong syntax for def"))))
+
+(defmacro' #export (defmacro tokens)
+ (let [[exported? tokens] (case tokens
+ (\ (@list& [_ (#TagS ["" "export"])] tokens'))
+ [true tokens']
+
+ _
+ [false tokens])
+ name+args+body?? (: (Maybe (, Ident (List AST) AST))
+ (case tokens
+ (\ (@list [_ (#;FormS (@list& [_ (#SymbolS name)] args))] body))
+ (#Some [name args body])
+
+ (\ (@list [_ (#;SymbolS name)] body))
+ (#Some [name #Nil body])
+
+ _
+ #None))]
+ (case name+args+body??
+ (#Some [name args body])
+ (let [name (symbol$ name)
+ decls (: (List AST)
+ (list:++ (if exported? (@list (` (;_lux_export (~ name)))) #;Nil)
+ (@list (` (;;_lux_declare-macro (~ name))))))
+ def-sig (case args
+ #;Nil name
+ _ (` ((~ name) (~@ args))))]
+ (return (@list& (` (;;def (~ def-sig) ;;Macro (~ body)))
+ decls)))
+
+
+ #None
+ (fail "Wrong syntax for defmacro"))))
(defmacro #export (defsig tokens)
- (let [[export? tokens'] (: (, Bool (List Syntax))
- (case tokens
- (\ (list& (#Meta [_ (#TagS ["" "export"])]) tokens'))
- [true tokens']
-
- _
- [false tokens]))
- ?parts (: (Maybe (, Syntax (List Syntax) (List Syntax)))
+ (let [[export? tokens'] (case tokens
+ (\ (@list& [_ (#TagS "" "export")] tokens'))
+ [true tokens']
+
+ _
+ [false tokens])
+ ?parts (: (Maybe (, Ident (List AST) (List AST)))
(case tokens'
- (\ (list& (#Meta [_ (#FormS (list& name args))]) sigs))
- (#Some [name args sigs])
+ (\ (@list& [_ (#FormS (@list& [_ (#SymbolS name)] args))] sigs))
+ (#Some name args sigs)
- (\ (list& name sigs))
- (#Some [name #Nil sigs])
+ (\ (@list& [_ (#SymbolS name)] sigs))
+ (#Some name #Nil sigs)
_
#None))]
(case ?parts
- (#Some [name args sigs])
- (let [sigs' (: Syntax
- (case args
- #Nil
- (`' (;sig (~@ sigs)))
-
- _
- (`' (;All (~ name) [(~@ args)] (;sig (~@ sigs))))))]
- (return (list& (`' (_lux_def (~ name) (~ sigs')))
- (if export?
- (list (`' (_lux_export (~ name))))
- #Nil))))
+ (#Some name args sigs)
+ (do Lux/Monad
+ [name+ (normalize name)
+ sigs' (map% Lux/Monad macro-expand sigs)
+ members (map% Lux/Monad
+ (: (-> AST (Lux (, Text AST)))
+ (lambda [token]
+ (case token
+ (\ [_ (#FormS (@list [_ (#SymbolS _ "_lux_:")] type [_ (#SymbolS ["" name])]))])
+ (wrap [name type])
+
+ _
+ (fail "Signatures require typed members!"))))
+ (list:join sigs'))
+ #let [[_module _name] name+
+ def-name (symbol$ name)
+ tags (: (List AST) (map (. (: (-> Text AST) (lambda [n] (tag$ ["" n]))) first) members))
+ types (map second members)
+ sig-type (` (#TupleT (~ (untemplate-list types))))
+ sig-decl (` (;_lux_declare-tags [(~@ tags)] (~ def-name)))
+ sig+ (case args
+ #Nil
+ sig-type
+
+ _
+ (` (#NamedT [(~ (text$ _module)) (~ (text$ _name))] (;All (~ def-name) [(~@ args)] (~ sig-type)))))]]
+ (return (@list& (` (;_lux_def (~ def-name) (~ sig+)))
+ sig-decl
+ (if export?
+ (@list (` (;_lux_export (~ def-name))))
+ #Nil))))
#None
(fail "Wrong syntax for defsig"))))
+(def (some f xs)
+ (All [a b]
+ (-> (-> a (Maybe b)) (List a) (Maybe b)))
+ (case xs
+ #Nil
+ #None
+
+ (#Cons x xs')
+ (case (f x)
+ #None
+ (some f xs')
+
+ (#Some y)
+ (#Some y))))
+
+(def (last-index-of part text)
+ (-> Text Text Int)
+ (_jvm_i2l (_jvm_invokevirtual "java.lang.String" "lastIndexOf" ["java.lang.String"]
+ text [part])))
+
+(def (index-of part text)
+ (-> Text Text Int)
+ (_jvm_i2l (_jvm_invokevirtual "java.lang.String" "indexOf" ["java.lang.String"]
+ text [part])))
+
+(def (substring1 idx text)
+ (-> Int Text Text)
+ (_jvm_invokevirtual "java.lang.String" "substring" ["int"]
+ text [(_jvm_l2i idx)]))
+
+(def (substring2 idx1 idx2 text)
+ (-> Int Int Text Text)
+ (_jvm_invokevirtual "java.lang.String" "substring" ["int" "int"]
+ text [(_jvm_l2i idx1) (_jvm_l2i idx2)]))
+
+(def (split-module-contexts module)
+ (-> Text (List Text))
+ (#Cons module (let [idx (last-index-of "/" module)]
+ (if (i< idx 0)
+ #Nil
+ (split-module-contexts (substring2 0 idx module))))))
+
+(def (split-module module)
+ (-> Text (List Text))
+ (let [idx (index-of "/" module)]
+ (if (i< idx 0)
+ (#Cons module #Nil)
+ (#Cons (substring2 0 idx module)
+ (split-module (substring1 (i+ 1 idx) module))))))
+
+(def (@ idx xs)
+ (All [a]
+ (-> Int (List a) (Maybe a)))
+ (case xs
+ #Nil
+ #None
+
+ (#Cons x xs')
+ (if (i= idx 0)
+ (#Some x)
+ (@ (i- idx 1) xs')
+ )))
+
+(def (beta-reduce env type)
+ (-> (List Type) Type Type)
+ (case type
+ (#VariantT ?cases)
+ (#VariantT (map (beta-reduce env) ?cases))
+
+ (#TupleT ?members)
+ (#TupleT (map (beta-reduce env) ?members))
+
+ (#AppT ?type-fn ?type-arg)
+ (#AppT (beta-reduce env ?type-fn) (beta-reduce env ?type-arg))
+
+ (#UnivQ ?local-env ?local-def)
+ (case ?local-env
+ #Nil
+ (#UnivQ env ?local-def)
+
+ _
+ type)
+
+ (#ExQ ?local-env ?local-def)
+ (case ?local-env
+ #Nil
+ (#ExQ env ?local-def)
+
+ _
+ type)
+
+ (#LambdaT ?input ?output)
+ (#LambdaT (beta-reduce env ?input) (beta-reduce env ?output))
+
+ (#BoundT idx)
+ (case (@ idx env)
+ (#Some bound)
+ bound
+
+ _
+ type)
+
+ (#NamedT name type)
+ (beta-reduce env type)
+
+ _
+ type
+ ))
+
+(def (apply-type type-fn param)
+ (-> Type Type (Maybe Type))
+ (case type-fn
+ (#UnivQ env body)
+ (#Some (beta-reduce (@list& type-fn param env) body))
+
+ (#AppT F A)
+ (do Maybe/Monad
+ [type-fn* (apply-type F A)]
+ (apply-type type-fn* param))
+
+ (#NamedT name type)
+ (apply-type type param)
+
+ _
+ #None))
+
+(def (resolve-struct-type type)
+ (-> Type (Maybe (List Type)))
+ (case type
+ (#TupleT slots)
+ (#Some slots)
+
+ (#AppT fun arg)
+ (do Maybe/Monad
+ [output (apply-type fun arg)]
+ (resolve-struct-type output))
+
+ (#UnivQ _ body)
+ (resolve-struct-type body)
+
+ (#ExQ _ body)
+ (resolve-struct-type body)
+
+ (#NamedT name type)
+ (resolve-struct-type type)
+
+ _
+ #None))
+
+(def (find-module name)
+ (-> Text (Lux (Module Compiler)))
+ (lambda [state]
+ (let [{#source source #modules modules
+ #envs envs #type-vars types #host host
+ #seed seed #eval? eval? #expected expected
+ #cursor cursor} state]
+ (case (get name modules)
+ (#Some module)
+ (#Right state module)
+
+ _
+ (#Left ($ text:++ "Unknown module: " name))))))
+
+(def get-current-module
+ (Lux (Module Compiler))
+ (do Lux/Monad
+ [module-name get-module-name]
+ (find-module module-name)))
+
+(def (resolve-tag [module name])
+ (-> Ident (Lux (, Int (List Ident) Type)))
+ (do Lux/Monad
+ [=module (find-module module)
+ #let [{#module-aliases _ #defs bindings #imports _ #tags tags-table #types types} =module]]
+ (case (get name tags-table)
+ (#Some output)
+ (return output)
+
+ _
+ (fail (text:++ "Unknown tag: " (ident->text [module name]))))))
+
+(def (resolve-type-tags type)
+ (-> Type (Lux (Maybe (, (List Ident) (List Type)))))
+ (case type
+ (#AppT fun arg)
+ (resolve-type-tags fun)
+
+ (#UnivQ env body)
+ (resolve-type-tags body)
+
+ (#ExQ env body)
+ (resolve-type-tags body)
+
+ (#NamedT [module name] _)
+ (do Lux/Monad
+ [=module (find-module module)
+ #let [{#module-aliases _ #defs bindings #imports _ #tags tags #types types} =module]]
+ (case (get name types)
+ (#Some [tags (#NamedT _ _type)])
+ (case (resolve-struct-type _type)
+ (#Some members)
+ (return (#Some [tags members]))
+
+ _
+ (return #None))
+
+ _
+ (return #None)))
+
+ _
+ (return #None)))
+
+(def expected-type
+ (Lux Type)
+ (lambda [state]
+ (let [{#source source #modules modules
+ #envs envs #type-vars types #host host
+ #seed seed #eval? eval? #expected expected
+ #cursor cursor} state]
+ (#Right state expected))))
+
(defmacro #export (struct tokens)
(do Lux/Monad
[tokens' (map% Lux/Monad macro-expand tokens)
+ struct-type expected-type
+ tags+type (resolve-type-tags struct-type)
+ tags (: (Lux (List Ident))
+ (case tags+type
+ (#Some [tags _])
+ (return tags)
+
+ _
+ (fail "No tags available for type.")))
+ #let [tag-mappings (: (List (, Text AST))
+ (map (lambda [tag] [(second tag) (tag$ tag)])
+ tags))]
members (map% Lux/Monad
- (: (-> Syntax (Lux (, Syntax Syntax)))
+ (: (-> AST (Lux (, AST AST)))
(lambda [token]
(case token
- (\ (#Meta [_ (#FormS (list (#Meta [_ (#SymbolS ["" "_lux_def"])]) (#Meta [_ (#SymbolS name)]) value))]))
- (do Lux/Monad
- [name' (normalize name)]
- (;return (: (, Syntax Syntax) [(tag$ name') value])))
+ (\ [_ (#FormS (@list [_ (#SymbolS _ "_lux_def")] [_ (#SymbolS "" tag-name)] value))])
+ (case (get tag-name tag-mappings)
+ (#Some tag)
+ (wrap [tag value])
+
+ _
+ (fail (text:++ "Unknown structure member: " tag-name)))
_
- (fail "Structures require defined members!"))))
+ (fail "Invalid structure member."))))
(list:join tokens'))]
- (;return (list (record$ members)))))
+ (wrap (@list (record$ members)))))
(defmacro #export (defstruct tokens)
- (let [[export? tokens'] (: (, Bool (List Syntax))
- (case tokens
- (\ (list& (#Meta [_ (#TagS ["" "export"])]) tokens'))
- [true tokens']
-
- _
- [false tokens]))
- ?parts (: (Maybe (, Syntax (List Syntax) Syntax (List Syntax)))
+ (let [[export? tokens'] (case tokens
+ (\ (@list& [_ (#TagS "" "export")] tokens'))
+ [true tokens']
+
+ _
+ [false tokens])
+ ?parts (: (Maybe (, AST (List AST) AST (List AST)))
(case tokens'
- (\ (list& (#Meta [_ (#FormS (list& name args))]) type defs))
- (#Some [name args type defs])
+ (\ (@list& [_ (#FormS (@list& name args))] type defs))
+ (#Some name args type defs)
- (\ (list& name type defs))
- (#Some [name #Nil type defs])
+ (\ (@list& name type defs))
+ (#Some name #Nil type defs)
_
#None))]
(case ?parts
- (#Some [name args type defs])
- (let [defs' (: Syntax
- (case args
- #Nil
- (`' (;struct (~@ defs)))
-
- _
- (`' (;lambda (~ name) [(~@ args)] (;struct (~@ defs))))))]
- (return (list& (`' (def (~ name) (~ type) (~ defs')))
- (if export?
- (list (`' (_lux_export (~ name))))
- #Nil))))
+ (#Some name args type defs)
+ (let [defs' (case args
+ #Nil
+ (` (struct (~@ defs)))
+
+ _
+ (` (lambda (~ name) [(~@ args)] (;struct (~@ defs)))))]
+ (return (@list& (` (def (~ name) (~ type) (~ defs')))
+ (if export?
+ (@list (` (;_lux_export (~ name))))
+ #Nil))))
#None
(fail "Wrong syntax for defstruct"))))
@@ -1867,10 +2472,11 @@
(do-template [<name> <form> <message>]
[(defmacro #export (<name> tokens)
(case (reverse tokens)
- (\ (list& last init))
- (return (list (foldL (lambda [post pre] (` <form>))
- last
- init)))
+ (\ (@list& last init))
+ (return (@list (foldL (: (-> AST AST AST)
+ (lambda [post pre] (` <form>)))
+ last
+ init)))
_
(fail <message>)))]
@@ -1887,16 +2493,16 @@
(deftype Openings
(, Text (List Ident)))
-(deftype Import
+(deftype Importation
(, Text (Maybe Text) Referrals (Maybe Openings)))
(def (extract-defs defs)
- (-> (List Syntax) (Lux (List Text)))
+ (-> (List AST) (Lux (List Text)))
(map% Lux/Monad
- (: (-> Syntax (Lux Text))
+ (: (-> AST (Lux Text))
(lambda [def]
(case def
- (#Meta [_ (#SymbolS ["" name])])
+ [_ (#SymbolS "" name)]
(return name)
_
@@ -1904,85 +2510,85 @@
defs))
(def (parse-alias tokens)
- (-> (List Syntax) (Lux (, (Maybe Text) (List Syntax))))
+ (-> (List AST) (Lux (, (Maybe Text) (List AST))))
(case tokens
- (\ (list& (#Meta [_ (#TagS ["" "as"])]) (#Meta [_ (#SymbolS ["" alias])]) tokens'))
- (return (: (, (Maybe Text) (List Syntax)) [(#Some alias) tokens']))
+ (\ (@list& [_ (#TagS "" "as")] [_ (#SymbolS "" alias)] tokens'))
+ (return [(#Some alias) tokens'])
_
- (return (: (, (Maybe Text) (List Syntax)) [#None tokens]))))
+ (return [#None tokens])))
(def (parse-referrals tokens)
- (-> (List Syntax) (Lux (, Referrals (List Syntax))))
+ (-> (List AST) (Lux (, Referrals (List AST))))
(case tokens
- (\ (list& (#Meta [_ (#TagS ["" "refer"])]) referral tokens'))
+ (\ (@list& [_ (#TagS "" "refer")] referral tokens'))
(case referral
- (#Meta [_ (#TagS ["" "all"])])
- (return (: (, Referrals (List Syntax)) [#All tokens']))
+ [_ (#TagS "" "all")]
+ (return [#All tokens'])
- (\ (#Meta [_ (#FormS (list& (#Meta [_ (#TagS ["" "only"])]) defs))]))
+ (\ [_ (#FormS (@list& [_ (#TagS "" "only")] defs))])
(do Lux/Monad
[defs' (extract-defs defs)]
- (return (: (, Referrals (List Syntax)) [(#Only defs') tokens'])))
+ (return [(#Only defs') tokens']))
- (\ (#Meta [_ (#FormS (list& (#Meta [_ (#TagS ["" "exclude"])]) defs))]))
+ (\ [_ (#FormS (@list& [_ (#TagS "" "exclude")] defs))])
(do Lux/Monad
[defs' (extract-defs defs)]
- (return (: (, Referrals (List Syntax)) [(#Exclude defs') tokens'])))
+ (return [(#Exclude defs') tokens']))
_
(fail "Incorrect syntax for referral."))
_
- (return (: (, Referrals (List Syntax)) [#Nothing tokens]))))
+ (return [#Nothing tokens])))
(def (extract-symbol syntax)
- (-> Syntax (Lux Ident))
+ (-> AST (Lux Ident))
(case syntax
- (#Meta [_ (#SymbolS ident)])
+ [_ (#SymbolS ident)]
(return ident)
_
(fail "Not a symbol.")))
(def (parse-openings tokens)
- (-> (List Syntax) (Lux (, (Maybe Openings) (List Syntax))))
+ (-> (List AST) (Lux (, (Maybe Openings) (List AST))))
(case tokens
- (\ (list& (#Meta [_ (#TagS ["" "open"])]) (#Meta [_ (#FormS (list& (#Meta [_ (#TextS prefix)]) structs))]) tokens'))
+ (\ (@list& [_ (#TagS "" "open")] [_ (#FormS (@list& [_ (#TextS prefix)] structs))] tokens'))
(do Lux/Monad
[structs' (map% Lux/Monad extract-symbol structs)]
- (return (: (, (Maybe Openings) (List Syntax)) [(#Some [prefix structs']) tokens'])))
+ (return [(#Some prefix structs') tokens']))
_
- (return (: (, (Maybe Openings) (List Syntax)) [#None tokens]))))
+ (return [#None tokens])))
(def (decorate-imports super-name tokens)
- (-> Text (List Syntax) (Lux (List Syntax)))
+ (-> Text (List AST) (Lux (List AST)))
(map% Lux/Monad
- (: (-> Syntax (Lux Syntax))
+ (: (-> AST (Lux AST))
(lambda [token]
(case token
- (#Meta [_ (#SymbolS ["" sub-name])])
+ [_ (#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)))
+ (\ [_ (#FormS (@list& [_ (#SymbolS "" sub-name)] parts))])
+ (return (form$ (@list& (symbol$ ["" ($ text:++ super-name "/" sub-name)]) parts)))
_
(fail "Wrong import syntax."))))
tokens))
(def (parse-imports imports)
- (-> (List Syntax) (Lux (List Import)))
+ (-> (List AST) (Lux (List Importation)))
(do Lux/Monad
[imports' (map% Lux/Monad
- (: (-> Syntax (Lux (List Import)))
+ (: (-> AST (Lux (List Importation)))
(lambda [token]
(case token
- (#Meta [_ (#SymbolS ["" m-name])])
- (;return (list [m-name #None #All #None]))
+ [_ (#SymbolS "" m-name)]
+ (wrap (@list [m-name #None #All #None]))
- (\ (#Meta [_ (#FormS (list& (#Meta [_ (#SymbolS ["" m-name])]) extra))]))
+ (\ [_ (#FormS (@list& [_ (#SymbolS "" m-name)] extra))])
(do Lux/Monad
[alias+extra (parse-alias extra)
#let [[alias extra] alias+extra]
@@ -1992,100 +2598,54 @@
#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))))
+ (wrap (case [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'))))
+ (wrap (list:join imports'))))
(def (module-exists? module state)
(-> Text (Lux Bool))
(case state
{#source source #modules modules
- #envs envs #types types #host host
- #seed seed #eval? eval?}
+ #envs envs #type-vars types #host host
+ #seed seed #eval? eval? #expected expected
+ #cursor cursor}
(case (get module modules)
(#Some =module)
- (#Right [state true])
+ (#Right state true)
#None
- (#Right [state false]))
+ (#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?}
+ #envs envs #type-vars types #host host
+ #seed seed #eval? eval? #expected expected
+ #cursor cursor}
(case (get module modules)
(#Some =module)
- (let [to-alias (map (: (-> (, Text (, Bool (DefData' (-> (List Syntax) (StateE Compiler (List Syntax))))))
+ (let [to-alias (map (: (-> (, Text Definition)
(List Text))
(lambda [gdef]
(let [[name [export? _]] gdef]
(if export?
- (list name)
- (list)))))
- (let [{#module-aliases _ #defs defs #imports _} =module]
+ (@list name)
+ (@list)))))
+ (let [{#module-aliases _ #defs defs #imports _ #tags tags #types types} =module]
defs))]
- (#Right [state (list:join to-alias)]))
+ (#Right state (list:join to-alias)))
#None
(#Left ($ text:++ "Unknown module: " module)))
))
-(def (last-index-of part text)
- (-> Text Text Int)
- (_jvm_i2l (_jvm_invokevirtual "java.lang.String" "lastIndexOf" ["java.lang.String"]
- text [part])))
-
-(def (index-of part text)
- (-> Text Text Int)
- (_jvm_i2l (_jvm_invokevirtual "java.lang.String" "indexOf" ["java.lang.String"]
- text [part])))
-
-(def (substring1 idx text)
- (-> Int Text Text)
- (_jvm_invokevirtual "java.lang.String" "substring" ["int"]
- text [(_jvm_l2i idx)]))
-
-(def (substring2 idx1 idx2 text)
- (-> Int Int Text Text)
- (_jvm_invokevirtual "java.lang.String" "substring" ["int" "int"]
- text [(_jvm_l2i idx1) (_jvm_l2i idx2)]))
-
-(def (split-module-contexts module)
- (-> Text (List Text))
- (#Cons [module (let [idx (last-index-of "/" module)]
- (if (i< idx 0)
- #Nil
- (split-module-contexts (substring2 0 idx module))))]))
-
-(def (split-module module)
- (-> Text (List Text))
- (let [idx (index-of "/" module)]
- (if (i< idx 0)
- (#Cons [module #Nil])
- (#Cons [(substring2 0 idx module)
- (split-module (substring1 (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 (split-with' p ys xs)
(All [a]
(-> (-> a Bool) (List a) (List a) (, (List a) (List a))))
@@ -2093,9 +2653,9 @@
#Nil
[ys xs]
- (#Cons [x xs'])
+ (#Cons x xs')
(if (p x)
- (split-with' p (list& x ys) xs')
+ (split-with' p (@list& x ys) xs')
[ys xs])))
(def (split-with p xs)
@@ -2109,8 +2669,8 @@
(do Lux/Monad
[module-name get-module-name]
(case (split-module module)
- (\ (list& "." parts))
- (return (|> (list& module-name parts) (interpose "/") (foldL text:++ "")))
+ (\ (@list& "." parts))
+ (return (|> (@list& module-name parts) (interpose "/") (foldL text:++ "")))
parts
(let [[ups parts'] (split-with (text:= "..") parts)
@@ -2122,7 +2682,7 @@
(fail (text:++ "Can't clean module: " module))
(#Some top-module)
- (return (|> (list& top-module parts') (interpose "/") (foldL text:++ ""))))
+ (return (|> (@list& top-module parts') (interpose "/") (foldL text:++ ""))))
)))
))
@@ -2130,11 +2690,11 @@
(All [a] (-> (-> a Bool) (List a) (List a)))
(case xs
#;Nil
- (list)
+ (@list)
- (#;Cons [x xs'])
+ (#;Cons x xs')
(if (p x)
- (#;Cons [x (filter p xs')])
+ (#;Cons x (filter p xs'))
(filter p xs'))))
(def (is-member? cases name)
@@ -2146,270 +2706,6 @@
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
- #Nil
- #None
-
- (#Cons [x xs'])
- (case (f x)
- #None
- (some f xs')
-
- (#Some y)
- (#Some y))))
-
-(def (split-slot slot)
- (-> Text (, Text Text))
- (let [idx (index-of ";" slot)
- module (substring2 0 idx slot)
- name (substring1 (inc idx) slot)]
- [module name]))
-
-(def (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
- (#RecordT slots)
- (#Some type)
-
- (#AppT [fun arg])
- (apply-type fun arg)
-
- (#AllT [_ _ _ body])
- (resolve-struct-type body)
-
- _
- #None))
-
(def (try-both f x1 x2)
(All [a b]
(-> (-> a (Maybe b)) a a (Maybe b)))
@@ -2418,223 +2714,241 @@
(#;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:++ "")))
+ (-> Text Compiler (Maybe Type))
+ (case state
+ {#source source #modules modules
+ #envs envs #type-vars types #host host
+ #seed seed #eval? eval? #expected expected
+ #cursor cursor}
+ (some (: (-> (Env Text (Meta (, Type Cursor) Analysis)) (Maybe Type))
+ (lambda [env]
+ (case env
+ {#name _ #inner-closures _ #locals {#counter _ #mappings locals} #closure {#counter _ #mappings closure}}
+ (try-both (some (: (-> (, Text (Meta (, Type Cursor) Analysis)) (Maybe Type))
+ (lambda [[bname [[type _] _]]]
+ (if (text:= name bname)
+ (#Some type)
+ #None))))
+ locals
+ closure))))
+ envs)))
(def (find-in-defs name state)
(-> Ident Compiler (Maybe Type))
(let [[v-prefix v-name] name
{#source source #modules modules
- #envs envs #types types #host host
- #seed seed #eval? eval?} state]
+ #envs envs #type-vars types #host host
+ #seed seed #eval? eval? #expected expected
+ #cursor cursor} state]
(case (get v-prefix modules)
#None
#None
- (#Some {#defs defs #module-aliases _ #imports _})
+ (#Some {#defs defs #module-aliases _ #imports _ #tags tags #types types})
(case (get v-name defs)
#None
#None
(#Some [_ def-data])
(case def-data
- #TypeD (#Some Type)
- (#ValueD type) (#Some type)
+ (#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)
+
+(def (find-var-type ident)
(-> Ident (Lux Type))
(do Lux/Monad
- [name' (normalize name)]
+ [#let [[module name] ident]
+ current-module get-module-name]
(lambda [state]
- (case (find-in-env name state)
- (#Some struct-type)
- (#Right [state struct-type])
+ (if (text:= "" module)
+ (case (find-in-env name state)
+ (#Some struct-type)
+ (#Right state struct-type)
- _
- (case (find-in-defs name' state)
+ _
+ (case (find-in-defs [current-module name] state)
+ (#Some struct-type)
+ (#Right state struct-type)
+
+ _
+ (let [{#source source #modules modules
+ #envs envs #type-vars types #host host
+ #seed seed #eval? eval? #expected expected
+ #cursor cursor} state]
+ (#Left ($ text:++ "Unknown var: " (ident->text ident))))))
+ (case (find-in-defs ident state)
(#Some struct-type)
- (#Right [state struct-type])
+ (#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)))))))))
+ #envs envs #type-vars types #host host
+ #seed seed #eval? eval? #expected expected
+ #cursor cursor} state]
+ (#Left ($ text:++ "Unknown var: " (ident->text ident))))))
+ )))
+
+(def (zip2 xs ys)
+ (All [a b] (-> (List a) (List b) (List (, a b))))
+ (case xs
+ (#Cons x xs')
+ (case ys
+ (#Cons y ys')
+ (@list& [x y] (zip2 xs' ys'))
+
+ _
+ (@list))
+
+ _
+ (@list)))
+
+(def (use-field [module name] type)
+ (-> Ident Type (Lux (, AST AST)))
+ (do Lux/Monad
+ [output (resolve-type-tags type)
+ pattern (: (Lux AST)
+ (case output
+ (#Some [tags members])
+ (do Lux/Monad
+ [slots (map% Lux/Monad
+ (: (-> (, Ident Type) (Lux (, AST AST)))
+ (lambda [[sname stype]] (use-field sname stype)))
+ (zip2 tags members))]
+ (return (record$ slots)))
+
+ #None
+ (return (symbol$ ["" name]))))]
+ (return [(tag$ [module name]) pattern])))
(defmacro #export (using tokens)
(case tokens
- (\ (list struct body))
+ (\ (@list struct body))
(case struct
- (#Meta [_ (#SymbolS name)])
+ [_ (#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))))))
+ [struct-type (find-var-type name)
+ output (resolve-type-tags struct-type)]
+ (case output
+ (#Some [tags members])
+ (do Lux/Monad
+ [slots (map% Lux/Monad (: (-> (, Ident Type) (Lux (, AST AST)))
+ (lambda [[sname stype]] (use-field sname stype)))
+ (zip2 tags members))
+ #let [pattern (record$ slots)]]
+ (return (@list (` (;_lux_case (~ struct) (~ pattern) (~ body))))))
_
(fail "Can only \"use\" records.")))
+
+ [_ (#TupleS members)]
+ (return (@list (foldL (: (-> AST AST AST)
+ (lambda [body' struct'] (` (;;using (~ struct') (~ body')))))
+ body
+ members)))
_
(let [dummy (symbol$ ["" ""])]
- (return (list (` (_lux_case (~ struct)
- (~ dummy)
- (using (~ dummy)
- (~ body))))))))
+ (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'))))
+ (\ (@list& else branches'))
+ (return (@list (foldL (: (-> AST (, AST AST) AST)
+ (lambda [else branch]
+ (let [[right left] branch]
+ (` (if (~ left) (~ right) (~ else))))))
+ else
+ (as-pairs branches'))))
_
(fail "Wrong syntax for cond"))))
+(def (enumerate' idx xs)
+ (All [a] (-> Int (List a) (List (, Int a))))
+ (case xs
+ (#Cons x xs')
+ (#Cons [idx x] (enumerate' (i+ 1 idx) xs'))
+
+ #Nil
+ #Nil))
+
+(def (enumerate xs)
+ (All [a] (-> (List a) (List (, Int a))))
+ (enumerate' 0 xs))
+
(defmacro #export (get@ tokens)
(case tokens
- (\ (list (#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)))))))
+ (\ (@list [_ (#TagS slot')] record))
+ (do Lux/Monad
+ [slot (normalize slot')
+ output (resolve-tag slot)
+ #let [[idx tags type] output]
+ g!_ (gensym "_")
+ g!output (gensym "")]
+ (case (resolve-struct-type type)
+ (#Some members)
+ (let [pattern (record$ (map (: (-> (, Ident (, Int Type)) (, AST AST))
+ (lambda [[[r-prefix r-name] [r-idx r-type]]]
+ [(tag$ [r-prefix r-name]) (if (i= idx r-idx)
+ g!output
+ g!_)]))
+ (zip2 tags (enumerate members))))]
+ (return (@list (` (;_lux_case (~ record) (~ pattern) (~ g!output))))))
- _
- (fail "get@ can only use records.")))
-
- _
- (do Lux/Monad
- [_record (gensym "")]
- (return (list (` (let [(~ _record) (~ record)]
- (get@ (~ (tag$ slot')) (~ _record))))))))
+ _
+ (fail "get@ can only use records.")))
_
(fail "Wrong syntax for get@")))
+(def (open-field prefix [module name] source type)
+ (-> Text Ident AST Type (Lux (List AST)))
+ (do Lux/Monad
+ [output (resolve-type-tags type)
+ #let [source+ (` (get@ (~ (tag$ [module name])) (~ source)))]]
+ (case output
+ (#Some [tags members])
+ (do Lux/Monad
+ [decls' (map% Lux/Monad
+ (: (-> (, Ident Type) (Lux (List AST)))
+ (lambda [[sname stype]] (open-field prefix sname source+ stype)))
+ (zip2 tags members))]
+ (return (list:join decls')))
+
+ _
+ (return (@list (` (;_lux_def (~ (symbol$ ["" (text:++ prefix name)])) (~ source+))))))))
+
(defmacro #export (open tokens)
(case tokens
- (\ (list& (#Meta [_ (#SymbolS struct-name)]) tokens'))
+ (\ (@list& [_ (#SymbolS struct-name)] tokens'))
(do Lux/Monad
- [#let [prefix (case tokens'
- (\ (list (#Meta [_ (#TextS prefix)])))
+ [@module get-module-name
+ #let [prefix (case tokens'
+ (\ (@list [_ (#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))
+ struct-type (find-var-type struct-name)
+ output (resolve-type-tags struct-type)
+ #let [source (symbol$ struct-name)]]
+ (case output
+ (#Some [tags members])
+ (do Lux/Monad
+ [decls' (map% Lux/Monad (: (-> (, Ident Type) (Lux (List AST)))
+ (lambda [[sname stype]] (open-field prefix sname source stype)))
+ (zip2 tags members))]
+ (return (list:join decls')))
_
(fail "Can only \"open\" records.")))
@@ -2642,12 +2956,91 @@
_
(fail "Wrong syntax for open")))
+(defmacro #export (import tokens)
+ (do Lux/Monad
+ [imports (parse-imports tokens)
+ imports (map% Lux/Monad
+ (: (-> Importation (Lux Importation))
+ (lambda [import]
+ (case import
+ [m-name m-alias m-referrals m-openings]
+ (do Lux/Monad
+ [m-name (clean-module m-name)]
+ (wrap [m-name m-alias m-referrals m-openings])))))
+ imports)
+ unknowns' (map% Lux/Monad
+ (: (-> Importation (Lux (List Text)))
+ (lambda [import]
+ (case import
+ [m-name _ _ _]
+ (do Lux/Monad
+ [? (module-exists? m-name)]
+ (wrap (if ?
+ (@list)
+ (@list m-name)))))))
+ imports)
+ #let [unknowns (list:join unknowns')]]
+ (case unknowns
+ #Nil
+ (do Lux/Monad
+ [output' (map% Lux/Monad
+ (: (-> Importation (Lux (List AST)))
+ (lambda [import]
+ (case import
+ [m-name m-alias m-referrals m-openings]
+ (do Lux/Monad
+ [defs (case m-referrals
+ #All
+ (exported-defs m-name)
+
+ (#Only +defs)
+ (do Lux/Monad
+ [*defs (exported-defs m-name)]
+ (wrap (filter (is-member? +defs) *defs)))
+
+ (#Exclude -defs)
+ (do Lux/Monad
+ [*defs (exported-defs m-name)]
+ (wrap (filter (. not (is-member? -defs)) *defs)))
+
+ #Nothing
+ (wrap (@list)))
+ #let [openings (: (List AST)
+ (case m-openings
+ #None
+ (@list)
+
+ (#Some prefix structs)
+ (map (: (-> Ident AST)
+ (lambda [struct]
+ (let [[_ name] struct]
+ (` (open (~ (symbol$ [m-name name])) (~ (text$ prefix)))))))
+ structs)))]]
+ (wrap ($ list:++
+ (: (List AST) (@list (` (;_lux_import (~ (text$ m-name))))))
+ (: (List AST)
+ (case m-alias
+ #None (@list)
+ (#Some alias) (@list (` (;_lux_alias (~ (text$ alias)) (~ (text$ m-name)))))))
+ (map (: (-> Text AST)
+ (lambda [def]
+ (` (;_lux_def (~ (symbol$ ["" def])) (~ (symbol$ [m-name def]))))))
+ defs)
+ openings))))))
+ imports)]
+ (wrap (list:join output')))
+
+ _
+ (wrap (list:++ (map (: (-> Text AST) (lambda [m-name] (` (;_lux_import (~ (text$ m-name))))))
+ unknowns)
+ (: (List AST) (@list (` (;import (~@ tokens))))))))))
+
(def (foldL% M f x ys)
(All [m a b]
(-> (Monad m) (-> a b (m a)) a (List b)
(m a)))
(case ys
- (#Cons [y ys'])
+ (#Cons y ys')
(do M
[x' (f x y)]
(foldL% M f x' ys'))
@@ -2657,137 +3050,111 @@
(defmacro #export (:: tokens)
(case tokens
- (\ (list& start parts))
+ (\ (@list& start parts))
(do Lux/Monad
[output (foldL% Lux/Monad
- (: (-> Syntax Syntax (Lux Syntax))
+ (: (-> AST AST (Lux AST))
(lambda [so-far part]
(case part
- (#Meta [_ (#SymbolS slot)])
- (return (` (get@ (~ (tag$ slot)) (~ so-far))))
+ [_ (#SymbolS slot)]
+ (return (` (using (~ so-far) (~ (symbol$ slot)))))
- (\ (#Meta [_ (#FormS (list& (#Meta [_ (#SymbolS slot)]) args))]))
- (return (` ((get@ (~ (tag$ slot)) (~ so-far))
+ (\ [_ (#FormS (@list& [_ (#SymbolS slot)] args))])
+ (return (` ((using (~ so-far) (~ (symbol$ slot)))
(~@ args))))
_
(fail "Wrong syntax for ::"))))
start parts)]
- (return (list output)))
+ (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)))))))
+ (\ (@list [_ (#TagS slot')] value record))
+ (do Lux/Monad
+ [slot (normalize slot')
+ output (resolve-tag slot)
+ #let [[idx tags type] output]]
+ (case (resolve-struct-type type)
+ (#Some members)
+ (do Lux/Monad
+ [pattern' (map% Lux/Monad
+ (: (-> (, Ident (, Int Type)) (Lux (, Ident Int AST)))
+ (lambda [[r-slot-name [r-idx r-type]]]
+ (do Lux/Monad
+ [g!slot (gensym "")]
+ (return [r-slot-name r-idx g!slot]))))
+ (zip2 tags (enumerate members)))]
+ (let [pattern (record$ (map (: (-> (, Ident Int AST) (, AST AST))
+ (lambda [[r-slot-name r-idx r-var]]
+ [(tag$ r-slot-name) r-var]))
+ pattern'))
+ output (record$ (map (: (-> (, Ident Int AST) (, AST AST))
+ (lambda [[r-slot-name r-idx r-var]]
+ [(tag$ r-slot-name) (if (i= idx r-idx)
+ value
+ r-var)]))
+ pattern'))]
+ (return (@list (` (;_lux_case (~ record) (~ pattern) (~ output)))))))
- _
- (fail "set@ can only use records.")))
-
- _
- (do Lux/Monad
- [_record (gensym "")]
- (return (list (` (let [(~ _record) (~ record)]
- (set@ (~ (tag$ slot')) (~ value) (~ _record))))))))
+ _
+ (fail "set@ can only use records.")))
_
(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)))))))
+ (\ (@list [_ (#TagS slot')] fun record))
+ (do Lux/Monad
+ [slot (normalize slot')
+ output (resolve-tag slot)
+ #let [[idx tags type] output]]
+ (case (resolve-struct-type type)
+ (#Some members)
+ (do Lux/Monad
+ [pattern' (map% Lux/Monad
+ (: (-> (, Ident (, Int Type)) (Lux (, Ident Int AST)))
+ (lambda [[r-slot-name [r-idx r-type]]]
+ (do Lux/Monad
+ [g!slot (gensym "")]
+ (return [r-slot-name r-idx g!slot]))))
+ (zip2 tags (enumerate members)))]
+ (let [pattern (record$ (map (: (-> (, Ident Int AST) (, AST AST))
+ (lambda [[r-slot-name r-idx r-var]]
+ [(tag$ r-slot-name) r-var]))
+ pattern'))
+ output (record$ (map (: (-> (, Ident Int AST) (, AST AST))
+ (lambda [[r-slot-name r-idx r-var]]
+ [(tag$ r-slot-name) (if (i= idx r-idx)
+ (` ((~ fun) (~ r-var)))
+ r-var)]))
+ pattern'))]
+ (return (@list (` (;_lux_case (~ record) (~ pattern) (~ output)))))))
- _
- (fail "update@ can only use records.")))
-
- _
- (do Lux/Monad
- [_record (gensym "")]
- (return (list (` (let [(~ _record) (~ record)]
- (update@ (~ (tag$ slot')) (~ fun) (~ _record))))))))
+ _
+ (fail "update@ can only use records.")))
_
(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))
+ (\ (@list [_ (#TupleS data)]
+ [_ (#TupleS bindings)]
+ [_ (#TupleS templates)]))
+ (case (: (Maybe (List AST))
(do Maybe/Monad
- [bindings' (map% Maybe/Monad get-ident bindings)
+ [bindings' (map% Maybe/Monad get-name bindings)
data' (map% Maybe/Monad tuple->list data)]
- (let [apply (: (-> RepEnv (List Syntax))
+ (let [apply (: (-> RepEnv (List AST))
(lambda [env] (map (apply-template env) templates)))]
(|> data'
(join-map (. apply (make-env bindings')))
- ;return))))
+ wrap))))
(#Some output)
(return output)
@@ -2797,28 +3164,140 @@
_
(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")))
+(def (interleave xs ys)
+ (All [a] (-> (List a) (List a) (List a)))
+ (case xs
+ #Nil
+ #Nil
+
+ (#Cons x xs')
+ (case ys
+ #Nil
+ #Nil
+
+ (#Cons y ys')
+ (@list& x y (interleave xs' ys')))))
+
+(do-template [<name> <init> <op>]
+ [(def (<name> p xs)
+ (All [a]
+ (-> (-> a Bool) (List a) Bool))
+ (foldL (lambda [_1 _2] (<op> _1 (p _2))) <init> xs))]
+
+ [every? true and])
+
+(def (type->ast type)
+ (-> Type AST)
+ (case type
+ (#DataT name params)
+ (` (#DataT (~ (text$ name)) (~ (untemplate-list (map type->ast params)))))
+
+ (#;VariantT cases)
+ (` (#VariantT (~ (untemplate-list (map type->ast cases)))))
+
+ (#TupleT parts)
+ (` (#TupleT (~ (untemplate-list (map type->ast parts)))))
+
+ (#LambdaT in out)
+ (` (#LambdaT (~ (type->ast in)) (~ (type->ast out))))
+
+ (#BoundT idx)
+ (` (#BoundT (~ (int$ idx))))
+
+ (#VarT id)
+ (` (#VarT (~ (int$ id))))
+
+ (#ExT id)
+ (` (#ExT (~ (int$ id))))
+
+ (#UnivQ env type)
+ (let [env' (untemplate-list (map type->ast env))]
+ (` (#UnivQ (~ env') (~ (type->ast type)))))
+
+ (#ExQ env type)
+ (let [env' (untemplate-list (map type->ast env))]
+ (` (#ExQ (~ env') (~ (type->ast type)))))
+
+ (#AppT fun arg)
+ (` (#AppT (~ (type->ast fun)) (~ (type->ast arg))))
+
+ (#NamedT [module name] type)
+ (` (#NamedT [(~ (text$ module)) (~ (text$ name))] (~ (type->ast type))))))
+
+(defmacro #export (loop tokens)
+ (case tokens
+ (\ (@list [_ (#TupleS bindings)] body))
+ (let [pairs (as-pairs bindings)
+ vars (map first pairs)
+ inits (map second pairs)]
+ (if (every? symbol? inits)
+ (do Lux/Monad
+ [inits' (: (Lux (List Ident))
+ (case (map% Maybe/Monad get-ident inits)
+ (#Some inits') (return inits')
+ #None (fail "Wrong syntax for loop")))
+ init-types (map% Lux/Monad find-var-type inits')
+ expected expected-type]
+ (return (@list (` ((: (-> (~@ (map type->ast init-types))
+ (~ (type->ast expected)))
+ (lambda (~ (symbol$ ["" "recur"])) [(~@ vars)]
+ (~ body)))
+ (~@ inits))))))
+ (do Lux/Monad
+ [aliases (map% Lux/Monad
+ (: (-> AST (Lux AST))
+ (lambda [_] (gensym "")))
+ inits)]
+ (return (@list (` (let [(~@ (interleave aliases inits))]
+ (;loop [(~@ (interleave vars aliases))]
+ (~ body)))))))))
+
+ _
+ (fail "Wrong syntax for loop")))
+
+(defmacro #export (export tokens)
+ (return (map (: (-> AST AST) (lambda [token] (` (;_lux_export (~ token))))) tokens)))
+
+(defmacro #export (\slots tokens)
+ (case tokens
+ (\ (@list body [_ (#TupleS (@list& hslot' tslots'))]))
+ (do Lux/Monad
+ [slots (: (Lux (, Ident (List Ident)))
+ (case (: (Maybe (, Ident (List Ident)))
+ (do Maybe/Monad
+ [hslot (get-tag hslot')
+ tslots (map% Maybe/Monad get-tag tslots')]
+ (wrap [hslot tslots])))
+ (#Some slots)
+ (return slots)
+
+ #None
+ (fail "Wrong syntax for \\slots")))
+ #let [[hslot tslots] slots]
+ hslot (normalize hslot)
+ tslots (map% Lux/Monad normalize tslots)
+ output (resolve-tag hslot)
+ g!_ (gensym "_")
+ #let [[idx tags type] output
+ slot-pairings (map (: (-> Ident (, Text AST))
+ (lambda [[module name]] [name (symbol$ ["" name])]))
+ (@list& hslot tslots))
+ pattern (record$ (map (: (-> Ident (, AST AST))
+ (lambda [[module name]]
+ (let [tag (tag$ [module name])]
+ (case (get name slot-pairings)
+ (#Some binding) [tag binding]
+ #None [tag g!_]))))
+ tags))]]
+ (return (@list pattern body)))
+
+ _
+ (fail "Wrong syntax for \\slots")))
+
+(do-template [<name> <diff>]
+ [(def #export <name>
+ (-> Int Int)
+ (i+ <diff>))]
+
+ [inc 1]
+ [dec -1])
generated by cgit v1.2.3 (git 2.25.1) at 2025-01-15 23:36:30 +0000