aboutsummaryrefslogtreecommitdiff
path: root/source
diff options
context:
space:
mode:
authorLuxLang2015-10-01 12:50:27 -0400
committerLuxLang2015-10-01 12:50:27 -0400
commit3e2ce4d30fd457205b0d0268d870d47a8d1ec738 (patch)
tree580b42a5024c8767b2f2dd78a77a9911593acb77 /source
parente543739f21e03be7cc0192bf510f350f7065bfa5 (diff)
parent6fcf9690f914e9b8b4f0ab767164bc97aeb12ca4 (diff)
Merge pull request #12 from LuxLang/v0.3
V0.3
Diffstat (limited to 'source')
-rw-r--r--source/lux.lux4353
-rw-r--r--source/lux/codata/function.lux27
-rw-r--r--source/lux/codata/io.lux42
-rw-r--r--source/lux/codata/lazy.lux56
-rw-r--r--source/lux/codata/reader.lux30
-rw-r--r--source/lux/codata/state.lux39
-rw-r--r--source/lux/codata/stream.lux79
-rw-r--r--source/lux/control/bounded.lux14
-rw-r--r--source/lux/control/comonad.lux44
-rw-r--r--source/lux/control/enum.lux25
-rw-r--r--source/lux/control/eq.lux11
-rw-r--r--source/lux/control/fold.lux42
-rw-r--r--source/lux/control/functor.lux11
-rw-r--r--source/lux/control/hash.lux11
-rw-r--r--source/lux/control/lazy.lux47
-rw-r--r--source/lux/control/monad.lux80
-rw-r--r--source/lux/control/monoid.lux11
-rw-r--r--source/lux/control/number.lux25
-rw-r--r--source/lux/control/ord.lux (renamed from source/lux/data/ord.lux)19
-rw-r--r--source/lux/control/show.lux11
-rw-r--r--source/lux/data/bool.lux31
-rw-r--r--source/lux/data/bounded.lux17
-rw-r--r--source/lux/data/char.lux25
-rw-r--r--source/lux/data/dict.lux83
-rw-r--r--source/lux/data/either.lux53
-rw-r--r--source/lux/data/eq.lux14
-rw-r--r--source/lux/data/error.lux34
-rw-r--r--source/lux/data/id.lux33
-rw-r--r--source/lux/data/ident.lux33
-rw-r--r--source/lux/data/io.lux52
-rw-r--r--source/lux/data/list.lux228
-rw-r--r--source/lux/data/maybe.lux38
-rw-r--r--source/lux/data/number.lux113
-rw-r--r--source/lux/data/number/int.lux93
-rw-r--r--source/lux/data/number/real.lux93
-rw-r--r--source/lux/data/reader.lux33
-rw-r--r--source/lux/data/show.lux14
-rw-r--r--source/lux/data/state.lux35
-rw-r--r--source/lux/data/text.lux96
-rw-r--r--source/lux/data/tuple.lux35
-rw-r--r--source/lux/data/writer.lux23
-rw-r--r--source/lux/host/io.lux60
-rw-r--r--source/lux/host/jvm.lux543
-rw-r--r--source/lux/math.lux33
-rw-r--r--source/lux/meta/ast.lux113
-rw-r--r--source/lux/meta/lux.lux304
-rw-r--r--source/lux/meta/macro.lux54
-rw-r--r--source/lux/meta/syntax.lux208
-rw-r--r--source/lux/meta/type.lux193
-rw-r--r--source/program.lux48
50 files changed, 4524 insertions, 3185 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])
diff --git a/source/lux/codata/function.lux b/source/lux/codata/function.lux
new file mode 100644
index 000000000..1b7336049
--- /dev/null
+++ b/source/lux/codata/function.lux
@@ -0,0 +1,27 @@
+## Copyright (c) Eduardo Julian. All rights reserved.
+## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
+## If a copy of the MPL was not distributed with this file,
+## You can obtain one at http://mozilla.org/MPL/2.0/.
+
+(;import lux
+ (lux/control (monoid #as m)))
+
+## [Functions]
+(def #export (const x y)
+ (All [a b] (-> a (-> b a)))
+ x)
+
+(def #export (flip f)
+ (All [a b c]
+ (-> (-> a b c) (-> b a c)))
+ (lambda [x y] (f y x)))
+
+(def #export (. f g)
+ (All [a b c]
+ (-> (-> b c) (-> a b) (-> a c)))
+ (lambda [x] (f (g x))))
+
+## [Structures]
+(defstruct #export Comp/Monoid (All [a] (m;Monoid (-> a a)))
+ (def unit id)
+ (def ++ .))
diff --git a/source/lux/codata/io.lux b/source/lux/codata/io.lux
new file mode 100644
index 000000000..195aef616
--- /dev/null
+++ b/source/lux/codata/io.lux
@@ -0,0 +1,42 @@
+## Copyright (c) Eduardo Julian. All rights reserved.
+## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
+## If a copy of the MPL was not distributed with this file,
+## You can obtain one at http://mozilla.org/MPL/2.0/.
+
+(;import lux
+ (lux (control (functor #as F)
+ (monad #as M))
+ (data list)))
+
+## [Types]
+(deftype #export (IO a)
+ (-> (,) a))
+
+## [Syntax]
+(defmacro #export (@io tokens state)
+ (case tokens
+ (\ (@list value))
+ (let [blank (: AST [["" -1 -1] (#;SymbolS ["" ""])])]
+ (#;Right [state (@list (` (;_lux_lambda (~ blank) (~ blank) (~ value))))]))
+
+ _
+ (#;Left "Wrong syntax for @io")))
+
+## [Structures]
+(defstruct #export IO/Functor (F;Functor IO)
+ (def (map f ma)
+ (@io (f (ma [])))))
+
+(defstruct #export IO/Monad (M;Monad IO)
+ (def _functor IO/Functor)
+
+ (def (wrap x)
+ (@io x))
+
+ (def (join mma)
+ (mma [])))
+
+## [Functions]
+(def #export (run-io io)
+ (All [a] (-> (IO a) a))
+ (io []))
diff --git a/source/lux/codata/lazy.lux b/source/lux/codata/lazy.lux
new file mode 100644
index 000000000..c0c79fc1a
--- /dev/null
+++ b/source/lux/codata/lazy.lux
@@ -0,0 +1,56 @@
+## Copyright (c) Eduardo Julian. All rights reserved.
+## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
+## If a copy of the MPL was not distributed with this file,
+## You can obtain one at http://mozilla.org/MPL/2.0/.
+
+(;import lux
+ (lux (meta ast)
+ (control (functor #as F #refer #all)
+ (monad #as M #refer #all))
+ (data list))
+ (.. function))
+
+## [Types]
+(deftype #export (Lazy a)
+ (All [b]
+ (-> (-> a b) b)))
+
+## [Syntax]
+(defmacro #export (... tokens state)
+ (case tokens
+ (\ (@list value))
+ (let [blank (symbol$ ["" ""])]
+ (#;Right [state (@list (` (;lambda [(~ blank)] ((~ blank) (~ value)))))]))
+
+ _
+ (#;Left "Wrong syntax for ...")))
+
+## [Functions]
+(def #export (! thunk)
+ (All [a]
+ (-> (Lazy a) a))
+ (thunk id))
+
+(def #export (call/cc f)
+ (All [a b c] (Lazy (-> a (Lazy b c)) (Lazy a c)))
+ (lambda [k]
+ (f (lambda [a _]
+ (k a))
+ k)))
+
+(def #export (run-lazy l k)
+ (All [a z] (-> (Lazy a z) (-> a z) z))
+ (l k))
+
+## [Structs]
+(defstruct #export Lazy/Functor (Functor Lazy)
+ (def (map f ma)
+ (lambda [k] (ma (. k f)))))
+
+(defstruct #export Lazy/Monad (Monad Lazy)
+ (def _functor Lazy/Functor)
+
+ (def (wrap a)
+ (... a))
+
+ (def join !))
diff --git a/source/lux/codata/reader.lux b/source/lux/codata/reader.lux
new file mode 100644
index 000000000..e776f73ec
--- /dev/null
+++ b/source/lux/codata/reader.lux
@@ -0,0 +1,30 @@
+## Copyright (c) Eduardo Julian. All rights reserved.
+## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
+## If a copy of the MPL was not distributed with this file,
+## You can obtain one at http://mozilla.org/MPL/2.0/.
+
+(;import (lux #refer (#exclude Reader))
+ (lux/control (functor #as F #refer #all)
+ (monad #as M #refer #all)))
+
+## [Types]
+(deftype #export (Reader r a)
+ (-> r a))
+
+## [Structures]
+(defstruct #export Reader/Functor (All [r]
+ (Functor (Reader r)))
+ (def (map f fa)
+ (lambda [env]
+ (f (fa env)))))
+
+(defstruct #export Reader/Monad (All [r]
+ (Monad (Reader r)))
+ (def _functor Reader/Functor)
+
+ (def (wrap x)
+ (lambda [env] x))
+
+ (def (join mma)
+ (lambda [env]
+ (mma env env))))
diff --git a/source/lux/codata/state.lux b/source/lux/codata/state.lux
new file mode 100644
index 000000000..311fce320
--- /dev/null
+++ b/source/lux/codata/state.lux
@@ -0,0 +1,39 @@
+## Copyright (c) Eduardo Julian. All rights reserved.
+## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
+## If a copy of the MPL was not distributed with this file,
+## You can obtain one at http://mozilla.org/MPL/2.0/.
+
+(;import lux
+ (lux/control (functor #as F #refer #all)
+ (monad #as M #refer #all)))
+
+## [Types]
+(deftype #export (State s a)
+ (-> s (, s a)))
+
+## [Structures]
+(defstruct #export State/Functor (All [s]
+ (Functor (State s)))
+ (def (map f ma)
+ (lambda [state]
+ (let [[state' a] (ma state)]
+ [state' (f a)]))))
+
+(defstruct #export State/Monad (All [s]
+ (Monad (State s)))
+ (def _functor State/Functor)
+
+ (def (wrap a)
+ (lambda [state]
+ [state a]))
+
+ (def (join mma)
+ (lambda [state]
+ (let [[state' ma] (mma state)]
+ (ma state')))))
+
+## [Functions]
+(def #export (run-state state action)
+ (All [s a] (-> s (State s a) a))
+ (let [[state' output] (action state)]
+ output))
diff --git a/source/lux/codata/stream.lux b/source/lux/codata/stream.lux
index 1d6dd1b50..86ce99761 100644
--- a/source/lux/codata/stream.lux
+++ b/source/lux/codata/stream.lux
@@ -1,20 +1,20 @@
-## 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/.
(;import lux
- (lux (control (lazy #as L #refer #all)
- (functor #as F #refer #all)
+ (lux (control (functor #as F #refer #all)
(monad #as M #refer #all)
(comonad #as CM #refer #all))
(meta lux
- macro
syntax)
- (data (list #as l #refer (#only list list& List/Monad)))))
+ (data (list #as l #refer (#only @list @list& List/Monad) #open ("" List/Fold))
+ (number (int #open ("i" Int/Number Int/Ord)))
+ bool)
+ (codata (lazy #as L #refer #all))))
+
+(open List/Monad "list:")
## [Types]
(deftype #export (Stream a)
@@ -25,8 +25,8 @@
(All [a]
(-> a (List a) a (List a) (Stream a)))
(case xs
- #;Nil (cycle' init full init full)
- (#;Cons [y xs']) (... [x (cycle' y xs' init full)])))
+ #;Nil (cycle' init full init full)
+ (#;Cons x' xs') (... [x (cycle' x' xs' init full)])))
## [Functions]
(def #export (iterate f x)
@@ -43,8 +43,8 @@
(All [a]
(-> (List a) (Maybe (Stream a))))
(case xs
- #;Nil #;None
- (#;Cons [x xs']) (#;Some (cycle' x xs' x xs'))))
+ #;Nil #;None
+ (#;Cons x xs') (#;Some (cycle' x xs' x xs'))))
(do-template [<name> <return> <part>]
[(def #export (<name> s)
@@ -59,7 +59,7 @@
(All [a] (-> Int (Stream a) a))
(let [[h t] (! s)]
(if (i> idx 0)
- (@ (dec idx) t)
+ (@ (i+ -1 idx) t)
h)))
(do-template [<taker> <dropper> <splitter> <det-type> <det-test> <det-step>]
@@ -68,8 +68,8 @@
(-> <det-type> (Stream a) (List a)))
(let [[x xs'] (! xs)]
(if <det-test>
- (list& x (<taker> <det-step> xs'))
- (list))))
+ (@list& x (<taker> <det-step> xs'))
+ (@list))))
(def #export (<dropper> det xs)
(All [a]
@@ -86,10 +86,10 @@
(if <det-test>
(let [[tail next] (<splitter> <det-step> xs')]
[(#;Cons [x tail]) next])
- [(list) xs])))]
+ [(@list) xs])))]
[take-while drop-while split-with (-> a Bool) (det x) det]
- [take drop split Int (i> det 0) (dec det)]
+ [take drop split Int (i> det 0) (i+ -1 det)]
)
(def #export (unfold step init)
@@ -107,27 +107,34 @@
(def #export (partition p xs)
(All [a] (-> (-> a Bool) (Stream a) (, (Stream a) (Stream a))))
- [(filter p xs) (filter (complement p) xs)])
+ [(filter p xs) (filter (comp p) xs)])
## [Structures]
(defstruct #export Stream/Functor (Functor Stream)
- (def (F;map f fa)
+ (def (map f fa)
(let [[h t] (! fa)]
- (... [(f h) (F;map f t)]))))
+ (... [(f h) (map f t)]))))
(defstruct #export Stream/CoMonad (CoMonad Stream)
- (def CM;_functor Stream/Functor)
- (def CM;unwrap head)
- (def (CM;split wa)
- (:: Stream/Functor (F;map repeat wa))))
+ (def _functor Stream/Functor)
+ (def unwrap head)
+ (def (split wa)
+ (let [[head tail] (! wa)]
+ (... [wa (split tail)]))))
## [Pattern-matching]
-(defsyntax #export (\stream body [patterns' (+^ id^)])
- (do Lux/Monad
- [patterns (map% Lux/Monad macro-expand-1 patterns')
- g!s (gensym "s")
- #let [patterns+ (: (List Syntax)
- (do List/Monad
- [pattern (l;reverse patterns)]
- (list (` [(~ pattern) (~ g!s)]) (` (L;! (~ g!s))))))]]
- (M;wrap (list g!s (` (;let [(~@ patterns+)] (~ body)))))))
+(defsyntax #export (\stream& body [patterns (+^ id^)])
+ (case (l;reverse patterns)
+ (\ (@list& last prevs))
+ (do Lux/Monad
+ [prevs (map% Lux/Monad macro-expand-1 prevs)
+ g!s (gensym "s")
+ #let [body+ (foldL (lambda [inner outer]
+ (` (let [[(~ outer) (~ g!s)] (! (~ g!s))]
+ (~ inner))))
+ (` (let [(~ last) (~ g!s)] (~ body)))
+ prevs)]]
+ (wrap (@list g!s body+)))
+
+ _
+ (fail "Wrong syntax for \\stream&")))
diff --git a/source/lux/control/bounded.lux b/source/lux/control/bounded.lux
new file mode 100644
index 000000000..b4c8a3e57
--- /dev/null
+++ b/source/lux/control/bounded.lux
@@ -0,0 +1,14 @@
+## Copyright (c) Eduardo Julian. All rights reserved.
+## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
+## If a copy of the MPL was not distributed with this file,
+## You can obtain one at http://mozilla.org/MPL/2.0/.
+
+(;import lux)
+
+## Signatures
+(defsig #export (Bounded a)
+ (: a
+ top)
+
+ (: a
+ bottom))
diff --git a/source/lux/control/comonad.lux b/source/lux/control/comonad.lux
index ce9a7e7de..2543f34da 100644
--- a/source/lux/control/comonad.lux
+++ b/source/lux/control/comonad.lux
@@ -1,17 +1,13 @@
-## 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/.
(;import lux
(../functor #as F)
- lux/data/list
- lux/meta/macro)
+ (lux/data/list #refer #all #open ("" List/Fold)))
-## Signatures
+## [Signatures]
(defsig #export (CoMonad w)
(: (F;Functor w)
_functor)
@@ -22,33 +18,35 @@
(-> (w a) (w (w a))))
split))
-## Functions
+## [Functions]
(def #export (extend w f ma)
(All [w a b]
(-> (CoMonad w) (-> (w a) b) (w a) (w b)))
(using w
- (using _functor
- (map f (split ma)))))
+ (map f (split ma))))
-## Syntax
+## [Syntax]
(defmacro #export (be tokens state)
(case tokens
- (\ (list monad (#;Meta [_ (#;TupleS bindings)]) body))
- (let [body' (foldL (: (-> Syntax (, Syntax Syntax) Syntax)
+ (#;Cons comonad (#;Cons [_ (#;TupleS bindings)] (#;Cons body #;Nil)))
+ (let [g!map (: AST [["" -1 -1] (#;SymbolS ["" " map "])])
+ g!split (: AST [["" -1 -1] (#;SymbolS ["" " split "])])
+ body' (foldL (: (-> AST (, AST AST) AST)
(lambda [body' binding]
(let [[var value] binding]
(case var
- (#;Meta [_ (#;TagS ["" "let"])])
- (` (;let (~ value) (~ body')))
+ [_ (#;TagS ["" "let"])]
+ (` (let (~ value) (~ body')))
_
- (` (extend (;lambda [(~ var)] (~ body'))
- (~ value)))))))
+ (` (|> (~ value) (~ g!split) ((~ g!map) (lambda [(~ var)] (~ body')))))
+ ))))
body
(reverse (as-pairs bindings)))]
- (#;Right [state (list (` (;case (~ monad)
- {#;return ;return #;bind ;bind}
- (~ body'))))]))
+ (#;Right [state (#;Cons (` (case (~ comonad)
+ {#_functor {#F;map (~ g!map)} #unwrap (~ (' unwrap)) #split (~ g!split)}
+ (~ body')))
+ #;Nil)]))
_
(#;Left "Wrong syntax for be")))
diff --git a/source/lux/control/enum.lux b/source/lux/control/enum.lux
new file mode 100644
index 000000000..4ce368e96
--- /dev/null
+++ b/source/lux/control/enum.lux
@@ -0,0 +1,25 @@
+## Copyright (c) Eduardo Julian. All rights reserved.
+## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
+## If a copy of the MPL was not distributed with this file,
+## You can obtain one at http://mozilla.org/MPL/2.0/.
+
+(;import lux
+ (lux/control ord))
+
+## [Signatures]
+(defsig #export (Enum e)
+ (: (Ord e) _ord)
+ (: (-> e e) succ)
+ (: (-> e e) pred))
+
+## [Functions]
+(def (range' <= succ from to)
+ (All [a] (-> (-> a a Bool) (-> a a) a a (List a)))
+ (if (<= from to)
+ (#;Cons from (range' <= succ (succ from) to))
+ #;Nil))
+
+(def #export (range enum from to)
+ (All [a] (-> (Enum a) a a (List a)))
+ (using enum
+ (range' <= succ from to)))
diff --git a/source/lux/control/eq.lux b/source/lux/control/eq.lux
new file mode 100644
index 000000000..d86df5757
--- /dev/null
+++ b/source/lux/control/eq.lux
@@ -0,0 +1,11 @@
+## Copyright (c) Eduardo Julian. All rights reserved.
+## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
+## If a copy of the MPL was not distributed with this file,
+## You can obtain one at http://mozilla.org/MPL/2.0/.
+
+(;import lux)
+
+## [Signatures]
+(defsig #export (Eq a)
+ (: (-> a a Bool)
+ =))
diff --git a/source/lux/control/fold.lux b/source/lux/control/fold.lux
new file mode 100644
index 000000000..d0aef1576
--- /dev/null
+++ b/source/lux/control/fold.lux
@@ -0,0 +1,42 @@
+## Copyright (c) Eduardo Julian. All rights reserved.
+## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
+## If a copy of the MPL was not distributed with this file,
+## You can obtain one at http://mozilla.org/MPL/2.0/.
+
+(;import lux
+ (lux (control monoid
+ eq)
+ (data/number/int #open ("i" Int/Number Int/Eq))))
+
+## [Signatures]
+(defsig #export (Fold F)
+ (: (All [a b]
+ (-> (-> a b a) a (F b) a))
+ foldL)
+ (: (All [a b]
+ (-> (-> b a a) a (F b) a))
+ foldR))
+
+## [Functions]
+(def #export (foldM mon fold xs)
+ (All [F a] (-> (Monoid a) (Fold F) (F a) a))
+ (using [mon fold]
+ (foldL ++ unit xs)))
+
+(def #export (size fold xs)
+ (All [F a] (-> (Fold F) (F a) Int))
+ (using fold
+ (foldL (lambda [count _] (i+ 1 count))
+ 0
+ xs)))
+
+(def #export (member? eq fold x xs)
+ (All [F a] (-> (Eq a) (Fold F) a (F a) Bool))
+ (using [eq fold]
+ (foldL (lambda [prev x'] (or prev (= x x')))
+ false
+ xs)))
+
+(def #export (empty? fold xs)
+ (All [F a] (-> (Fold F) (F a) Bool))
+ (i= 0 (size fold xs)))
diff --git a/source/lux/control/functor.lux b/source/lux/control/functor.lux
index 6a9dcfff8..99c34a45c 100644
--- a/source/lux/control/functor.lux
+++ b/source/lux/control/functor.lux
@@ -1,10 +1,7 @@
-## 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/.
(;import lux)
diff --git a/source/lux/control/hash.lux b/source/lux/control/hash.lux
new file mode 100644
index 000000000..643c49e9d
--- /dev/null
+++ b/source/lux/control/hash.lux
@@ -0,0 +1,11 @@
+## Copyright (c) Eduardo Julian. All rights reserved.
+## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
+## If a copy of the MPL was not distributed with this file,
+## You can obtain one at http://mozilla.org/MPL/2.0/.
+
+(;import lux)
+
+## [Signatures]
+(defsig #export (Hash a)
+ (: (-> a Int)
+ hash))
diff --git a/source/lux/control/lazy.lux b/source/lux/control/lazy.lux
deleted file mode 100644
index 22dac74fe..000000000
--- a/source/lux/control/lazy.lux
+++ /dev/null
@@ -1,47 +0,0 @@
-## Copyright (c) Eduardo Julian. All rights reserved.
-## The use and distribution terms for this software are covered by the
-## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
-## which can be found in the file epl-v10.html at the root of this distribution.
-## By using this software in any fashion, you are agreeing to be bound by
-## the terms of this license.
-## You must not remove this notice, or any other, from this software.
-
-(;import lux
- (lux/meta macro)
- (.. (functor #as F #refer #all)
- (monad #as M #refer #all))
- (lux/data list))
-
-## Types
-(deftype #export (Lazy a)
- (All [b]
- (-> (-> a b) b)))
-
-## Syntax
-(defmacro #export (... tokens state)
- (case tokens
- (\ (list value))
- (let [blank (symbol$ ["" ""])]
- (#;Right [state (list (` (;lambda [(~ blank)] ((~ blank) (~ value)))))]))
-
- _
- (#;Left "Wrong syntax for ...")))
-
-## Functions
-(def #export (! thunk)
- (All [a]
- (-> (Lazy a) a))
- (thunk id))
-
-## Structs
-(defstruct #export Lazy/Functor (Functor Lazy)
- (def (F;map f ma)
- (lambda [k] (ma (. k f)))))
-
-(defstruct #export Lazy/Monad (Monad Lazy)
- (def M;_functor Lazy/Functor)
-
- (def (M;wrap a)
- (... a))
-
- (def M;join !))
diff --git a/source/lux/control/monad.lux b/source/lux/control/monad.lux
index a03c1499a..e5c5989cf 100644
--- a/source/lux/control/monad.lux
+++ b/source/lux/control/monad.lux
@@ -1,15 +1,11 @@
-## 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/.
(;import lux
(.. (functor #as F)
- (monoid #as M))
- lux/meta/macro)
+ (monoid #as M)))
## [Utils]
(def (foldL f init xs)
@@ -19,21 +15,21 @@
#;Nil
init
- (#;Cons [x xs'])
+ (#;Cons x xs')
(foldL f (f init x) xs')))
(def (reverse xs)
(All [a]
(-> (List a) (List a)))
- (foldL (lambda [tail head] (#;Cons [head tail]))
+ (foldL (lambda [tail head] (#;Cons head tail))
#;Nil
xs))
(def (as-pairs xs)
(All [a] (-> (List a) (List (, a a))))
(case xs
- (#;Cons [x1 (#;Cons [x2 xs'])])
- (#;Cons [[x1 x2] (as-pairs xs')])
+ (#;Cons x1 (#;Cons x2 xs'))
+ (#;Cons [x1 x2] (as-pairs xs'))
_
#;Nil))
@@ -52,27 +48,25 @@
## [Syntax]
(defmacro #export (do tokens state)
(case tokens
- ## (\ (list monad (#;Meta [_ (#;TupleS bindings)]) body))
- (#;Cons [monad (#;Cons [(#;Meta [_ (#;TupleS bindings)]) (#;Cons [body #;Nil])])])
- (let [body' (foldL (: (-> Syntax (, Syntax Syntax) Syntax)
+ (#;Cons monad (#;Cons [_ (#;TupleS bindings)] (#;Cons body #;Nil)))
+ (let [g!map (: AST [["" -1 -1] (#;SymbolS ["" " map "])])
+ g!join (: AST [["" -1 -1] (#;SymbolS ["" " join "])])
+ body' (foldL (: (-> AST (, AST AST) AST)
(lambda [body' binding]
(let [[var value] binding]
(case var
- (#;Meta [_ (#;TagS ["" "let"])])
- (` (;let (~ value) (~ body')))
+ [_ (#;TagS ["" "let"])]
+ (` (let (~ value) (~ body')))
_
- (` (;case ;;_functor
- {#F;map F;map}
- (;|> (~ value) (F;map (;lambda [(~ var)] (~ body'))) (;;join))))
- ## (` (;|> (~ value) (F;map (;lambda [(~ var)] (~ body'))) (;:: ;;_functor) (;;join)))
+ (` (|> (~ value) ((~ g!map) (lambda [(~ var)] (~ body'))) (~ g!join)))
))))
body
(reverse (as-pairs bindings)))]
- (#;Right [state (#;Cons [(` (;case (~ monad)
- {#;;_functor ;;_functor #;;wrap ;;wrap #;;join ;;join}
- (~ body')))
- #;Nil])]))
+ (#;Right [state (#;Cons (` (case (~ monad)
+ {#_functor {#F;map (~ g!map)} #wrap (~ (' wrap)) #join (~ g!join)}
+ (~ body')))
+ #;Nil)]))
_
(#;Left "Wrong syntax for do")))
@@ -82,18 +76,32 @@
(All [m a b]
(-> (Monad m) (-> a (m b)) (m a) (m b)))
(using m
- (join (:: _functor (F;map f ma)))))
+ (join (map f ma))))
-(def #export (map% m f xs)
- (All [m a b]
- (-> (Monad m) (-> a (m b)) (List a) (m (List b))))
+(def #export (seq% monad xs)
+ (All [M a]
+ (-> (Monad M) (List (M a)) (M (List a))))
+ (case xs
+ #;Nil
+ (:: monad (wrap #;Nil))
+
+ (#;Cons x xs')
+ (do monad
+ [_x x
+ _xs (seq% monad xs')]
+ (wrap (#;Cons _x _xs)))
+ ))
+
+(def #export (map% monad f xs)
+ (All [M a b]
+ (-> (Monad M) (-> a (M b)) (List a) (M (List b))))
(case xs
#;Nil
- (:: m (;;wrap #;Nil))
+ (:: monad (wrap #;Nil))
- (#;Cons [x xs'])
- (do m
- [y (f x)
- ys (map% m f xs')]
- (;;wrap (#;Cons [y ys])))
+ (#;Cons x xs')
+ (do monad
+ [_x (f x)
+ _xs (map% monad f xs')]
+ (wrap (#;Cons _x _xs)))
))
diff --git a/source/lux/control/monoid.lux b/source/lux/control/monoid.lux
index d32baabc5..447ab8225 100644
--- a/source/lux/control/monoid.lux
+++ b/source/lux/control/monoid.lux
@@ -1,10 +1,7 @@
-## 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/.
(;import lux)
diff --git a/source/lux/control/number.lux b/source/lux/control/number.lux
new file mode 100644
index 000000000..b1bbec190
--- /dev/null
+++ b/source/lux/control/number.lux
@@ -0,0 +1,25 @@
+## Copyright (c) Eduardo Julian. All rights reserved.
+## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
+## If a copy of the MPL was not distributed with this file,
+## You can obtain one at http://mozilla.org/MPL/2.0/.
+
+(;import lux
+ (lux/control (monoid #as m)
+ (eq #as E)
+ (ord #as O)
+ (bounded #as B)
+ (show #as S)))
+
+## [Signatures]
+(defsig #export (Number n)
+ (do-template [<name>]
+ [(: (-> n n n) <name>)]
+ [+] [-] [*] [/] [%])
+
+ (do-template [<name>]
+ [(: (-> n n) <name>)]
+ [negate] [signum] [abs])
+
+ (: (-> Int n)
+ from-int)
+ )
diff --git a/source/lux/data/ord.lux b/source/lux/control/ord.lux
index 80f2e4fb5..cb77e7042 100644
--- a/source/lux/data/ord.lux
+++ b/source/lux/control/ord.lux
@@ -1,10 +1,7 @@
-## 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/.
(;import lux
(../eq #as E))
@@ -27,11 +24,11 @@
(def < <)
(def (<= x y)
(or (< x y)
- (:: eq (E;= x y))))
+ (:: eq (= x y))))
(def > >)
(def (>= x y)
(or (> x y)
- (:: eq (E;= x y))))))
+ (:: eq (= x y))))))
## [Functions]
(do-template [<name> <op>]
@@ -40,5 +37,5 @@
(-> (Ord a) a a a))
(if (:: ord (<op> x y)) x y))]
- [max ;;>]
- [min ;;<])
+ [max >]
+ [min <])
diff --git a/source/lux/control/show.lux b/source/lux/control/show.lux
new file mode 100644
index 000000000..706819ec2
--- /dev/null
+++ b/source/lux/control/show.lux
@@ -0,0 +1,11 @@
+## Copyright (c) Eduardo Julian. All rights reserved.
+## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
+## If a copy of the MPL was not distributed with this file,
+## You can obtain one at http://mozilla.org/MPL/2.0/.
+
+(;import lux)
+
+## [Signatures]
+(defsig #export (Show a)
+ (: (-> a Text)
+ show))
diff --git a/source/lux/data/bool.lux b/source/lux/data/bool.lux
index d4f223612..a3e28733b 100644
--- a/source/lux/data/bool.lux
+++ b/source/lux/data/bool.lux
@@ -1,33 +1,36 @@
-## 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/.
(;import lux
- (lux/control (monoid #as m))
- (.. (eq #as E)
- (show #as S)))
+ (lux (control (monoid #as m)
+ (eq #as E)
+ (show #as S))
+ (codata function)))
## [Structures]
(defstruct #export Bool/Eq (E;Eq Bool)
- (def (E;= x y)
+ (def (= x y)
(if x
y
(not y))))
(defstruct #export Bool/Show (S;Show Bool)
- (def (S;show x)
+ (def (show x)
(if x "true" "false")))
(do-template [<name> <unit> <op>]
[(defstruct #export <name> (m;Monoid Bool)
- (def m;unit <unit>)
- (def (m;++ x y)
+ (def unit <unit>)
+ (def (++ x y)
(<op> x y)))]
[ Or/Monoid false or]
[And/Monoid true and]
)
+
+## [Functions]
+(def #export comp
+ (All [a] (-> (-> a Bool) (-> a Bool)))
+ (. not))
diff --git a/source/lux/data/bounded.lux b/source/lux/data/bounded.lux
deleted file mode 100644
index 9d2dabde1..000000000
--- a/source/lux/data/bounded.lux
+++ /dev/null
@@ -1,17 +0,0 @@
-## Copyright (c) Eduardo Julian. All rights reserved.
-## The use and distribution terms for this software are covered by the
-## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
-## which can be found in the file epl-v10.html at the root of this distribution.
-## By using this software in any fashion, you are agreeing to be bound by
-## the terms of this license.
-## You must not remove this notice, or any other, from this software.
-
-(;import lux)
-
-## Signatures
-(defsig #export (Bounded a)
- (: a
- top)
-
- (: a
- bottom))
diff --git a/source/lux/data/char.lux b/source/lux/data/char.lux
index 5a811c006..b7b4c6bda 100644
--- a/source/lux/data/char.lux
+++ b/source/lux/data/char.lux
@@ -1,21 +1,22 @@
-## 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/.
(;import lux
- (.. (eq #as E)
- (show #as S)
- (text #as T #open ("text:" Text/Monoid))))
+ (lux/control (eq #as E)
+ (show #as S))
+ (.. (text #as T #open ("text:" Text/Monoid))))
## [Structures]
(defstruct #export Char/Eq (E;Eq Char)
- (def (E;= x y)
+ (def (= x y)
(_jvm_ceq x y)))
(defstruct #export Char/Show (S;Show Char)
- (def (S;show x)
+ (def (show x)
($ text:++ "#\"" (_jvm_invokevirtual "java.lang.Object" "toString" [] x []) "\"")))
+
+(def #export (->text c)
+ (-> Char Text)
+ (_jvm_invokevirtual "java.lang.Object" "toString" [] c []))
diff --git a/source/lux/data/dict.lux b/source/lux/data/dict.lux
deleted file mode 100644
index 63a66d49b..000000000
--- a/source/lux/data/dict.lux
+++ /dev/null
@@ -1,83 +0,0 @@
-## Copyright (c) Eduardo Julian. All rights reserved.
-## The use and distribution terms for this software are covered by the
-## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
-## which can be found in the file epl-v10.html at the root of this distribution.
-## By using this software in any fashion, you are agreeing to be bound by
-## the terms of this license.
-## You must not remove this notice, or any other, from this software.
-
-(;import lux
- (lux/data (eq #as E)))
-
-## Signatures
-(defsig #export (Dict d)
- (: (All [k v]
- (-> k (d k v) (Maybe v)))
- get)
- (: (All [k v]
- (-> k v (d k v) (d k v)))
- put)
- (: (All [k v]
- (-> k (d k v) (d k v)))
- remove))
-
-## Types
-(deftype #export (PList k v)
- (| (#PList (, (E;Eq k) (List (, k v))))))
-
-## Constructors
-(def #export (plist eq)
- (All [k v]
- (-> (E;Eq k) (PList k v)))
- (#PList [eq #;Nil]))
-
-## Utils
-(def (pl-get eq k kvs)
- (All [k v]
- (-> (E;Eq k) k (List (, k v)) (Maybe v)))
- (case kvs
- #;Nil
- #;None
-
- (#;Cons [[k' v'] kvs'])
- (if (:: eq (E;= k k'))
- (#;Some v')
- (pl-get eq k kvs'))))
-
-(def (pl-put eq k v kvs)
- (All [k v]
- (-> (E;Eq k) k v (List (, k v)) (List (, k v))))
- (case kvs
- #;Nil
- (#;Cons [[k v] kvs])
-
- (#;Cons [[k' v'] kvs'])
- (if (:: eq (E;= k k'))
- (#;Cons [[k v] kvs'])
- (#;Cons [[k' v'] (pl-put eq k v kvs')]))))
-
-(def (pl-remove eq k kvs)
- (All [k v]
- (-> (E;Eq k) k (List (, k v)) (List (, k v))))
- (case kvs
- #;Nil
- kvs
-
- (#;Cons [[k' v'] kvs'])
- (if (:: eq (E;= k k'))
- kvs'
- (#;Cons [[k' v'] (pl-remove eq k kvs')]))))
-
-## Structs
-(defstruct #export PList/Dict (Dict PList)
- (def (get k plist)
- (let [(#PList [eq kvs]) plist]
- (pl-get eq k kvs)))
-
- (def (put k v plist)
- (let [(#PList [eq kvs]) plist]
- (#PList [eq (pl-put eq k v kvs)])))
-
- (def (remove k plist)
- (let [(#PList [eq kvs]) plist]
- (#PList [eq (pl-remove eq k kvs)]))))
diff --git a/source/lux/data/either.lux b/source/lux/data/either.lux
index eba6438db..38de1e2d1 100644
--- a/source/lux/data/either.lux
+++ b/source/lux/data/either.lux
@@ -1,13 +1,12 @@
-## 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/.
(;import lux
- (lux/data (list #refer (#exclude partition))))
+ (lux (control (functor #as F #refer #all)
+ (monad #as M #refer #all))
+ (data (list #refer (#exclude partition)))))
## [Types]
## (deftype (Either l r)
@@ -33,14 +32,32 @@
[rights b #;Right]
)
-(def #export (partition es)
+(def #export (partition xs)
(All [a b] (-> (List (Either a b)) (, (List a) (List b))))
- (foldL (: (All [a b]
- (-> (, (List a) (List b)) (Either a b) (, (List a) (List b))))
- (lambda [tails e]
- (let [[ltail rtail] tails]
- (case e
- (#;Left x) [(#;Cons [x ltail]) rtail]
- (#;Right x) [ltail (#;Cons [x rtail])]))))
- [(list) (list)]
- (reverse es)))
+ (case xs
+ #;Nil
+ [#;Nil #;Nil]
+
+ (#;Cons x xs')
+ (let [[lefts rights] (partition xs')]
+ (case x
+ (#;Left x') [(#;Cons x' lefts) rights]
+ (#;Right x') [lefts (#;Cons x' rights)]))))
+
+## [Structures]
+(defstruct #export Error/Functor (All [a] (Functor (Either a)))
+ (def (map f ma)
+ (case ma
+ (#;Left msg) (#;Left msg)
+ (#;Right datum) (#;Right (f datum)))))
+
+(defstruct #export Error/Monad (All [a] (Monad (Either a)))
+ (def _functor Error/Functor)
+
+ (def (wrap a)
+ (#;Right a))
+
+ (def (join mma)
+ (case mma
+ (#;Left msg) (#;Left msg)
+ (#;Right ma) ma)))
diff --git a/source/lux/data/eq.lux b/source/lux/data/eq.lux
deleted file mode 100644
index be3400208..000000000
--- a/source/lux/data/eq.lux
+++ /dev/null
@@ -1,14 +0,0 @@
-## Copyright (c) Eduardo Julian. All rights reserved.
-## The use and distribution terms for this software are covered by the
-## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
-## which can be found in the file epl-v10.html at the root of this distribution.
-## By using this software in any fashion, you are agreeing to be bound by
-## the terms of this license.
-## You must not remove this notice, or any other, from this software.
-
-(;import lux)
-
-## [Signatures]
-(defsig #export (Eq a)
- (: (-> a a Bool)
- =))
diff --git a/source/lux/data/error.lux b/source/lux/data/error.lux
deleted file mode 100644
index cb5c309a6..000000000
--- a/source/lux/data/error.lux
+++ /dev/null
@@ -1,34 +0,0 @@
-## Copyright (c) Eduardo Julian. All rights reserved.
-## The use and distribution terms for this software are covered by the
-## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
-## which can be found in the file epl-v10.html at the root of this distribution.
-## By using this software in any fashion, you are agreeing to be bound by
-## the terms of this license.
-## You must not remove this notice, or any other, from this software.
-
-(;import lux
- (lux/control (functor #as F #refer #all)
- (monad #as M #refer #all)))
-
-## [Types]
-(deftype #export (Error a)
- (| (#Fail Text)
- (#Ok a)))
-
-## [Structures]
-(defstruct #export Error/Functor (Functor Error)
- (def (F;map f ma)
- (case ma
- (#Fail msg) (#Fail msg)
- (#Ok datum) (#Ok (f datum)))))
-
-(defstruct #export Error/Monad (Monad Error)
- (def M;_functor Error/Functor)
-
- (def (M;wrap a)
- (#Ok a))
-
- (def (M;join mma)
- (case mma
- (#Fail msg) (#Fail msg)
- (#Ok ma) ma)))
diff --git a/source/lux/data/id.lux b/source/lux/data/id.lux
index 0e3bdbee6..e4f2a775f 100644
--- a/source/lux/data/id.lux
+++ b/source/lux/data/id.lux
@@ -1,28 +1,27 @@
-## 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/.
(;import lux
(lux/control (functor #as F #refer #all)
- (monad #as M #refer #all)))
+ (monad #as M #refer #all)
+ (comonad #as CM #refer #all)))
## [Types]
(deftype #export (Id a)
- (| (#Id a)))
+ a)
## [Structures]
(defstruct #export Id/Functor (Functor Id)
- (def (F;map f fa)
- (let [(#Id a) fa]
- (#Id (f a)))))
+ (def map id))
(defstruct #export Id/Monad (Monad Id)
- (def M;_functor Id/Functor)
- (def (M;wrap a) (#Id a))
- (def (M;join mma)
- (let [(#Id ma) mma]
- ma)))
+ (def _functor Id/Functor)
+ (def wrap id)
+ (def join id))
+
+(defstruct #export Id/CoMonad (CoMonad Id)
+ (def _functor Id/Functor)
+ (def unwrap id)
+ (def split id))
diff --git a/source/lux/data/ident.lux b/source/lux/data/ident.lux
new file mode 100644
index 000000000..cb2353e43
--- /dev/null
+++ b/source/lux/data/ident.lux
@@ -0,0 +1,33 @@
+## Copyright (c) Eduardo Julian. All rights reserved.
+## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
+## If a copy of the MPL was not distributed with this file,
+## You can obtain one at http://mozilla.org/MPL/2.0/.
+
+(;import lux
+ (lux (control (eq #as E)
+ (show #as S))
+ (data (text #open ("text:" Text/Monoid Text/Eq)))))
+
+## [Types]
+## (deftype Ident
+## (, Text Text))
+
+## [Functions]
+(do-template [<name> <side>]
+ [(def #export (<name> [left right])
+ (-> Ident Text)
+ <side>)]
+
+ [module left]
+ [name right]
+ )
+
+## [Structures]
+(defstruct #export Ident/Eq (E;Eq Ident)
+ (def (= [xmodule xname] [ymodule yname])
+ (and (text:= xmodule ymodule)
+ (text:= xname yname))))
+
+(defstruct #export Ident/Show (S;Show Ident)
+ (def (show [module name])
+ ($ text:++ module ";" name)))
diff --git a/source/lux/data/io.lux b/source/lux/data/io.lux
deleted file mode 100644
index a194fc854..000000000
--- a/source/lux/data/io.lux
+++ /dev/null
@@ -1,52 +0,0 @@
-## Copyright (c) Eduardo Julian. All rights reserved.
-## The use and distribution terms for this software are covered by the
-## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
-## which can be found in the file epl-v10.html at the root of this distribution.
-## By using this software in any fashion, you are agreeing to be bound by
-## the terms of this license.
-## You must not remove this notice, or any other, from this software.
-
-(;import lux
- (lux/meta macro)
- (lux/control (functor #as F)
- (monad #as M))
- (.. list
- (text #as T #open ("text:" Text/Monoid))))
-
-## Types
-(deftype #export (IO a)
- (-> (,) a))
-
-## Syntax
-(defmacro #export (io tokens state)
- (case tokens
- (\ (list value))
- (let [blank (symbol$ ["" ""])]
- (#;Right [state (list (` (_lux_lambda (~ blank) (~ blank) (~ value))))]))
-
- _
- (#;Left "Wrong syntax for io")))
-
-## Structures
-(defstruct #export IO/Functor (F;Functor IO)
- (def (F;map f ma)
- (io (f (ma [])))))
-
-(defstruct #export IO/Monad (M;Monad IO)
- (def M;_functor IO/Functor)
-
- (def (M;wrap x)
- (io x))
-
- (def (M;join mma)
- (mma [])))
-
-## Functions
-(def #export (print x)
- (-> Text (IO (,)))
- (io (_jvm_invokevirtual "java.io.PrintStream" "print" ["java.lang.Object"]
- (_jvm_getstatic "java.lang.System" "out") [x])))
-
-(def #export (println x)
- (-> Text (IO (,)))
- (print (text:++ x "\n")))
diff --git a/source/lux/data/list.lux b/source/lux/data/list.lux
index 8fd5c2951..6bf050228 100644
--- a/source/lux/data/list.lux
+++ b/source/lux/data/list.lux
@@ -1,42 +1,51 @@
-## 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/.
(;import lux
- (lux/control (monoid #as m #refer #all)
- (functor #as F #refer #all)
- (monad #as M #refer #all))
- lux/meta/macro)
-
-## Types
+ (lux (control (monoid #as m #refer #all)
+ (functor #as F #refer #all)
+ (monad #as M #refer #all)
+ (eq #as E)
+ (ord #as O)
+ (fold #as f))
+ (data (number (int #open ("i:" Int/Number Int/Ord Int/Show)))
+ bool
+ (text #open ("text:" Text/Monoid))
+ tuple)
+ codata/function))
+
+## [Types]
## (deftype (List a)
## (| #Nil
## (#Cons (, a (List a)))))
-## Functions
-(def #export (foldL f init xs)
- (All [a b]
- (-> (-> a b a) a (List b) a))
- (case xs
- #;Nil
- init
+## [Functions]
+(defstruct #export List/Fold (f;Fold List)
+ (def (foldL f init xs)
+ (case xs
+ #;Nil
+ init
- (#;Cons [x xs'])
- (foldL f (f init x) xs')))
+ (#;Cons [x xs'])
+ (foldL f (f init x) xs')))
+
+ (def (foldR f init xs)
+ (case xs
+ #;Nil
+ init
-(def #export (foldR f init xs)
- (All [a b]
- (-> (-> b a a) a (List b) a))
- (case xs
- #;Nil
- init
+ (#;Cons [x xs'])
+ (f x (foldR f init xs')))))
- (#;Cons [x xs'])
- (f x (foldR f init xs'))))
+(open List/Fold)
+
+(def #export (fold mon xs)
+ (All [a]
+ (-> (m;Monoid a) (List a) a))
+ (using mon
+ (foldL ++ unit xs)))
(def #export (reverse xs)
(All [a]
@@ -59,7 +68,7 @@
(def #export (partition p xs)
(All [a] (-> (-> a Bool) (List a) (, (List a) (List a))))
- [(filter p xs) (filter (complement p) xs)])
+ [(filter p xs) (filter (comp p) xs)])
(def #export (as-pairs xs)
(All [a] (-> (List a) (List (, a a))))
@@ -74,7 +83,7 @@
[(def #export (<name> n xs)
(All [a]
(-> Int (List a) (List a)))
- (if (i> n 0)
+ (if (i:> n 0)
(case xs
#;Nil
#;Nil
@@ -83,8 +92,8 @@
<then>)
<else>))]
- [take (#;Cons [x (take (dec n) xs')]) #;Nil]
- [drop (drop (dec n) xs') xs]
+ [take (#;Cons [x (take (i:+ -1 n) xs')]) #;Nil]
+ [drop (drop (i:+ -1 n) xs') xs]
)
(do-template [<name> <then> <else>]
@@ -107,13 +116,13 @@
(def #export (split n xs)
(All [a]
(-> Int (List a) (, (List a) (List a))))
- (if (i> n 0)
+ (if (i:> n 0)
(case xs
#;Nil
[#;Nil #;Nil]
(#;Cons [x xs'])
- (let [[tail rest] (split (dec n) xs')]
+ (let [[tail rest] (split (i:+ -1 n) xs')]
[(#;Cons [x tail]) rest]))
[#;Nil xs]))
@@ -138,8 +147,8 @@
(def #export (repeat n x)
(All [a]
(-> Int a (List a)))
- (if (i> n 0)
- (#;Cons [x (repeat (dec n) x)])
+ (if (i:> n 0)
+ (#;Cons [x (repeat (i:+ -1 n) x)])
#;Nil))
(def #export (iterate f x)
@@ -181,8 +190,8 @@
(#;Cons [x (#;Cons [sep (interpose sep xs')])])))
(def #export (size list)
- (-> List Int)
- (foldL (lambda [acc _] (i+ 1 acc)) 0 list))
+ (All [a] (-> (List a) Int))
+ (foldL (lambda [acc _] (i:+ 1 acc)) 0 list))
(do-template [<name> <init> <op>]
[(def #export (<name> p xs)
@@ -201,50 +210,135 @@
#;None
(#;Cons [x xs'])
- (if (i= 0 i)
+ (if (i:= 0 i)
(#;Some x)
- (@ (dec i) xs'))))
+ (@ (i:+ -1 i) xs'))))
-## Syntax
-(defmacro #export (list xs state)
- (#;Right [state (#;Cons [(foldL (lambda [tail head]
- (` (#;Cons [(~ head) (~ tail)])))
- (` #;Nil)
- (reverse xs))
- #;Nil])]))
+## [Syntax]
+(defmacro #export (@list xs state)
+ (#;Right state (#;Cons (foldL (: (-> AST AST AST)
+ (lambda [tail head] (` (#;Cons (~ head) (~ tail)))))
+ (` #;Nil)
+ (reverse xs))
+ #;Nil)))
-(defmacro #export (list& xs state)
+(defmacro #export (@list& xs state)
(case (reverse xs)
- (#;Cons [last init])
- (#;Right [state (list (foldL (lambda [tail head]
- (` (#;Cons [(~ head) (~ tail)])))
+ (#;Cons last init)
+ (#;Right state (@list (foldL (: (-> AST AST AST)
+ (lambda [tail head] (` (#;Cons (~ head) (~ tail)))))
last
- init))])
+ init)))
_
- (#;Left "Wrong syntax for list&")))
+ (#;Left "Wrong syntax for @list&")))
+
+## [Structures]
+(defstruct #export (List/Eq eq)
+ (All [a] (-> (E;Eq a) (E;Eq (List a))))
+ (def (= xs ys)
+ (case [xs ys]
+ [#;Nil #;Nil]
+ true
+
+ [(#;Cons x xs') (#;Cons y ys')]
+ (and (:: eq (= x y))
+ (= xs' ys'))
+
+ [_ _]
+ false
+ )))
-## Structures
(defstruct #export List/Monoid (All [a]
(Monoid (List a)))
- (def m;unit #;Nil)
- (def (m;++ xs ys)
+ (def unit #;Nil)
+ (def (++ xs ys)
(case xs
- #;Nil ys
- (#;Cons [x xs']) (#;Cons [x (m;++ xs' ys)]))))
+ #;Nil ys
+ (#;Cons x xs') (#;Cons x (++ xs' ys)))))
(defstruct #export List/Functor (Functor List)
- (def (F;map f ma)
+ (def (map f ma)
(case ma
- #;Nil #;Nil
- (#;Cons [a ma']) (#;Cons [(f a) (F;map f ma')]))))
+ #;Nil #;Nil
+ (#;Cons a ma') (#;Cons (f a) (map f ma')))))
(defstruct #export List/Monad (Monad List)
- (def M;_functor List/Functor)
+ (def _functor List/Functor)
- (def (M;wrap a)
- (#;Cons [a #;Nil]))
+ (def (wrap a)
+ (#;Cons a #;Nil))
- (def (M;join mma)
+ (def (join mma)
(using List/Monoid
(foldL ++ unit mma))))
+
+## [Functions]
+(def #export (sort ord xs)
+ (All [a] (-> (O;Ord a) (List a) (List a)))
+ (case xs
+ #;Nil
+ #;Nil
+
+ (#;Cons x xs')
+ (using ord
+ (let [pre (filter (>= x) xs')
+ post (filter (< x) xs')
+ ++ (:: List/Monoid ++)]
+ ($ ++ (sort ord pre) (@list x) (sort ord post))))))
+
+## [Syntax]
+(def (symbol$ name)
+ (-> Text AST)
+ [["" -1 -1] (#;SymbolS "" name)])
+
+(def (range from to)
+ (-> Int Int (List Int))
+ (if (i:<= from to)
+ (@list& from (range (i:+ 1 from) to))
+ (@list)))
+
+(defmacro #export (zip tokens state)
+ (case tokens
+ (\ (@list [_ (#;IntS num-lists)]))
+ (if (i:> num-lists 0)
+ (using List/Functor
+ (let [indices (range 0 (i:- num-lists 1))
+ type-vars (: (List AST) (map (. symbol$ i:show) indices))
+ zip-type (` (All [(~@ type-vars)]
+ (-> (~@ (map (: (-> AST AST) (lambda [var] (` (List (~ var)))))
+ type-vars))
+ (List (, (~@ type-vars))))))
+ vars+lists (map (lambda [idx]
+ (let [base (text:++ "_" (i:show idx))]
+ [(symbol$ base)
+ (symbol$ (text:++ base "s"))]))
+ indices)
+ pattern (` [(~@ (map (lambda [[v vs]] (` (#;Cons (~ v) (~ vs))))
+ vars+lists))])
+ g!step (symbol$ "\tstep\t")
+ g!blank (symbol$ "\t_\t")
+ list-vars (map second vars+lists)
+ code (` (: (~ zip-type)
+ (lambda (~ g!step) [(~@ list-vars)]
+ (case [(~@ list-vars)]
+ (~ pattern)
+ (#;Cons [(~@ (map first vars+lists))]
+ ((~ g!step) (~@ list-vars)))
+
+ (~ g!blank)
+ #;Nil))))]
+ (#;Right [state (@list code)])))
+ (#;Left "Can't zip no lists."))
+
+ _
+ (#;Left "Wrong syntax for zip")))
+
+(def #export zip2 (zip 2))
+(def #export zip3 (zip 3))
+
+(def #export (empty? xs)
+ (All [a] (-> (List a) Bool))
+ (case xs
+ #;Nil true
+ _ false))
diff --git a/source/lux/data/maybe.lux b/source/lux/data/maybe.lux
index faec53c2e..1303270a7 100644
--- a/source/lux/data/maybe.lux
+++ b/source/lux/data/maybe.lux
@@ -1,15 +1,12 @@
-## 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/.
(;import lux
- (lux/control (monoid #as m #refer #all)
- (functor #as F #refer #all)
- (monad #as M #refer #all)))
+ (lux (control (monoid #as m #refer #all)
+ (functor #as F #refer #all)
+ (monad #as M #refer #all))))
## [Types]
## (deftype (Maybe a)
@@ -17,26 +14,33 @@
## (#;Some a)))
## [Structures]
-(defstruct #export Maybe/Monoid (Monoid Maybe)
- (def m;unit #;None)
- (def (m;++ xs ys)
+(defstruct #export Maybe/Monoid (All [a] (Monoid (Maybe a)))
+ (def unit #;None)
+ (def (++ xs ys)
(case xs
#;None ys
(#;Some x) (#;Some x))))
(defstruct #export Maybe/Functor (Functor Maybe)
- (def (F;map f ma)
+ (def (map f ma)
(case ma
#;None #;None
(#;Some a) (#;Some (f a)))))
(defstruct #export Maybe/Monad (Monad Maybe)
- (def M;_functor Maybe/Functor)
+ (def _functor Maybe/Functor)
- (def (M;wrap x)
+ (def (wrap x)
(#;Some x))
- (def (M;join mma)
+ (def (join mma)
(case mma
#;None #;None
(#;Some xs) xs)))
+
+## [Functions]
+(def #export (? else maybe)
+ (All [a] (-> a (Maybe a) a))
+ (case maybe
+ (#;Some x) x
+ _ else))
diff --git a/source/lux/data/number.lux b/source/lux/data/number.lux
deleted file mode 100644
index 8771ef06e..000000000
--- a/source/lux/data/number.lux
+++ /dev/null
@@ -1,113 +0,0 @@
-## Copyright (c) Eduardo Julian. All rights reserved.
-## The use and distribution terms for this software are covered by the
-## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
-## which can be found in the file epl-v10.html at the root of this distribution.
-## By using this software in any fashion, you are agreeing to be bound by
-## the terms of this license.
-## You must not remove this notice, or any other, from this software.
-
-(;import lux
- (lux/control (monoid #as m))
- (.. (eq #as E)
- (ord #as O)
- (bounded #as B)
- (show #as S)))
-
-## Signatures
-(defsig #export (Number n)
- (do-template [<name>]
- [(: (-> n n n) <name>)]
- [+] [-] [*] [/] [%])
-
- (: (-> Int n)
- from-int)
-
- (do-template [<name>]
- [(: (-> n n) <name>)]
- [negate] [signum] [abs])
- )
-
-## [Structures]
-## Number
-(do-template [<name> <type> <+> <-> <*> </> <%> <=> <<> <from> <0> <1> <-1>]
- [(defstruct #export <name> (Number <type>)
- (def + <+>)
- (def - <->)
- (def * <*>)
- (def / </>)
- (def % <%>)
- (def (from-int x)
- (<from> x))
- (def (negate x)
- (<*> <-1> x))
- (def (abs x)
- (if (<<> x <0>)
- (<*> <-1> x)
- x))
- (def (signum x)
- (cond (<=> x <0>) <0>
- (<<> x <0>) <-1>
- ## else
- <1>))
- )]
-
- [ Int/Number Int i+ i- i* i/ i% i= i< id 0 1 -1]
- [Real/Number Real r+ r- r* r/ r% r= r< _jvm_l2d 0.0 1.0 -1.0])
-
-## Eq
-(defstruct #export Int/Eq (E;Eq Int)
- (def E;= i=))
-
-(defstruct #export Real/Eq (E;Eq Real)
- (def E;= r=))
-
-## Ord
-(do-template [<name> <type> <eq> <lt> <gt>]
- [(defstruct #export <name> (O;Ord <type>)
- (def O;_eq <eq>)
- (def O;< <lt>)
- (def (O;<= x y)
- (or (<lt> x y)
- (:: <eq> (E;= x y))))
- (def O;> <gt>)
- (def (O;>= x y)
- (or (<gt> x y)
- (:: <eq> (E;= x y)))))]
-
- [ Int/Ord Int Int/Eq i< i>]
- [Real/Ord Real Real/Eq r< r>])
-
-## Bounded
-(do-template [<name> <type> <top> <bottom>]
- [(defstruct #export <name> (B;Bounded <type>)
- (def B;top <top>)
- (def B;bottom <bottom>))]
-
- [ Int/Bounded Int (_jvm_getstatic "java.lang.Long" "MAX_VALUE") (_jvm_getstatic "java.lang.Long" "MIN_VALUE")]
- [Real/Bounded Real (_jvm_getstatic "java.lang.Double" "MAX_VALUE") (_jvm_getstatic "java.lang.Double" "MIN_VALUE")])
-
-## Monoid
-(do-template [<name> <type> <unit> <++>]
- [(defstruct #export <name> (m;Monoid <type>)
- (def m;unit <unit>)
- (def m;++ <++>))]
-
- [ IntAdd/Monoid Int 0 i+]
- [ IntMul/Monoid Int 1 i*]
- [RealAdd/Monoid Real 0.0 r+]
- [RealMul/Monoid Real 1.0 r*]
- [ IntMax/Monoid Int (:: Int/Bounded B;bottom) (O;max Int/Ord)]
- [ IntMin/Monoid Int (:: Int/Bounded B;top) (O;min Int/Ord)]
- [RealMax/Monoid Real (:: Real/Bounded B;bottom) (O;max Real/Ord)]
- [RealMin/Monoid Real (:: Real/Bounded B;top) (O;min Real/Ord)]
- )
-
-## Show
-(do-template [<name> <type> <body>]
- [(defstruct #export <name> (S;Show <type>)
- (def (S;show x)
- <body>))]
-
- [ Int/Show Int (_jvm_invokevirtual "java.lang.Object" "toString" [] x [])]
- [Real/Show Real (_jvm_invokevirtual "java.lang.Object" "toString" [] x [])]
- )
diff --git a/source/lux/data/number/int.lux b/source/lux/data/number/int.lux
new file mode 100644
index 000000000..1e71b8a5a
--- /dev/null
+++ b/source/lux/data/number/int.lux
@@ -0,0 +1,93 @@
+## Copyright (c) Eduardo Julian. All rights reserved.
+## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
+## If a copy of the MPL was not distributed with this file,
+## You can obtain one at http://mozilla.org/MPL/2.0/.
+
+(;import lux
+ (lux/control (number #as N)
+ (monoid #as m)
+ (eq #as E)
+ (ord #as O)
+ (enum #as EN)
+ (bounded #as B)
+ (show #as S)))
+
+## [Structures]
+## Number
+(do-template [<name> <type> <+> <-> <*> </> <%> <=> <<> <from> <0> <1> <-1>]
+ [(defstruct #export <name> (N;Number <type>)
+ (def (+ x y) (<+> x y))
+ (def (- x y) (<-> x y))
+ (def (* x y) (<*> x y))
+ (def (/ x y) (</> x y))
+ (def (% x y) (<%> x y))
+ (def (from-int x)
+ (<from> x))
+ (def (negate x)
+ (<*> <-1> x))
+ (def (abs x)
+ (if (<<> x <0>)
+ (<*> <-1> x)
+ x))
+ (def (signum x)
+ (cond (<=> x <0>) <0>
+ (<<> x <0>) <-1>
+ ## else
+ <1>))
+ )]
+
+ [ Int/Number Int _jvm_ladd _jvm_lsub _jvm_lmul _jvm_ldiv _jvm_lrem _jvm_leq _jvm_llt id 0 1 -1])
+
+## Eq
+(defstruct #export Int/Eq (E;Eq Int)
+ (def (= x y) (_jvm_leq x y)))
+
+## Ord
+(do-template [<name> <type> <eq> <=> <lt> <gt>]
+ [(defstruct #export <name> (O;Ord <type>)
+ (def _eq <eq>)
+ (def (< x y) (<lt> x y))
+ (def (<= x y)
+ (or (<lt> x y)
+ (<=> x y)))
+ (def (> x y) (<gt> x y))
+ (def (>= x y)
+ (or (<gt> x y)
+ (<=> x y))))]
+
+ [ Int/Ord Int Int/Eq _jvm_leq _jvm_llt _jvm_lgt])
+
+## Enum
+(defstruct #export Int/Enum (EN;Enum Int)
+ (def _ord Int/Ord)
+ (def succ (lambda [n] (:: Int/Number (+ n 1))))
+ (def pred (lambda [n] (:: Int/Number (- n 1)))))
+
+## Bounded
+(do-template [<name> <type> <top> <bottom>]
+ [(defstruct #export <name> (B;Bounded <type>)
+ (def top <top>)
+ (def bottom <bottom>))]
+
+ [ Int/Bounded Int (_jvm_getstatic "java.lang.Long" "MAX_VALUE") (_jvm_getstatic "java.lang.Long" "MIN_VALUE")])
+
+## Monoid
+(do-template [<name> <type> <unit> <++>]
+ [(defstruct #export <name> (m;Monoid <type>)
+ (def unit <unit>)
+ (def (++ x y) (<++> x y)))]
+
+ [ IntAdd/Monoid Int 0 _jvm_ladd]
+ [ IntMul/Monoid Int 1 _jvm_lmul]
+ [ IntMax/Monoid Int (:: Int/Bounded bottom) (O;max Int/Ord)]
+ [ IntMin/Monoid Int (:: Int/Bounded top) (O;min Int/Ord)]
+ )
+
+## Show
+(do-template [<name> <type> <body>]
+ [(defstruct #export <name> (S;Show <type>)
+ (def (show x)
+ <body>))]
+
+ [ Int/Show Int (_jvm_invokevirtual "java.lang.Object" "toString" [] x [])]
+ )
diff --git a/source/lux/data/number/real.lux b/source/lux/data/number/real.lux
new file mode 100644
index 000000000..7d5243385
--- /dev/null
+++ b/source/lux/data/number/real.lux
@@ -0,0 +1,93 @@
+## Copyright (c) Eduardo Julian. All rights reserved.
+## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
+## If a copy of the MPL was not distributed with this file,
+## You can obtain one at http://mozilla.org/MPL/2.0/.
+
+(;import lux
+ (lux/control (number #as N)
+ (monoid #as m)
+ (eq #as E)
+ (ord #as O)
+ (enum #as EN)
+ (bounded #as B)
+ (show #as S)))
+
+## [Structures]
+## Number
+(do-template [<name> <type> <+> <-> <*> </> <%> <=> <<> <from> <0> <1> <-1>]
+ [(defstruct #export <name> (N;Number <type>)
+ (def (+ x y) (<+> x y))
+ (def (- x y) (<-> x y))
+ (def (* x y) (<*> x y))
+ (def (/ x y) (</> x y))
+ (def (% x y) (<%> x y))
+ (def (from-int x)
+ (<from> x))
+ (def (negate x)
+ (<*> <-1> x))
+ (def (abs x)
+ (if (<<> x <0>)
+ (<*> <-1> x)
+ x))
+ (def (signum x)
+ (cond (<=> x <0>) <0>
+ (<<> x <0>) <-1>
+ ## else
+ <1>))
+ )]
+
+ [Real/Number Real _jvm_dadd _jvm_dsub _jvm_dmul _jvm_ddiv _jvm_drem _jvm_deq _jvm_dlt _jvm_l2d 0.0 1.0 -1.0])
+
+## Eq
+(defstruct #export Real/Eq (E;Eq Real)
+ (def (= x y) (_jvm_deq x y)))
+
+## Ord
+(do-template [<name> <type> <eq> <=> <lt> <gt>]
+ [(defstruct #export <name> (O;Ord <type>)
+ (def _eq <eq>)
+ (def (< x y) (<lt> x y))
+ (def (<= x y)
+ (or (<lt> x y)
+ (<=> x y)))
+ (def (> x y) (<gt> x y))
+ (def (>= x y)
+ (or (<gt> x y)
+ (<=> x y))))]
+
+ [Real/Ord Real Real/Eq _jvm_deq _jvm_dlt _jvm_dgt])
+
+## Enum
+(defstruct Real/Enum (EN;Enum Real)
+ (def _ord Real/Ord)
+ (def succ (lambda [n] (:: Real/Number (+ n 1.0))))
+ (def pred (lambda [n] (:: Real/Number (- n 1.0)))))
+
+## Bounded
+(do-template [<name> <type> <top> <bottom>]
+ [(defstruct #export <name> (B;Bounded <type>)
+ (def top <top>)
+ (def bottom <bottom>))]
+
+ [Real/Bounded Real (_jvm_getstatic "java.lang.Double" "MAX_VALUE") (_jvm_getstatic "java.lang.Double" "MIN_VALUE")])
+
+## Monoid
+(do-template [<name> <type> <unit> <++>]
+ [(defstruct #export <name> (m;Monoid <type>)
+ (def unit <unit>)
+ (def (++ x y) (<++> x y)))]
+
+ [RealAdd/Monoid Real 0.0 _jvm_dadd]
+ [RealMul/Monoid Real 1.0 _jvm_dmul]
+ [RealMax/Monoid Real (:: Real/Bounded bottom) (O;max Real/Ord)]
+ [RealMin/Monoid Real (:: Real/Bounded top) (O;min Real/Ord)]
+ )
+
+## Show
+(do-template [<name> <type> <body>]
+ [(defstruct #export <name> (S;Show <type>)
+ (def (show x)
+ <body>))]
+
+ [Real/Show Real (_jvm_invokevirtual "java.lang.Object" "toString" [] x [])]
+ )
diff --git a/source/lux/data/reader.lux b/source/lux/data/reader.lux
deleted file mode 100644
index e91687c3a..000000000
--- a/source/lux/data/reader.lux
+++ /dev/null
@@ -1,33 +0,0 @@
-## Copyright (c) Eduardo Julian. All rights reserved.
-## The use and distribution terms for this software are covered by the
-## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
-## which can be found in the file epl-v10.html at the root of this distribution.
-## By using this software in any fashion, you are agreeing to be bound by
-## the terms of this license.
-## You must not remove this notice, or any other, from this software.
-
-(;import (lux #refer (#exclude Reader))
- (lux/control (functor #as F #refer #all)
- (monad #as M #refer #all)))
-
-## [Types]
-(deftype #export (Reader r a)
- (-> r a))
-
-## [Structures]
-(defstruct #export Reader/Functor (All [r]
- (Functor (Reader r)))
- (def (F;map f fa)
- (lambda [env]
- (f (fa env)))))
-
-(defstruct #export Reader/Monad (All [r]
- (Monad (Reader r)))
- (def M;_functor Reader/Functor)
-
- (def (M;wrap x)
- (lambda [env] x))
-
- (def (M;join mma)
- (lambda [env]
- (mma env env))))
diff --git a/source/lux/data/show.lux b/source/lux/data/show.lux
deleted file mode 100644
index f4e1cf762..000000000
--- a/source/lux/data/show.lux
+++ /dev/null
@@ -1,14 +0,0 @@
-## Copyright (c) Eduardo Julian. All rights reserved.
-## The use and distribution terms for this software are covered by the
-## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
-## which can be found in the file epl-v10.html at the root of this distribution.
-## By using this software in any fashion, you are agreeing to be bound by
-## the terms of this license.
-## You must not remove this notice, or any other, from this software.
-
-(;import lux)
-
-## Signatures
-(defsig #export (Show a)
- (: (-> a Text)
- show))
diff --git a/source/lux/data/state.lux b/source/lux/data/state.lux
deleted file mode 100644
index bc9858a29..000000000
--- a/source/lux/data/state.lux
+++ /dev/null
@@ -1,35 +0,0 @@
-## Copyright (c) Eduardo Julian. All rights reserved.
-## The use and distribution terms for this software are covered by the
-## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
-## which can be found in the file epl-v10.html at the root of this distribution.
-## By using this software in any fashion, you are agreeing to be bound by
-## the terms of this license.
-## You must not remove this notice, or any other, from this software.
-
-(;import lux
- (lux/control (functor #as F #refer #all)
- (monad #as M #refer #all)))
-
-## [Types]
-(deftype #export (State s a)
- (-> s (, s a)))
-
-## [Structures]
-(defstruct #export State/Functor (Functor State)
- (def (F;map f ma)
- (lambda [state]
- (let [[state' a] (ma state)]
- [state' (f a)]))))
-
-(defstruct #export State/Monad (All [s]
- (Monad (State s)))
- (def M;_functor State/Functor)
-
- (def (M;wrap x)
- (lambda [state]
- [state x]))
-
- (def (M;join mma)
- (lambda [state]
- (let [[state' ma] (mma state)]
- (ma state')))))
diff --git a/source/lux/data/text.lux b/source/lux/data/text.lux
index 6ad9cfd63..af2de51ff 100644
--- a/source/lux/data/text.lux
+++ b/source/lux/data/text.lux
@@ -1,16 +1,16 @@
-## 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/.
(;import lux
- (lux/control (monoid #as m))
- (lux/data (eq #as E)
- (ord #as O)
- (show #as S)))
+ (lux (control (monoid #as m)
+ (eq #as E)
+ (ord #as O)
+ (show #as S)
+ (monad #as M #refer #all))
+ (data (number (int #open ("i" Int/Number Int/Ord)))
+ maybe)))
## [Functions]
(def #export (size x)
@@ -112,12 +112,12 @@
## [Structures]
(defstruct #export Text/Eq (E;Eq Text)
- (def (E;= x y)
+ (def (= x y)
(_jvm_invokevirtual "java.lang.Object" "equals" ["java.lang.Object"]
x [y])))
(defstruct #export Text/Ord (O;Ord Text)
- (def O;_eq Text/Eq)
+ (def _eq Text/Eq)
(do-template [<name> <op>]
[(def (<name> x y)
@@ -125,17 +125,71 @@
x [y]))
0))]
- [O;< i<]
- [O;<= i<=]
- [O;> i>]
- [O;>= i>=]))
+ [< i<]
+ [<= i<=]
+ [> i>]
+ [>= i>=]))
(defstruct #export Text/Show (S;Show Text)
- (def (S;show x)
- x))
+ (def show id))
(defstruct #export Text/Monoid (m;Monoid Text)
- (def m;unit "")
- (def (m;++ x y)
+ (def unit "")
+ (def (++ x y)
(_jvm_invokevirtual "java.lang.String" "concat" ["java.lang.String"]
x [y])))
+
+## [Syntax]
+(def (extract-var template)
+ (-> Text (Maybe (, Text Text Text)))
+ (do Maybe/Monad
+ [pre-idx (index-of "#{" template)
+ [pre in] (split pre-idx template)
+ [_ in] (split 2 in)
+ post-idx (index-of "}" in)
+ [var post] (split post-idx in)
+ #let [[_ post] (? ["" ""] (split 1 post))]]
+ (wrap [pre var post])))
+
+(do-template [<name> <type> <tag>]
+ [(def (<name> value)
+ (-> <type> AST)
+ [["" -1 -1] (<tag> value)])]
+
+ [text$ Text #;TextS]
+ [symbol$ Ident #;SymbolS])
+
+(def (unravel-template template)
+ (-> Text (List AST))
+ (case (extract-var template)
+ (#;Some [pre var post])
+ (#;Cons (text$ pre)
+ (#;Cons (symbol$ ["" var])
+ (unravel-template post)))
+
+ #;None
+ (#;Cons (text$ template) #;Nil)))
+
+(defmacro #export (<> tokens state)
+ (case tokens
+ (#;Cons [_ (#;TextS template)] #;Nil)
+ (let [++ (symbol$ ["" ""])]
+ (#;Right state (#;Cons (` (;let [(~ ++) (get@ #m;++ Text/Monoid)]
+ (;$ (~ ++) (~@ (unravel-template template)))))
+ #;Nil)))
+
+ _
+ (#;Left "Wrong syntax for <>")))
+
+(def #export (split-lines text)
+ (-> Text (List Text))
+ (case (: (Maybe (List Text))
+ (do Maybe/Monad
+ [idx (index-of "\n" text)
+ [head post] (split (inc idx) text)]
+ (wrap (#;Cons head (split-lines post)))))
+ #;None
+ (#;Cons text #;Nil)
+
+ (#;Some xs)
+ xs))
diff --git a/source/lux/data/tuple.lux b/source/lux/data/tuple.lux
new file mode 100644
index 000000000..6eef74670
--- /dev/null
+++ b/source/lux/data/tuple.lux
@@ -0,0 +1,35 @@
+## Copyright (c) Eduardo Julian. All rights reserved.
+## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
+## If a copy of the MPL was not distributed with this file,
+## You can obtain one at http://mozilla.org/MPL/2.0/.
+
+(;import lux)
+
+## [Functions]
+(do-template [<name> <type> <output>]
+ [(def #export (<name> xy)
+ (All [a b] (-> (, a b) <type>))
+ (let [[x y] xy]
+ <output>))]
+
+ [first a x]
+ [second b y])
+
+(def #export (curry f)
+ (All [a b c]
+ (-> (-> (, a b) c)
+ (-> a b c)))
+ (lambda [x y]
+ (f [x y])))
+
+(def #export (uncurry f)
+ (All [a b c]
+ (-> (-> a b c) (-> (, a b) c)))
+ (lambda [xy]
+ (let [[x y] xy]
+ (f x y))))
+
+(def #export (swap xy)
+ (All [a b] (-> (, a b) (, b a)))
+ (let [[x y] xy]
+ [y x]))
diff --git a/source/lux/data/writer.lux b/source/lux/data/writer.lux
index f71492e35..3bf99c1ad 100644
--- a/source/lux/data/writer.lux
+++ b/source/lux/data/writer.lux
@@ -1,10 +1,7 @@
-## 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/.
(;import lux
(lux/control (monoid #as m #refer #all)
@@ -18,17 +15,17 @@
## [Structures]
(defstruct #export Writer/Functor (All [l]
(Functor (Writer l)))
- (def (F;map f fa)
+ (def (map f fa)
(let [[log datum] fa]
[log (f datum)])))
(defstruct #export (Writer/Monad mon) (All [l]
(-> (Monoid l) (Monad (Writer l))))
- (def M;_functor Writer/Functor)
+ (def _functor Writer/Functor)
- (def (M;wrap x)
- [(:: mon m;unit) x])
+ (def (wrap x)
+ [(:: mon unit) x])
- (def (M;join mma)
+ (def (join mma)
(let [[log1 [log2 a]] mma]
- [(:: mon (m;++ log1 log2)) a])))
+ [(:: mon (++ log1 log2)) a])))
diff --git a/source/lux/host/io.lux b/source/lux/host/io.lux
new file mode 100644
index 000000000..220f089a2
--- /dev/null
+++ b/source/lux/host/io.lux
@@ -0,0 +1,60 @@
+## Copyright (c) Eduardo Julian. All rights reserved.
+## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
+## If a copy of the MPL was not distributed with this file,
+## You can obtain one at http://mozilla.org/MPL/2.0/.
+
+(;import lux
+ (lux (data (list #refer #all #open ("" List/Fold)))
+ (codata io)
+ (meta ast
+ syntax
+ lux)
+ control/monad)
+ (.. jvm))
+
+## [Functions]
+(do-template [<name> <method> <type> <class>]
+ [(def #export (<name> x)
+ (-> <type> (IO (,)))
+ (@io (_jvm_invokevirtual "java.io.PrintStream" <method> [<class>]
+ (_jvm_getstatic "java.lang.System" "out") [x])))]
+
+ [write-char "print" Char "char"]
+ [write "print" Text "java.lang.String"]
+ [write-line "println" Text "java.lang.String"]
+ )
+
+(do-template [<name> <type> <op>]
+ [(def #export <name>
+ (IO (Maybe <type>))
+ (let [in (_jvm_getstatic "java.lang.System" "in")
+ reader (_jvm_new "java.io.InputStreamReader" ["java.io.InputStream"] [in])
+ buff-reader (_jvm_new "java.io.BufferedReader" ["java.io.Reader"] [reader])]
+ (@io (let [output (: (Either Text <type>) (try <op>))
+ _close (: (Either Text (,)) (try (_jvm_invokeinterface "java.io.Closeable" "close" [] buff-reader [])))]
+ (case [output _close]
+ (\or [(#;Left _) _] [_ (#;Left _)]) #;None
+ [(#;Right input) (#;Right _)] (#;Some input))))))]
+
+ [read-char Char (_jvm_i2c (_jvm_invokevirtual "java.io.BufferedReader" "read" [] buff-reader []))]
+ [read-line Text (_jvm_invokevirtual "java.io.BufferedReader" "readLine" [] buff-reader [])]
+ )
+
+## [Syntax]
+(def simple-bindings^
+ (Parser (List (, Text AST)))
+ (tuple^ (*^ (&^ local-symbol^ id^))))
+
+(defsyntax #export (with-open [bindings simple-bindings^] body)
+ (do Lux/Monad
+ [g!output (gensym "output")
+ #let [code (foldL (: (-> AST (, Text AST) AST)
+ (lambda [body [res-name res-value]]
+ (let [g!res-name (symbol$ ["" res-name])]
+ (` (let [(~ g!res-name) (~ res-value)
+ (~ g!output) (~ body)]
+ (exec (;_jvm_invokeinterface "java.io.Closeable" "close" [] (~ g!res-name) [])
+ (~ g!output)))))))
+ body
+ (reverse bindings))]]
+ (wrap (@list code))))
diff --git a/source/lux/host/jvm.lux b/source/lux/host/jvm.lux
index 7af043969..737c1731d 100644
--- a/source/lux/host/jvm.lux
+++ b/source/lux/host/jvm.lux
@@ -1,238 +1,377 @@
-## 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/.
(;import lux
(lux (control (monoid #as m)
(functor #as F)
- (monad #as M #refer (#only do)))
- (data (list #as l #refer #all #open ("" List/Functor))
- (text #as text))
+ (monad #as M #refer (#only do seq%))
+ (enum #as E))
+ (data (list #refer #all #open ("" List/Functor List/Fold))
+ (number/int #refer #all #open ("i:" Int/Ord Int/Number))
+ maybe
+ tuple
+ (text #open ("text:" Text/Monoid)))
(meta lux
- macro
+ ast
syntax)))
+(open List/Monad "list:")
+
+## [Types]
+(defsyntax #export (Array [dimensions (?^ nat^)] type)
+ (emit (@list (foldL (lambda [inner _] (` (#;DataT "#Array" (@list (~ inner)))))
+ type
+ (repeat (? 1 dimensions) [])))))
+
## [Utils]
+## Types
+(deftype StackFrame (^ java.lang.StackTraceElement))
+(deftype StackTrace (Array StackFrame))
+
+(deftype Modifier Text)
+(deftype JvmType Text)
+
+(deftype AnnotationParam
+ (, Text AST))
+
+(deftype Annotation
+ (& #ann-name Text
+ #ann-params (List AnnotationParam)))
+
+(deftype MemberDecl
+ (& #member-name Text
+ #member-modifiers (List Modifier)
+ #member-anns (List Annotation)))
+
+(deftype FieldDecl
+ JvmType)
+
+(deftype MethodDecl
+ (& #method-inputs (List JvmType)
+ #method-output JvmType
+ #method-exs (List JvmType)))
+
+(deftype ArgDecl
+ (& #arg-name Text
+ #arg-type JvmType))
+
+(deftype MethodDef
+ (& #method-vars (List ArgDecl)
+ #return-type JvmType
+ #return-body AST
+ #throws-exs (List JvmType)))
+
+(deftype ExpectedInput
+ (& #opt-input? Bool
+ #input-type JvmType))
+
+(deftype ExpectedOutput
+ (& #ex-output? Bool
+ #opt-output? Bool
+ #output-type JvmType))
+
+## Functions
+(def (prepare-args args)
+ (-> (List ExpectedInput) (Lux (, (List AST) (List AST) (List AST) (List Text))))
+ (do Lux/Monad
+ [vars (seq% Lux/Monad (repeat (size args) (gensym "")))
+ #let [pairings (map (: (-> (, (, Bool Text) AST) (, AST (List AST)))
+ (lambda [[[opt? arg-class] var]]
+ (if opt?
+ [(` (Maybe (^ (~ (symbol$ ["" arg-class])))))
+ (@list var (` (: (^ (~ (symbol$ ["" arg-class])))
+ (case (~ var)
+ (#;Some (~ var)) (~ var)
+ #;None ;_jvm_null))))]
+ [(` (^ (~ (symbol$ ["" arg-class]))))
+ (@list)])))
+ (zip2 args vars))
+ var-types (map first pairings)
+ var-rebinds (map second pairings)
+ arg-classes (map second args)]]
+ (wrap [vars var-types (list:join var-rebinds) arg-classes])))
+
+(def (class->type class)
+ (-> JvmType AST)
+ (case class
+ "boolean" (' (;^ java.lang.Boolean))
+ "byte" (' (;^ java.lang.Byte))
+ "short" (' (;^ java.lang.Short))
+ "int" (' (;^ java.lang.Integer))
+ "long" (' (;^ java.lang.Long))
+ "float" (' (;^ java.lang.Float))
+ "double" (' (;^ java.lang.Double))
+ "char" (' (;^ java.lang.Character))
+ "void" (` ;Unit)
+ _
+ (` (^ (~ (symbol$ ["" class]))))))
+
## Parsers
-(def finally^
- (Parser Syntax)
- (form^ (do Parser/Monad
- [_ (symbol?^ ["" "finally"])
- expr id^]
- (M;wrap expr))))
-
-(def catch^
- (Parser (, Text Ident Syntax))
- (form^ (do Parser/Monad
- [_ (symbol?^ ["" "catch"])
- ex-class local-symbol^
- ex symbol^
- expr id^]
- (M;wrap [ex-class ex expr]))))
+(def annotation-params^
+ (Parser (List AnnotationParam))
+ (record^ (*^ (tuple^ (&^ local-tag^ id^)))))
+
+(def annotation^
+ (Parser Annotation)
+ (form^ (&^ local-symbol^
+ annotation-params^)))
+
+(def annotations^'
+ (Parser (List Annotation))
+ (do Parser/Monad
+ [_ (tag!^ ["" "ann"])]
+ (tuple^ (*^ annotation^))))
+
+(def annotations^
+ (Parser (List Annotation))
+ (do Parser/Monad
+ [anns?? (?^ annotations^')]
+ (wrap (? (@list) anns??))))
+
+(def member-decl^
+ (Parser MemberDecl)
+ (do Parser/Monad
+ [modifiers (*^ local-tag^)
+ name local-symbol^
+ anns annotations^]
+ (wrap [name modifiers anns])))
+
+(def throws-decl'^
+ (Parser (List JvmType))
+ (do Parser/Monad
+ [_ (tag!^ ["" "throws"])]
+ (tuple^ (*^ local-symbol^))))
+
+(def throws-decl^
+ (Parser (List JvmType))
+ (do Parser/Monad
+ [exs? (?^ throws-decl'^)]
+ (wrap (? (@list) exs?))))
+
+(def method-decl'^
+ (Parser MethodDecl)
+ (do Parser/Monad
+ [inputs (tuple^ (*^ local-symbol^))
+ outputs local-symbol^
+ exs throws-decl^]
+ (wrap [inputs outputs exs])))
(def method-decl^
- (Parser (, (List Text) Text (List Text) Text))
- (form^ (do Parser/Monad
- [modifiers (*^ local-tag^)
- name local-symbol^
- inputs (tuple^ (*^ local-symbol^))
- output local-symbol^]
- (M;wrap [modifiers name inputs output]))))
+ (Parser (, MemberDecl MethodDecl))
+ (form^ (&^ member-decl^
+ method-decl'^)))
(def field-decl^
- (Parser (, (List Text) Text Text))
- (form^ (do Parser/Monad
- [modifiers (*^ local-tag^)
- name local-symbol^
- class local-symbol^]
- (M;wrap [modifiers name class]))))
+ (Parser (, MemberDecl FieldDecl))
+ (form^ (&^ member-decl^
+ local-symbol^)))
(def arg-decl^
- (Parser (, Text Text))
- (form^ (do Parser/Monad
- [arg-name local-symbol^
- arg-class local-symbol^]
- (M;wrap [arg-name arg-class]))))
+ (Parser ArgDecl)
+ (form^ (&^ local-symbol^ local-symbol^)))
+
+(def method-def'^
+ (Parser MethodDef)
+ (do Parser/Monad
+ [inputs (tuple^ (*^ arg-decl^))
+ output local-symbol^
+ exs throws-decl^
+ body id^]
+ (wrap [inputs output body exs])))
(def method-def^
- (Parser (, (List Text) Text (List (, Text Text)) Text Syntax))
- (form^ (do Parser/Monad
- [modifiers (*^ local-tag^)
- name local-symbol^
- inputs (tuple^ (*^ arg-decl^))
- output local-symbol^
- body id^]
- (M;wrap [modifiers name inputs output body]))))
-
-(def method-call^
- (Parser (, Text (List Text) (List Syntax)))
- (form^ (do Parser/Monad
- [method local-symbol^
- arity-classes (tuple^ (*^ local-symbol^))
- arity-args (tuple^ (*^ id^))
- _ (: (Parser (,))
- (if (i= (size arity-classes)
- (size arity-args))
- (M;wrap [])
- (lambda [_] #;None)))]
- (M;wrap [method arity-classes arity-args])
- )))
+ (Parser (, MemberDecl MethodDef))
+ (form^ (&^ member-decl^
+ method-def'^)))
-## [Syntax]
-(defsyntax #export (throw ex)
- (emit (list (` (_jvm_throw (~ ex))))))
-
-(defsyntax #export (try body [catches (*^ catch^)] [finally (?^ finally^)])
- (emit (list (` (_jvm_try (~ body)
- (~@ (:: List/Monoid (m;++ (map (: (-> (, Text Ident Syntax) Syntax)
- (lambda [catch]
- (let [[class ex body] catch]
- (` (_jvm_catch (~ (text$ class)) (~ (symbol$ ex)) (~ body))))))
- catches)
- (case finally
- #;None
- (list)
-
- (#;Some finally)
- (list (` (_jvm_finally (~ finally)))))))))))))
-
-(defsyntax #export (definterface [name local-symbol^] [supers (tuple^ (*^ local-symbol^))] [members (*^ method-decl^)])
- (let [members' (map (: (-> (, (List Text) Text (List Text) Text) Syntax)
- (lambda [member]
- (let [[modifiers name inputs output] member]
- (` ((~ (text$ name)) [(~@ (map text$ inputs))] (~ (text$ output)) [(~@ (map text$ modifiers))])))))
- members)]
- (emit (list (` (_jvm_interface (~ (text$ name)) [(~@ (map text$ supers))]
- (~@ members')))))))
+(def exp-input^
+ (Parser ExpectedInput)
+ (&^ (tag?^ ["" "?"])
+ local-symbol^))
+
+(def exp-output^
+ (Parser ExpectedOutput)
+ (do Parser/Monad
+ [ex? (tag?^ ["" "!"])
+ opt? (tag?^ ["" "?"])
+ return local-symbol^]
+ (wrap [ex? opt? return])))
+
+## Generators
+(def (gen-annotation-param [name value])
+ (-> AnnotationParam (, AST AST))
+ [(text$ name) value])
+
+(def (gen-annotation [name params])
+ (-> Annotation AST)
+ (` ((~ (text$ name))
+ (~ (record$ (map gen-annotation-param params))))))
+
+(def (gen-method-decl [[name modifiers anns] [inputs output exs]])
+ (-> (, MemberDecl MethodDecl) AST)
+ (` ((~ (text$ name))
+ [(~@ (map text$ modifiers))]
+ [(~@ (map gen-annotation anns))]
+ [(~@ (map text$ exs))]
+ [(~@ (map text$ inputs))]
+ (~ (text$ output)))))
+
+(def (gen-field-decl [[name modifiers anns] class])
+ (-> (, MemberDecl FieldDecl) AST)
+ (` ((~ (text$ name))
+ [(~@ (map text$ modifiers))]
+ [(~@ (map gen-annotation anns))]
+ (~ (text$ class))
+ )))
+
+(def (gen-arg-decl [name type])
+ (-> ArgDecl AST)
+ (form$ (@list (symbol$ ["" name]) (text$ type))))
+(def (gen-method-def [[name modifiers anns] [inputs output body exs]])
+ (-> (, MemberDecl MethodDef) AST)
+ (` ((~ (text$ name))
+ [(~@ (map text$ modifiers))]
+ [(~@ (map gen-annotation anns))]
+ [(~@ (map text$ exs))]
+ [(~@ (map gen-arg-decl inputs))]
+ (~ (text$ output))
+ (~ body))))
+
+(def (gen-expected-output [ex? opt? output] body)
+ (-> ExpectedOutput AST (, AST AST))
+ (let [type (class->type output)
+ [body type] (if opt?
+ [(` (;;??? (~ body)))
+ (` (Maybe (~ type)))]
+ [body type])
+ [body type] (if ex?
+ [(` (;;try (~ body)))
+ (` (Either Text (~ type)))]
+ [body type])]
+ [body type]))
+
+## [Functions]
+(def (stack-trace->text trace)
+ (-> StackTrace Text)
+ (let [size (_jvm_arraylength trace)
+ idxs (E;range Int/Enum 0 (i:+ -1 size))]
+ (|> idxs
+ (map (: (-> Int Text)
+ (lambda [idx]
+ (_jvm_invokevirtual "java.lang.Object" "toString" [] (_jvm_aaload trace idx) []))))
+ (interpose "\n")
+ (foldL text:++ "")
+ )))
+
+(def (get-stack-trace t)
+ (-> (^ java.lang.Throwable) StackTrace)
+ (_jvm_invokevirtual "java.lang.Throwable" "getStackTrace" [] t []))
+
+(def #export (throwable->text t)
+ (-> (^ java.lang.Throwable) Text)
+ ($ text:++
+ (_jvm_invokevirtual "java.lang.Object" "toString" [] t [])
+ "\n"
+ (|> t get-stack-trace stack-trace->text)))
+
+## [Syntax]
(defsyntax #export (defclass [name local-symbol^] [super local-symbol^] [interfaces (tuple^ (*^ local-symbol^))]
+ [annotations annotations^]
[fields (*^ field-decl^)]
[methods (*^ method-def^)])
+ (emit (@list (` (;_jvm_class (~ (text$ name)) (~ (text$ super))
+ [(~@ (map text$ interfaces))]
+ [(~@ (map gen-annotation annotations))]
+ [(~@ (map gen-field-decl fields))]
+ [(~@ (map gen-method-def methods))])))))
+
+(defsyntax #export (definterface [name local-symbol^] [supers (tuple^ (*^ local-symbol^))]
+ [annotations annotations^]
+ [members (*^ method-decl^)])
+ (emit (@list (` (;_jvm_interface (~ (text$ name)) [(~@ (map text$ supers))]
+ [(~@ (map gen-annotation annotations))]
+ (~@ (map gen-method-decl members)))))))
+
+(defsyntax #export (object [super local-symbol^] [interfaces (tuple^ (*^ local-symbol^))]
+ [methods (*^ method-def^)])
+ (emit (@list (` (;_jvm_anon-class (~ (text$ super))
+ [(~@ (map text$ interfaces))]
+ [(~@ (map gen-method-def methods))])))))
+
+(defsyntax #export (program [args symbol^] body)
+ (emit (@list (` (;_jvm_program (~ (symbol$ args))
+ (~ body))))))
+
+(defsyntax #export (??? expr)
(do Lux/Monad
- [current-module get-module-name
- #let [fields' (map (: (-> (, (List Text) Text Text) Syntax)
- (lambda [field]
- (let [[modifiers name class] field]
- (` ((~ (text$ name))
- (~ (text$ class))
- [(~@ (map text$ modifiers))])))))
- fields)
- methods' (map (: (-> (, (List Text) Text (List (, Text Text)) Text Syntax) Syntax)
- (lambda [methods]
- (let [[modifiers name inputs output body] methods]
- (` ((~ (text$ name))
- [(~@ (map (: (-> (, Text Text) Syntax)
- (lambda [in]
- (let [[left right] in]
- (form$ (list (symbol$ ["" left])
- (text$ right))))))
- inputs))]
- (~ (text$ output))
- [(~@ (map text$ modifiers))]
- (~ body))))))
- methods)]]
- (emit (list (` (_jvm_class (~ (text$ name)) (~ (text$ super))
- [(~@ (map text$ interfaces))]
- [(~@ fields')]
- [(~@ methods')]))))))
-
-(defsyntax #export (new [class local-symbol^] [arg-classes (tuple^ (*^ local-symbol^))] [args (tuple^ (*^ id^))])
- (emit (list (` (_jvm_new (~ (text$ class))
- [(~@ (map text$ arg-classes))]
- [(~@ args)])))))
+ [g!temp (gensym "")]
+ (wrap (@list (` (let [(~ g!temp) (~ expr)]
+ (if (;_jvm_null? (~ g!temp))
+ #;None
+ (#;Some (~ g!temp)))))))))
+
+(defsyntax #export (try expr)
+ (emit (@list (` (;_jvm_try (#;Right (~ expr))
+ (~ (' (_jvm_catch "java.lang.Exception" e
+ (#;Left (throwable->text e))))))))))
(defsyntax #export (instance? [class local-symbol^] obj)
- (emit (list (` (_jvm_instanceof (~ (text$ class)) (~ obj))))))
+ (emit (@list (` (;_jvm_instanceof (~ (text$ class)) (~ obj))))))
(defsyntax #export (locking lock body)
(do Lux/Monad
[g!lock (gensym "")
- g!body (gensym "")]
- (emit (list (` (;let [(~ g!lock) (~ lock)
- _ (_jvm_monitorenter (~ g!lock))
+ g!body (gensym "")
+ g!_ (gensym "")]
+ (emit (@list (` (let [(~ g!lock) (~ lock)
+ (~ g!_) (;_jvm_monitorenter (~ g!lock))
(~ g!body) (~ body)
- _ (_jvm_monitorexit (~ g!lock))]
- (~ g!body)))))
+ (~ g!_) (;_jvm_monitorexit (~ g!lock))]
+ (~ g!body)))))
))
(defsyntax #export (null? obj)
- (emit (list (` (_jvm_null? (~ obj))))))
+ (emit (@list (` (;_jvm_null? (~ obj))))))
-(defsyntax #export (program [args symbol^] body)
- (emit (list (` (_jvm_program (~ (symbol$ args))
- (~ body))))))
-
-(defsyntax #export (.? [field local-symbol^] obj)
- (case obj
- (#;Meta [_ (#;SymbolS obj-name)])
- (do Lux/Monad
- [obj-type (find-var-type obj-name)]
- (case obj-type
- (#;DataT class)
- (emit (list (` (_jvm_getfield (~ (text$ class)) (~ (text$ field))))))
-
- _
- (fail "Can only get field from object.")))
+(defsyntax #export (new$ [class local-symbol^] [args (tuple^ (*^ exp-input^))] [unsafe? (tag?^ ["" "unsafe"])])
+ (do Lux/Monad
+ [[vars var-types var-rebinds arg-classes] (prepare-args args)
+ #let [new-expr (` (;_jvm_new (~ (text$ class)) [(~@ (map text$ arg-classes))] [(~@ vars)]))
+ return-type (class->type class)
+ [new-expr return-type] (if unsafe?
+ [(` (try (~ new-expr))) (` (Either Text (~ return-type)))]
+ [new-expr return-type])]]
+ (wrap (@list (` (: (-> (, (~@ var-types)) (~ return-type))
+ (lambda [[(~@ vars)]]
+ (let [(~@ var-rebinds)]
+ (~ new-expr)))))))))
- _
- (do Lux/Monad
- [g!obj (gensym "")]
- (emit (list (` (;let [(~ g!obj) (~ obj)]
- (.? (~ (text$ field)) (~ g!obj)))))))))
-
-(defsyntax #export (.= [field local-symbol^] value obj)
- (case obj
- (#;Meta [_ (#;SymbolS obj-name)])
- (do Lux/Monad
- [obj-type (find-var-type obj-name)]
- (case obj-type
- (#;DataT class)
- (emit (list (` (_jvm_putfield (~ (text$ class)) (~ (text$ field)) (~ value)))))
-
- _
- (fail "Can only set field of object.")))
+(do-template [<name> <op> <use-self?>]
+ [(defsyntax #export (<name> [class local-symbol^] [method local-symbol^] [args (tuple^ (*^ exp-input^))]
+ [expected-output exp-output^] [unsafe? (tag?^ ["" "unsafe"])])
+ (do Lux/Monad
+ [[vars var-types var-rebinds arg-classes] (prepare-args args)
+ g!self (gensym "self")
+ #let [included-self (: (List AST)
+ (if <use-self?>
+ (@list g!self)
+ (@list)))
+ [body return-type] (gen-expected-output expected-output
+ (` (<op> (~ (text$ class)) (~ (text$ method)) [(~@ (map text$ arg-classes))] (~@ included-self) [(~@ vars)])))
+ [body return-type] (if unsafe?
+ [(` (try (~ body))) (` (Either Text (~ return-type)))]
+ [body return-type])]]
+ (wrap (@list (` (: (-> (, (~@ var-types)) (^ (~ (symbol$ ["" class]))) (~ return-type))
+ (lambda [[(~@ vars)] (~@ included-self)]
+ (let [(~@ var-rebinds)]
+ (~ body)))))))
+ ))]
- _
- (do Lux/Monad
- [g!obj (gensym "")]
- (emit (list (` (;let [(~ g!obj) (~ obj)]
- (.= (~ (text$ field)) (~ value) (~ g!obj)))))))))
-
-(defsyntax #export (.! [call method-call^] obj)
- (let [[m-name ?m-classes m-args] call]
- (case obj
- (#;Meta [_ (#;SymbolS obj-name)])
- (do Lux/Monad
- [obj-type (find-var-type obj-name)]
- (case obj-type
- (#;DataT class)
- (emit (list (` (_jvm_invokevirtual (~ (text$ class)) (~ (text$ m-name)) [(~@ (map text$ ?m-classes))]
- (~ obj) [(~@ m-args)]))))
-
- _
- (fail "Can only call method on object.")))
-
- _
- (do Lux/Monad
- [g!obj (gensym "")]
- (emit (list (` (;let [(~ g!obj) (~ obj)]
- (.! ((~ (symbol$ ["" m-name]))
- [(~@ (map (lambda [c] (symbol$ ["" c])) ?m-classes))]
- [(~@ m-args)])
- (~ g!obj))))))))))
-
-(defsyntax #export (..? [field local-symbol^] [class local-symbol^])
- (emit (list (` (_jvm_getstatic (~ (text$ class)) (~ (text$ field)))))))
-
-(defsyntax #export (..= [field local-symbol^] value [class local-symbol^])
- (emit (list (` (_jvm_putstatic (~ (text$ class)) (~ (text$ field)) (~ value))))))
-
-(defsyntax #export (..! [call method-call^] [class local-symbol^])
- (let [[m-name m-classes m-args] call]
- (emit (list (` (_jvm_invokestatic (~ (text$ class)) (~ (text$ m-name))
- [(~@ (map text$ m-classes))]
- [(~@ m-args)]))))))
+ [invoke-virtual$ ;_jvm_invokevirtual true]
+ [invoke-interface$ ;_jvm_invokeinterface true]
+ [invoke-special$ ;_jvm_invokespecial true]
+ [invoke-static$ ;_jvm_invokestatic false]
+ )
diff --git a/source/lux/math.lux b/source/lux/math.lux
index a495d130c..a60ce512c 100644
--- a/source/lux/math.lux
+++ b/source/lux/math.lux
@@ -1,12 +1,10 @@
-## 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/.
-(;import lux)
+(;import lux
+ (lux/data/number/int #open ("i:" Int/Number)))
## [Constants]
(do-template [<name> <value>]
@@ -61,3 +59,22 @@
[atan2 "atan2"]
[pow "pow"]
)
+
+(def (gcd' a b)
+ (-> Int Int Int)
+ (case b
+ 0 a
+ _ (gcd' b (i:% a b))))
+
+(def #export (gcd a b)
+ (-> Int Int Int)
+ (gcd' (i:abs a) (i:abs b)))
+
+(def #export (lcm x y)
+ (-> Int Int Int)
+ (case [x y]
+ (\or [_ 0] [0 _])
+ 0
+
+ _
+ (i:abs (i:* (i:/ x (gcd x y)) y))))
diff --git a/source/lux/meta/ast.lux b/source/lux/meta/ast.lux
new file mode 100644
index 000000000..a9bc8b588
--- /dev/null
+++ b/source/lux/meta/ast.lux
@@ -0,0 +1,113 @@
+## Copyright (c) Eduardo Julian. All rights reserved.
+## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
+## If a copy of the MPL was not distributed with this file,
+## You can obtain one at http://mozilla.org/MPL/2.0/.
+
+(;import lux
+ (lux (control (show #as S #refer #all)
+ (eq #as E #refer #all))
+ (data bool
+ (number int
+ real)
+ char
+ (text #refer (#only Text/Show Text/Eq) #open ("text:" Text/Monoid))
+ ident
+ (list #refer #all #open ("" List/Functor List/Fold))
+ )))
+
+## [Types]
+## (deftype (AST' w)
+## (| (#;BoolS Bool)
+## (#;IntS Int)
+## (#;RealS Real)
+## (#;CharS Char)
+## (#;TextS Text)
+## (#;SymbolS Text Text)
+## (#;TagS Text Text)
+## (#;FormS (List (w (AST' w))))
+## (#;TupleS (List (w (AST' w))))
+## (#;RecordS (List (, (w (AST' w)) (w (AST' w)))))))
+
+## (deftype AST
+## (Meta Cursor (AST' (Meta Cursor))))
+
+## [Utils]
+(def _cursor Cursor ["" -1 -1])
+
+## [Functions]
+(do-template [<name> <type> <tag>]
+ [(def #export (<name> x)
+ (-> <type> AST)
+ [_cursor (<tag> x)])]
+
+ [bool$ Bool #;BoolS]
+ [int$ Int #;IntS]
+ [real$ Real #;RealS]
+ [char$ Char #;CharS]
+ [text$ Text #;TextS]
+ [symbol$ Ident #;SymbolS]
+ [tag$ Ident #;TagS]
+ [form$ (List AST) #;FormS]
+ [tuple$ (List AST) #;TupleS]
+ [record$ (List (, AST AST)) #;RecordS]
+ )
+
+## [Structures]
+(defstruct #export AST/Show (Show AST)
+ (def (show ast)
+ (case ast
+ (\template [<tag> <struct>]
+ [[_ (<tag> value)]
+ (:: <struct> (show value))])
+ [[#;BoolS Bool/Show]
+ [#;IntS Int/Show]
+ [#;RealS Real/Show]
+ [#;CharS Char/Show]
+ [#;TextS Text/Show]]
+
+ (\template [<tag> <prefix>]
+ [[_ (<tag> ident)]
+ (text:++ <prefix> (:: Ident/Show (show ident)))])
+ [[#;SymbolS ""] [#;TagS "#"]]
+
+ (\template [<tag> <open> <close>]
+ [[_ (<tag> members)]
+ ($ text:++ <open> (|> members (map show) (interpose "") (foldL text:++ text:unit)) <close>)])
+ [[#;FormS "(" ")"] [#;TupleS "[" "]"]]
+
+ [_ (#;RecordS pairs)]
+ ($ text:++ "{" (|> pairs (map (lambda [[left right]] ($ text:++ (show left) " " (show right)))) (interpose "") (foldL text:++ text:unit)) "}")
+ )))
+
+(defstruct #export AST/Eq (Eq AST)
+ (def (= x y)
+ (case [x y]
+ (\template [<tag> <struct>]
+ [[[_ (<tag> x')] [_ (<tag> y')]]
+ (:: <struct> (= x' y'))])
+ [[#;BoolS Bool/Eq]
+ [#;IntS Int/Eq]
+ [#;RealS Real/Eq]
+ [#;CharS Char/Eq]
+ [#;TextS Text/Eq]
+ [#;SymbolS Ident/Eq]
+ [#;TagS Ident/Eq]]
+
+ (\template [<tag>]
+ [[[_ (<tag> xs')] [_ (<tag> ys')]]
+ (and (:: Int/Eq (= (size xs') (size ys')))
+ (foldL (lambda [old [x' y']]
+ (and old (= x' y')))
+ true
+ (zip2 xs' ys')))])
+ [[#;FormS] [#;TupleS]]
+
+ [[_ (#;RecordS xs')] [_ (#;RecordS ys')]]
+ (and (:: Int/Eq (= (size xs') (size ys')))
+ (foldL (lambda [old [[xl' xr'] [yl' yr']]]
+ (and old (= xl' yl') (= xr' yr')))
+ true
+ (zip2 xs' ys')))
+
+ _
+ false)))
diff --git a/source/lux/meta/lux.lux b/source/lux/meta/lux.lux
index 19b7dd9df..b6ff09f59 100644
--- a/source/lux/meta/lux.lux
+++ b/source/lux/meta/lux.lux
@@ -1,21 +1,19 @@
-## 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/.
(;import lux
- (.. macro)
+ (.. ast)
(lux/control (monoid #as m)
(functor #as F)
- (monad #as M #refer (#only do)))
- (lux/data list
- maybe
- (show #as S)
- (number #as N)
- (text #as T #open ("text:" Text/Monoid Text/Eq))))
+ (monad #as M #refer (#only do))
+ (show #as S))
+ (lux/data (list #refer #all #open ("list:" List/Monoid List/Functor))
+ (text #as T #open ("text:" Text/Monoid Text/Eq))
+ (number/int #as I #open ("i" Int/Number))
+ (tuple #as t)
+ ident))
## [Types]
## (deftype (Lux a)
@@ -29,7 +27,7 @@
## [Structures]
(defstruct #export Lux/Functor (F;Functor Lux)
- (def (F;map f fa)
+ (def (map f fa)
(lambda [state]
(case (fa state)
(#;Left msg)
@@ -39,11 +37,11 @@
(#;Right [state' (f a)])))))
(defstruct #export Lux/Monad (M;Monad Lux)
- (def M;_functor Lux/Functor)
- (def (M;wrap x)
+ (def _functor Lux/Functor)
+ (def (wrap x)
(lambda [state]
(#;Right [state x])))
- (def (M;join mma)
+ (def (join mma)
(lambda [state]
(case (mma state)
(#;Left msg)
@@ -69,7 +67,7 @@
#;Nil
#;None
- (#;Cons [[k' v] plist'])
+ (#;Cons [k' v] plist')
(if (text:= k k')
(#;Some v)
(get k plist'))))
@@ -77,20 +75,27 @@
(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 (|> (: (Module Compiler) $module) (get@ #;defs) (get name))]
- (case (: (, Bool (DefData' Macro)) gdef)
- [exported? (#;MacroD macro')]
- (if (or exported? (text:= module current-module))
- (#;Some macro')
+ (case (get module modules)
+ (#;Some $module)
+ (case (|> (: (Module Compiler) $module) (get@ #;defs) (get name))
+ (#;Some gdef)
+ (case (: Definition gdef)
+ [exported? (#;MacroD macro')]
+ (if (or exported? (text:= module current-module))
+ (#;Some macro')
+ #;None)
+
+ [_ (#;AliasD [r-module r-name])]
+ (find-macro' modules current-module r-module r-name)
+
+ _
#;None)
-
- [_ (#;AliasD [r-module r-name])]
- (find-macro' modules current-module r-module r-name)
_
- #;None)))
+ #;None)
+
+ _
+ #;None))
(def #export (find-macro ident)
(-> Ident (Lux (Maybe Macro)))
@@ -107,15 +112,15 @@
["" name]
(do Lux/Monad
[module-name get-module-name]
- (M;wrap (: Ident [module-name name])))
+ (wrap [module-name name]))
_
- (:: Lux/Monad (M;wrap ident))))
+ (:: Lux/Monad (wrap ident))))
(def #export (macro-expand syntax)
- (-> Syntax (Lux (List Syntax)))
+ (-> AST (Lux (List AST)))
(case syntax
- (#;Meta [_ (#;FormS (#;Cons [(#;Meta [_ (#;SymbolS macro-name)]) args]))])
+ [_ (#;FormS (#;Cons [[_ (#;SymbolS macro-name)] args]))]
(do Lux/Monad
[macro-name' (normalize macro-name)
?macro (find-macro macro-name')]
@@ -124,31 +129,51 @@
(do Lux/Monad
[expansion (macro args)
expansion' (M;map% Lux/Monad macro-expand expansion)]
- (M;wrap (:: List/Monad (M;join expansion'))))
+ (wrap (:: List/Monad (join expansion'))))
+
+ #;None
+ (:: Lux/Monad (wrap (@list syntax)))))
+
+ _
+ (:: Lux/Monad (wrap (@list syntax)))))
+
+(def #export (macro-expand-all syntax)
+ (-> AST (Lux (List AST)))
+ (case syntax
+ [_ (#;FormS (#;Cons [[_ (#;SymbolS macro-name)] args]))]
+ (do Lux/Monad
+ [macro-name' (normalize macro-name)
+ ?macro (find-macro macro-name')]
+ (case ?macro
+ (#;Some macro)
+ (do Lux/Monad
+ [expansion (macro args)
+ expansion' (M;map% Lux/Monad macro-expand-all expansion)]
+ (wrap (:: List/Monad (join expansion'))))
#;None
(do Lux/Monad
- [parts' (M;map% Lux/Monad macro-expand (list& (symbol$ macro-name) args))]
- (M;wrap (list (form$ (:: List/Monad (M;join parts'))))))))
+ [parts' (M;map% Lux/Monad macro-expand-all (@list& (symbol$ macro-name) args))]
+ (wrap (@list (form$ (:: List/Monad (join parts'))))))))
- (#;Meta [_ (#;FormS (#;Cons [harg targs]))])
+ [_ (#;FormS (#;Cons [harg targs]))]
(do Lux/Monad
- [harg+ (macro-expand harg)
- targs+ (M;map% Lux/Monad macro-expand targs)]
- (M;wrap (list (form$ (list:++ harg+ (:: List/Monad (M;join (: (List (List Syntax)) targs+))))))))
+ [harg+ (macro-expand-all harg)
+ targs+ (M;map% Lux/Monad macro-expand-all targs)]
+ (wrap (@list (form$ (list:++ harg+ (:: List/Monad (join (: (List (List AST)) targs+))))))))
- (#;Meta [_ (#;TupleS members)])
+ [_ (#;TupleS members)]
(do Lux/Monad
- [members' (M;map% Lux/Monad macro-expand members)]
- (M;wrap (list (tuple$ (:: List/Monad (M;join members'))))))
+ [members' (M;map% Lux/Monad macro-expand-all members)]
+ (wrap (@list (tuple$ (:: List/Monad (join members'))))))
_
- (:: Lux/Monad (M;wrap (list syntax)))))
+ (:: Lux/Monad (wrap (@list syntax)))))
(def #export (gensym prefix state)
- (-> Text (Lux Syntax))
- (#;Right [(update@ #;seed inc state)
- (symbol$ ["__gensym__" (:: N;Int/Show (S;show (get@ #;seed state)))])]))
+ (-> Text (Lux AST))
+ (#;Right [(update@ #;seed (i+ 1) state)
+ (symbol$ ["" ($ text:++ "__gensym__" prefix (:: I;Int/Show (show (get@ #;seed state))))])]))
(def #export (emit datum)
(All [a]
@@ -163,12 +188,12 @@
(#;Left msg)))
(def #export (macro-expand-1 token)
- (-> Syntax (Lux Syntax))
+ (-> AST (Lux AST))
(do Lux/Monad
[token+ (macro-expand token)]
(case token+
- (\ (list token'))
- (M;wrap token')
+ (\ (@list token'))
+ (wrap token')
_
(fail "Macro expanded to more than 1 element."))))
@@ -187,34 +212,18 @@
(case (get module (get@ #;modules state))
(#;Some =module)
(using List/Monad
- (#;Right [state (join (:: _functor (F;map (: (-> (, Text (, Bool (DefData' Macro)))
- (List Text))
- (lambda [gdef]
- (let [[name [export? _]] gdef]
- (if export?
- (list name)
- (list)))))
- (get@ #;defs =module))))]))
+ (#;Right [state (join (map (: (-> (, Text Definition)
+ (List Text))
+ (lambda [gdef]
+ (let [[name [export? _]] gdef]
+ (if export?
+ (@list name)
+ (@list)))))
+ (get@ #;defs =module)))]))
#;None
(#;Left ($ text:++ "Unknown module: " module))))
-(def (show-envs envs)
- (-> (List (Env Text (, LuxVar Type))) Text)
- (|> envs
- (F;map (lambda [env]
- (case env
- {#;name name #;inner-closures _ #;locals {#;counter _ #;mappings locals} #;closure _}
- ($ text:++ name ": " (|> locals
- (F;map (: (All [a] (-> (, Text a) Text))
- (lambda [b] (let [[label _] b] label))))
- (:: List/Functor)
- (interpose " ")
- (foldL text:++ text:unit))))))
- (:: List/Functor)
- (interpose "\n")
- (foldL text:++ text:unit)))
-
(def (try-both f x1 x2)
(All [a b]
(-> (-> a (Maybe b)) a a (Maybe b)))
@@ -222,56 +231,71 @@
#;None (f x2)
(#;Some y) (#;Some y)))
-(def (find-in-env name state)
- (-> Ident Compiler (Maybe Type))
- (let [vname' (ident->text name)]
- (case state
- {#;source source #;modules modules
- #;envs envs #;types types #;host host
- #;seed seed #;eval? eval?}
- (some (: (-> (Env Text (, LuxVar Type)) (Maybe Type))
- (lambda [env]
- (case env
- {#;name _ #;inner-closures _ #;locals {#;counter _ #;mappings locals} #;closure {#;counter _ #;mappings closure}}
- (try-both (some (: (-> (, Text (, LuxVar Type)) (Maybe Type))
- (lambda [binding]
- (let [[bname [_ type]] binding]
- (if (text:= vname' bname)
- (#;Some type)
- #;None)))))
- locals
- closure))))
- envs))))
-
-(def (find-in-defs name state)
- (-> Ident Compiler (Maybe Type))
+(def #export (find-in-env name state)
+ (-> Text Compiler (Maybe Type))
+ (case state
+ {#;source source #;modules modules
+ #;envs envs #;type-vars types #;host host
+ #;seed seed #;eval? eval? #;expected expected
+ #;cursor cursor}
+ (some (: (-> (Env Text (Meta (, Type Cursor) Analysis)) (Maybe Type))
+ (lambda [env]
+ (case env
+ {#;name _ #;inner-closures _ #;locals {#;counter _ #;mappings locals} #;closure {#;counter _ #;mappings closure}}
+ (try-both (some (: (-> (, Text (Meta (, Type Cursor) Analysis)) (Maybe Type))
+ (lambda [binding]
+ (let [[bname [[type _] _]] binding]
+ (if (text:= name bname)
+ (#;Some type)
+ #;None)))))
+ locals
+ closure))))
+ envs)))
+
+(def (find-in-defs' name state)
+ (-> Ident Compiler (Maybe Definition))
(let [[v-prefix v-name] name
{#;source source #;modules modules
- #;envs envs #;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 _ #;types _})
(case (get v-name defs)
#;None
#;None
- (#;Some [_ def-data])
- (case def-data
- #;TypeD (#;Some Type)
- (#;ValueD type) (#;Some type)
- (#;MacroD m) (#;Some Macro)
- (#;AliasD name') (find-in-defs name' state))))))
+ (#;Some def)
+ (case def
+ [_ (#;AliasD name')] (find-in-defs' name' state)
+ _ (#;Some def)
+ )))
+ ))
+
+(def #export (find-in-defs name state)
+ (-> Ident Compiler (Maybe Type))
+ (case (find-in-defs' name state)
+ (#;Some [_ def-data])
+ (case def-data
+ (#;ValueD [type value]) (#;Some type)
+ (#;MacroD _) (#;Some Macro)
+ (#;TypeD _) (#;Some Type)
+ _ #;None)
+
+ #;None
+ #;None))
(def #export (find-var-type name)
(-> Ident (Lux Type))
(do Lux/Monad
- [name' (normalize name)]
+ [#let [[_ _name] name]
+ name' (normalize name)]
(: (Lux Type)
(lambda [state]
- (case (find-in-env name state)
+ (case (find-in-env _name state)
(#;Some struct-type)
(#;Right [state struct-type])
@@ -281,8 +305,62 @@
(#;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))))))))
+ (#;Left ($ text:++ "Unknown var: " (ident->text name)))))))
))
+
+(def #export (find-type name)
+ (-> Ident (Lux Type))
+ (do Lux/Monad
+ [name' (normalize name)]
+ (: (Lux Type)
+ (lambda [state]
+ (case (find-in-defs' name' state)
+ (#;Some def-data)
+ (case def-data
+ [_ (#;TypeD type)] (#;Right [state type])
+ _ (#;Left ($ text:++ "Definition is not a type: " (ident->text name))))
+
+ _
+ (#;Left ($ text:++ "Unknown var: " (ident->text name))))))
+ ))
+
+(def #export (defs module-name state)
+ (-> Text (Lux (List (, Text Definition))))
+ (case (get module-name (get@ #;modules state))
+ #;None (#;Left ($ text:++ "Unknown module: " module-name))
+ (#;Some module) (#;Right [state (get@ #;defs module)])
+ ))
+
+(def #export (exports module-name)
+ (-> Text (Lux (List (, Text Definition))))
+ (do Lux/Monad
+ [defs (defs module-name)]
+ (wrap (filter (lambda [[name [exported? data]]] exported?)
+ defs))))
+
+(def #export (modules state)
+ (Lux (List Text))
+ (|> state
+ (get@ #;modules)
+ (list:map t;first)
+ (#;Right state)))
+
+(def #export (find-module name state)
+ (-> Text (Lux (Module Compiler)))
+ (case (get name (get@ #;modules state))
+ (#;Some module)
+ (#;Right state module)
+
+ _
+ (#;Left ($ text:++ "Unknown module: " name))))
+
+(def #export (tags-for [module name])
+ (-> Ident (Lux (Maybe (List Ident))))
+ (do Lux/Monad
+ [module (find-module module)]
+ (case (get name (get@ #;types module))
+ (#;Some [tags _])
+ (wrap (#;Some tags))
+
+ _
+ (wrap #;None))))
diff --git a/source/lux/meta/macro.lux b/source/lux/meta/macro.lux
deleted file mode 100644
index 22aeaf874..000000000
--- a/source/lux/meta/macro.lux
+++ /dev/null
@@ -1,54 +0,0 @@
-## Copyright (c) Eduardo Julian. All rights reserved.
-## The use and distribution terms for this software are covered by the
-## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
-## which can be found in the file epl-v10.html at the root of this distribution.
-## By using this software in any fashion, you are agreeing to be bound by
-## the terms of this license.
-## You must not remove this notice, or any other, from this software.
-
-(;import lux)
-
-## [Utils]
-(def (_meta x)
- (-> (Syntax' (Meta Cursor)) Syntax)
- (#;Meta [["" -1 -1] x]))
-
-## [Syntax]
-(def #export (defmacro tokens state)
- Macro
- (case tokens
- (#;Cons [(#;Meta [_ (#;FormS (#;Cons [name args]))]) (#;Cons [body #;Nil])])
- (#;Right [state (#;Cons [(` ((~ (_meta (#;SymbolS ["lux" "def"]))) ((~ name) (~@ args))
- (~ (_meta (#;SymbolS ["lux" "Macro"])))
- (~ body)))
- (#;Cons [(` ((~ (_meta (#;SymbolS ["" "_lux_declare-macro"]))) (~ name)))
- #;Nil])])])
-
- (#;Cons [(#;Meta [_ (#;TagS ["" "export"])]) (#;Cons [(#;Meta [_ (#;FormS (#;Cons [name args]))]) (#;Cons [body #;Nil])])])
- (#;Right [state (#;Cons [(` ((~ (_meta (#;SymbolS ["lux" "def"]))) (~ (_meta (#;TagS ["" "export"]))) ((~ name) (~@ args))
- (~ (_meta (#;SymbolS ["lux" "Macro"])))
- (~ body)))
- (#;Cons [(` ((~ (_meta (#;SymbolS ["" "_lux_declare-macro"]))) (~ name)))
- #;Nil])])])
-
- _
- (#;Left "Wrong syntax for defmacro")))
-(_lux_declare-macro defmacro)
-
-## [Functions]
-(do-template [<name> <type> <tag>]
- [(def #export (<name> x)
- (-> <type> Syntax)
- (#;Meta [["" -1 -1] (<tag> x)]))]
-
- [bool$ Bool #;BoolS]
- [int$ Int #;IntS]
- [real$ Real #;RealS]
- [char$ Char #;CharS]
- [text$ Text #;TextS]
- [symbol$ Ident #;SymbolS]
- [tag$ Ident #;TagS]
- [form$ (List Syntax) #;FormS]
- [tuple$ (List Syntax) #;TupleS]
- [record$ (List (, Syntax Syntax)) #;RecordS]
- )
diff --git a/source/lux/meta/syntax.lux b/source/lux/meta/syntax.lux
index 63ab81475..641dfba0d 100644
--- a/source/lux/meta/syntax.lux
+++ b/source/lux/meta/syntax.lux
@@ -1,21 +1,20 @@
-## 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/.
(;import lux
- (.. (macro #as m #refer #all)
+ (.. ast
(lux #as l #refer (#only Lux/Monad gensym)))
(lux (control (functor #as F)
- (monad #as M #refer (#only do)))
- (data (eq #as E)
- (bool #as b)
+ (monad #as M #refer (#only do))
+ (eq #as E))
+ (data (bool #as b)
(char #as c)
(text #as t #open ("text:" Text/Monoid Text/Eq))
- list)))
+ (list #refer #all #open ("" List/Functor List/Fold))
+ (number (int #open ("i" Int/Ord))
+ (real #open ("r" Real/Eq))))))
## [Utils]
(def (first xy)
@@ -27,15 +26,19 @@
(All [a] (-> (List (, a a)) (List a)))
(case pairs
#;Nil #;Nil
- (#;Cons [[x y] pairs']) (list& x y (join-pairs pairs'))))
+ (#;Cons [[x y] pairs']) (@list& x y (join-pairs pairs'))))
-## Types
+(def (pair->tuple [left right])
+ (-> (, AST AST) AST)
+ (tuple$ (@list left right)))
+
+## [Types]
(deftype #export (Parser a)
- (-> (List Syntax) (Maybe (, (List Syntax) a))))
+ (-> (List AST) (Maybe (, (List AST) a))))
-## Structures
+## [Structures]
(defstruct #export Parser/Functor (F;Functor Parser)
- (def (F;map f ma)
+ (def (map f ma)
(lambda [tokens]
(case (ma tokens)
#;None
@@ -45,12 +48,12 @@
(#;Some [tokens' (f a)])))))
(defstruct #export Parser/Monad (M;Monad Parser)
- (def M;_functor Parser/Functor)
+ (def _functor Parser/Functor)
- (def (M;wrap x tokens)
+ (def (wrap x tokens)
(#;Some [tokens x]))
- (def (M;join mma)
+ (def (join mma)
(lambda [tokens]
(case (mma tokens)
#;None
@@ -59,9 +62,9 @@
(#;Some [tokens' ma])
(ma tokens')))))
-## Parsers
+## [Parsers]
(def #export (id^ tokens)
- (Parser Syntax)
+ (Parser AST)
(case tokens
#;Nil #;None
(#;Cons [t tokens']) (#;Some [tokens' t])))
@@ -70,7 +73,7 @@
[(def #export (<name> tokens)
(Parser <type>)
(case tokens
- (#;Cons [(#;Meta [_ (<tag> x)]) tokens'])
+ (#;Cons [[_ (<tag> x)] tokens'])
(#;Some [tokens' x])
_
@@ -85,11 +88,24 @@
[ tag^ Ident #;TagS]
)
+(def #export (assert v tokens)
+ (-> Bool (Parser (,)))
+ (if v
+ (#;Some [tokens []])
+ #;None))
+
+(def #export nat^
+ (Parser Int)
+ (do Parser/Monad
+ [n int^
+ _ (assert (i>= n 0))]
+ (wrap n)))
+
(do-template [<name> <tag>]
[(def #export (<name> tokens)
(Parser Text)
(case tokens
- (#;Cons [(#;Meta [_ (<tag> ["" x])]) tokens'])
+ (#;Cons [[_ (<tag> ["" x])] tokens'])
(#;Some [tokens' x])
_
@@ -108,32 +124,51 @@
(do-template [<name> <type> <tag> <eq>]
[(def #export (<name> v tokens)
- (-> <type> (Parser (,)))
+ (-> <type> (Parser Bool))
(case tokens
- (#;Cons [(#;Meta [_ (<tag> x)]) tokens'])
- (if (<eq> v x)
- (#;Some [tokens' []])
- #;None)
+ (#;Cons [[_ (<tag> x)] tokens'])
+ (#;Some [tokens' (<eq> v x)])
_
- #;None))]
+ (#;Some [tokens false])))]
- [ bool?^ Bool #;BoolS (:: b;Bool/Eq E;=)]
+ [ bool?^ Bool #;BoolS (:: b;Bool/Eq =)]
[ int?^ Int #;IntS i=]
[ real?^ Real #;RealS r=]
- [ char?^ Char #;CharS (:: c;Char/Eq E;=)]
- [ text?^ Text #;TextS (:: t;Text/Eq E;=)]
+ [ char?^ Char #;CharS (:: c;Char/Eq =)]
+ [ text?^ Text #;TextS (:: t;Text/Eq =)]
[symbol?^ Ident #;SymbolS ident:=]
[ tag?^ Ident #;TagS ident:=]
)
+(do-template [<name> <type> <tag> <eq>]
+ [(def #export (<name> v tokens)
+ (-> <type> (Parser Unit))
+ (case tokens
+ (#;Cons [[_ (<tag> x)] tokens'])
+ (if (<eq> v x)
+ (#;Some [tokens' []])
+ #;None)
+
+ _
+ #;None))]
+
+ [ bool!^ Bool #;BoolS (:: b;Bool/Eq =)]
+ [ int!^ Int #;IntS i=]
+ [ real!^ Real #;RealS r=]
+ [ char!^ Char #;CharS (:: c;Char/Eq =)]
+ [ text!^ Text #;TextS (:: t;Text/Eq =)]
+ [symbol!^ Ident #;SymbolS ident:=]
+ [ tag!^ Ident #;TagS ident:=]
+ )
+
(do-template [<name> <tag>]
[(def #export (<name> p tokens)
(All [a]
(-> (Parser a) (Parser a)))
(case tokens
- (#;Cons [(#;Meta [_ (<tag> form)]) tokens'])
- (case (p form)
+ (#;Cons [[_ (<tag> members)] tokens'])
+ (case (p members)
(#;Some [#;Nil x]) (#;Some [tokens' x])
_ #;None)
@@ -144,6 +179,18 @@
[tuple^ #;TupleS]
)
+(def #export (record^ p tokens)
+ (All [a]
+ (-> (Parser a) (Parser a)))
+ (case tokens
+ (#;Cons [[_ (#;RecordS pairs)] tokens'])
+ (case (p (map pair->tuple pairs))
+ (#;Some [#;Nil x]) (#;Some [tokens' x])
+ _ #;None)
+
+ _
+ #;None))
+
(def #export (?^ p tokens)
(All [a]
(-> (Parser a) (Parser (Maybe a))))
@@ -153,17 +200,17 @@
(def (run-parser p tokens)
(All [a]
- (-> (Parser a) (List Syntax) (Maybe (, (List Syntax) a))))
+ (-> (Parser a) (List AST) (Maybe (, (List AST) a))))
(p tokens))
(def #export (*^ p tokens)
(All [a]
(-> (Parser a) (Parser (List a))))
(case (p tokens)
- #;None (#;Some [tokens (list)])
+ #;None (#;Some [tokens (@list)])
(#;Some [tokens' x]) (run-parser (do Parser/Monad
[xs (*^ p)]
- (M;wrap (list& x xs)))
+ (wrap (@list& x xs)))
tokens')))
(def #export (+^ p)
@@ -172,7 +219,7 @@
(do Parser/Monad
[x p
xs (*^ p)]
- (M;wrap (list& x xs))))
+ (wrap (@list& x xs))))
(def #export (&^ p1 p2)
(All [a b]
@@ -180,17 +227,18 @@
(do Parser/Monad
[x1 p1
x2 p2]
- (M;wrap [x1 x2])))
+ (wrap [x1 x2])))
(def #export (|^ p1 p2 tokens)
(All [a b]
- (-> (Parser a) (Parser b) (Parser (Either b))))
+ (-> (Parser a) (Parser b) (Parser (Either a b))))
(case (p1 tokens)
(#;Some [tokens' x1]) (#;Some [tokens' (#;Left x1)])
#;None (run-parser (do Parser/Monad
[x2 p2]
- (M;wrap (#;Right x2)))
- tokens)))
+ (wrap (#;Right x2)))
+ tokens)
+ ))
(def #export (||^ ps tokens)
(All [a]
@@ -208,55 +256,51 @@
#;Nil (#;Some [tokens []])
_ #;None))
-## Syntax
+## [Syntax]
(defmacro #export (defsyntax tokens)
- (let [[exported? tokens] (: (, Bool (List Syntax))
- (case tokens
- (\ (list& (#;Meta [_ (#;TagS ["" "export"])]) tokens'))
- [true tokens']
+ (let [[exported? tokens] (case tokens
+ (\ (@list& [_ (#;TagS ["" "export"])] tokens'))
+ [true tokens']
- _
- [false tokens]))]
+ _
+ [false tokens])]
(case tokens
- (\ (list (#;Meta [_ (#;FormS (list& (#;Meta [_ (#;SymbolS ["" name])]) args))])
- body))
+ (\ (@list [_ (#;FormS (@list& [_ (#;SymbolS ["" name])] args))]
+ body))
(do Lux/Monad
- [names+parsers (M;map% Lux/Monad
- (: (-> Syntax (Lux (, Syntax Syntax)))
- (lambda [arg]
- (case arg
- (\ (#;Meta [_ (#;TupleS (list (#;Meta [_ (#;SymbolS var-name)])
- parser))]))
- (M;wrap [(symbol$ var-name) parser])
-
- (\ (#;Meta [_ (#;SymbolS var-name)]))
- (M;wrap [(symbol$ var-name) (` id^)])
-
- _
- (l;fail "Syntax pattern expects 2-tuples or symbols."))))
- args)
+ [vars+parsers (M;map% Lux/Monad
+ (: (-> AST (Lux (, AST AST)))
+ (lambda [arg]
+ (case arg
+ (\ [_ (#;TupleS (@list var parser))])
+ (wrap [var parser])
+
+ (\ [_ (#;SymbolS var-name)])
+ (wrap [(symbol$ var-name) (` id^)])
+
+ _
+ (l;fail "Syntax pattern expects 2-tuples or symbols."))))
+ args)
g!tokens (gensym "tokens")
g!_ (gensym "_")
- #let [names (:: List/Functor (F;map first names+parsers))
- error-msg (text$ (text:++ "Wrong syntax for " name))
- body' (foldL (: (-> Syntax (, Syntax Syntax) Syntax)
+ #let [error-msg (text$ (text:++ "Wrong syntax for " name))
+ body' (foldL (: (-> AST (, AST AST) AST)
(lambda [body name+parser]
(let [[name parser] name+parser]
- (` (_lux_case ((~ parser) (~ g!tokens))
- (#;Some [(~ g!tokens) (~ name)])
- (~ body)
+ (` (;_lux_case ((~ parser) (~ g!tokens))
+ (#;Some [(~ g!tokens) (~ name)])
+ (~ body)
- (~ g!_)
- (l;fail (~ error-msg)))))))
+ (~ g!_)
+ (l;fail (~ error-msg)))))))
body
- (: (List (, Syntax Syntax)) (list& [(symbol$ ["" ""]) (` end^)] (reverse names+parsers))))
- macro-def (: Syntax
- (` (m;defmacro ((~ (symbol$ ["" name])) (~ g!tokens))
- (~ body'))))]]
- (M;wrap (list& macro-def
- (if exported?
- (list (` (_lux_export (~ (symbol$ ["" name])))))
- (list)))))
+ (: (List (, AST AST)) (@list& [(symbol$ ["" ""]) (` end^)] (reverse vars+parsers))))
+ macro-def (` (defmacro ((~ (symbol$ ["" name])) (~ g!tokens))
+ (~ body')))]]
+ (wrap (@list& macro-def
+ (if exported?
+ (@list (` (;_lux_export (~ (symbol$ ["" name])))))
+ (@list)))))
_
(l;fail "Wrong syntax for defsyntax"))))
diff --git a/source/lux/meta/type.lux b/source/lux/meta/type.lux
new file mode 100644
index 000000000..0938d104d
--- /dev/null
+++ b/source/lux/meta/type.lux
@@ -0,0 +1,193 @@
+## Copyright (c) Eduardo Julian. All rights reserved.
+## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
+## If a copy of the MPL was not distributed with this file,
+## You can obtain one at http://mozilla.org/MPL/2.0/.
+
+(;import lux
+ (lux (control show
+ eq
+ monad)
+ (data (char #as c)
+ (text #as t #open ("text:" Text/Monoid Text/Eq))
+ (number/int #open ("int:" Int/Number Int/Ord Int/Show))
+ maybe
+ (list #refer #all #open ("list:" List/Monad List/Monoid List/Fold)))
+ ))
+
+(open List/Fold)
+
+## [Utils]
+(def (unravel-fun type)
+ (-> Type (, Type (List Type)))
+ (case type
+ (#;LambdaT in out')
+ (let [[out ins] (unravel-fun out')]
+ [out (@list& in ins)])
+
+ _
+ [type (@list)]))
+
+(def (unravel-app type)
+ (-> Type (, Type (List Type)))
+ (case type
+ (#;AppT left' right)
+ (let [[left rights] (unravel-app left')]
+ [left (list:++ rights (@list right))])
+
+ _
+ [type (@list)]))
+
+## [Structures]
+(defstruct #export Type/Show (Show Type)
+ (def (show type)
+ (case type
+ (#;DataT name params)
+ (case params
+ #;Nil
+ ($ text:++ "(^ " name ")")
+
+ _
+ ($ text:++ "(^ " name " " (|> params (list:map show) (interpose " ") (list:foldL text:++ "")) ")"))
+
+ (#;TupleT members)
+ (case members
+ #;Nil
+ "(,)"
+
+ _
+ ($ text:++ "(, " (|> members (list:map show) (interpose " ") (foldL text:++ "")) ")"))
+
+ (#;VariantT members)
+ (case members
+ #;Nil
+ "(|)"
+
+ _
+ ($ text:++ "(| " (|> members (list:map show) (interpose " ") (foldL text:++ "")) ")"))
+
+ (#;LambdaT input output)
+ (let [[out ins] (unravel-fun type)]
+ ($ text:++ "(-> " (|> ins (list:map show) (interpose " ") (foldL text:++ "")) " " (show out) ")"))
+
+ (#;VarT id)
+ ($ text:++ "⌈" (int:show id) "⌋")
+
+ (#;BoundT idx)
+ (int:show idx)
+
+ (#;ExT id)
+ ($ text:++ "⟨" (int:show id) "⟩")
+
+ (#;AppT fun param)
+ (let [[type-fun type-args] (unravel-app type)]
+ ($ text:++ "(" (show type-fun) " " (|> type-args (list:map show) (interpose " ") (foldL text:++ "")) ")"))
+
+ (#;UnivQ env body)
+ ($ text:++ "(All " (show body) ")")
+
+ (#;ExQ env body)
+ ($ text:++ "(Ex " (show body) ")")
+
+ (#;NamedT [module name] type)
+ ($ text:++ module ";" name)
+ )))
+
+(defstruct #export Type/Eq (Eq Type)
+ (def (= x y)
+ (case [x y]
+ [(#;DataT xname xparams) (#;DataT yname yparams)]
+ (and (text:= xname yname)
+ (int:= (size xparams) (size yparams))
+ (foldL (lambda [prev [x y]]
+ (and prev (= x y)))
+ true
+ (zip2 xparams yparams)))
+
+ (\or [(#;VarT xid) (#;VarT yid)]
+ [(#;ExT xid) (#;ExT yid)]
+ [(#;BoundT xid) (#;BoundT yid)])
+ (int:= xid yid)
+
+ (\or [(#;LambdaT xleft xright) (#;LambdaT yleft yright)]
+ [(#;AppT xleft xright) (#;AppT yleft yright)])
+ (and (= xleft yleft)
+ (= xright yright))
+
+ [(#;NamedT [xmodule xname] xtype) (#;NamedT [ymodule yname] ytype)]
+ (and (text:= xmodule ymodule)
+ (text:= xname yname)
+ (= xtype ytype))
+
+ (\or [(#;TupleT xmembers) (#;TupleT ymembers)]
+ [(#;VariantT xmembers) (#;VariantT ymembers)])
+ (and (int:= (size xmembers) (size ymembers))
+ (foldL (lambda [prev [x y]]
+ (and prev (= x y)))
+ true
+ (zip2 xmembers ymembers)))
+
+ (\or [(#;UnivQ xenv xbody) (#;UnivQ yenv ybody)]
+ [(#;ExQ xenv xbody) (#;ExQ yenv ybody)])
+ (and (int:= (size xenv) (size yenv))
+ (foldL (lambda [prev [x y]]
+ (and prev (= x y)))
+ (= xbody ybody)
+ (zip2 xenv yenv)))
+
+ _
+ false
+ )))
+
+## [Functions]
+(def #export (beta-reduce env type)
+ (-> (List Type) Type Type)
+ (case type
+ (\template [<tag>]
+ [(<tag> members)
+ (<tag> (list:map (beta-reduce env) members))])
+ [[#;VariantT]
+ [#;TupleT]]
+
+ (\template [<tag>]
+ [(<tag> left right)
+ (<tag> (beta-reduce env left) (beta-reduce env right))])
+ [[#;LambdaT]
+ [#;AppT]]
+
+ (\template [<tag>]
+ [(<tag> env def)
+ (case env
+ #;Nil
+ (<tag> env def)
+
+ _
+ type)])
+ [[#;UnivQ]
+ [#;ExQ]]
+
+ (#;BoundT idx)
+ (? type (@ idx env))
+
+ (#;NamedT name type)
+ (beta-reduce env type)
+
+ _
+ type
+ ))
+
+(def #export (apply-type type-fun param)
+ (-> Type Type (Maybe Type))
+ (case type-fun
+ (#;UnivQ env body)
+ (#;Some (beta-reduce (@list& type-fun param env) body))
+
+ (#;AppT F A)
+ (do Maybe/Monad
+ [type-fn* (apply-type F A)]
+ (apply-type type-fn* param))
+
+ (#;NamedT name type)
+ (apply-type type param)
+
+ _
+ #;None))
diff --git a/source/program.lux b/source/program.lux
deleted file mode 100644
index 086506725..000000000
--- a/source/program.lux
+++ /dev/null
@@ -1,48 +0,0 @@
-## Copyright (c) Eduardo Julian. All rights reserved.
-## The use and distribution terms for this software are covered by the
-## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
-## which can be found in the file epl-v10.html at the root of this distribution.
-## By using this software in any fashion, you are agreeing to be bound by
-## the terms of this license.
-## You must not remove this notice, or any other, from this software.
-
-(;import lux
- (lux (codata (stream #as S))
- (control monoid
- functor
- monad
- lazy
- comonad)
- (data bool
- bounded
- char
- ## cont
- dict
- (either #as e)
- eq
- error
- id
- io
- list
- maybe
- number
- ord
- (reader #as r)
- show
- state
- (text #as t #open ("text:" Text/Monoid))
- writer)
- (host jvm)
- (meta lux
- macro
- syntax)
- (math #as m)
- ))
-
-(program args
- (case args
- (\ (list name))
- (println ($ text:++ "Hello, " name "!"))
-
- _
- (println "Hello, world!")))