diff options
| author | Eduardo Julian | 2015-10-04 19:59:22 -0400 |
|---|---|---|
| committer | Eduardo Julian | 2015-10-04 19:59:22 -0400 |
| commit | 72d9dc02b2a6978ff0905843019bc563e4db8767 (patch) | |
| tree | 5fea1a7aac28ebd9f9d74e6dd7846c1cae4f9db9 /source/lux.lux | |
| parent | 171b856f378e09e8e5e6dd3528c404eb9cf9560e (diff) | |
- Removed the Lux source from the repo, as it now belongs to the lux/stdlib package.
- Removed de Apacke Commons Compress library, as Lux libraries will now be packaged as .jar files instead of as .tar.gz files.
- The compiler no longer packages libraries, as that task will now be left for the build system.
Diffstat (limited to '')
| -rw-r--r-- | source/lux.lux | 3303 |
1 files changed, 0 insertions, 3303 deletions
diff --git a/source/lux.lux b/source/lux.lux deleted file mode 100644 index 4d1c3fdef..000000000 --- a/source/lux.lux +++ /dev/null @@ -1,3303 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -## If a copy of the MPL was not distributed with this file, -## You can obtain one at http://mozilla.org/MPL/2.0/. - -## First things first, must define functions -(_jvm_interface "Function" [] [] - ("apply" ["public" "abstract"] [] [] ["java.lang.Object"] "java.lang.Object")) - -## Basic types -(_lux_def Bool (10 ["lux" "Bool"] - (0 "java.lang.Boolean" (0)))) -(_lux_export Bool) - -(_lux_def Int (10 ["lux" "Int"] - (0 "java.lang.Long" (0)))) -(_lux_export Int) - -(_lux_def Real (10 ["lux" "Real"] - (0 "java.lang.Double" (0)))) -(_lux_export Real) - -(_lux_def Char (10 ["lux" "Char"] - (0 "java.lang.Character" (0)))) -(_lux_export Char) - -(_lux_def Text (10 ["lux" "Text"] - (0 "java.lang.String" (0)))) -(_lux_export Text) - -(_lux_def Unit (10 ["lux" "Unit"] - (2 (0)))) -(_lux_export Unit) - -(_lux_def Void (10 ["lux" "Void"] - (1 (0)))) -(_lux_export Void) - -(_lux_def Ident (10 ["lux" "Ident"] - (2 (1 Text (1 Text (0)))))) -(_lux_export Ident) - -## (deftype (List a) -## (| #Nil -## (#Cons a (List a)))) -(_lux_def List - (10 ["lux" "List"] - (7 (0) - (1 (1 ## "lux;Nil" - (2 (0)) - (1 ## "lux;Cons" - (2 (1 (4 1) - (1 (9 (4 0) (4 1)) - (0)))) - (0))))))) -(_lux_export List) -(_lux_declare-tags [#Nil #Cons] List) - -## (deftype (Maybe a) -## (| #None -## (1 a))) -(_lux_def Maybe - (10 ["lux" "Maybe"] - (7 (0) - (1 (1 ## "lux;None" - (2 (0)) - (1 ## "lux;Some" - (4 1) - (0))))))) -(_lux_export Maybe) -(_lux_declare-tags [#None #Some] Maybe) - -## (deftype #rec Type -## (| (#DataT (, Text (List Type))) -## (#VariantT (List Type)) -## (#TupleT (List Type)) -## (#LambdaT Type Type) -## (#BoundT Int) -## (#VarT Int) -## (#ExT Int) -## (#UnivQ (List Type) Type) -## (#ExQ (List Type) Type) -## (#AppT Type Type) -## (#NamedT Ident Type) -## )) -(_lux_def Type - (10 ["lux" "Type"] - (_lux_case (9 (4 0) (4 1)) - Type - (_lux_case (9 List Type) - TypeList - (9 (7 (0) - (1 (1 ## "lux;DataT" - (2 (1 Text (1 TypeList (0)))) - (1 ## "lux;VariantT" - TypeList - (1 ## "lux;TupleT" - TypeList - (1 ## "lux;LambdaT" - (2 (1 Type (1 Type (0)))) - (1 ## "lux;BoundT" - Int - (1 ## "lux;VarT" - Int - (1 ## "lux;ExT" - Int - (1 ## "lux;UnivQ" - (2 (1 TypeList (1 Type (0)))) - (1 ## "lux;ExQ" - (2 (1 TypeList (1 Type (0)))) - (1 ## "lux;AppT" - (2 (1 Type (1 Type (0)))) - (1 ## "lux;NamedT" - (2 (1 Ident (1 Type (0)))) - (0)))))))))))))) - Void))))) -(_lux_export Type) -(_lux_declare-tags [#DataT #VariantT #TupleT #LambdaT #BoundT #VarT #ExT #UnivQ #ExQ #AppT #NamedT] Type) - -## (deftype (Bindings k v) -## (& #counter Int -## #mappings (List (, k v)))) -(_lux_def Bindings - (#NamedT ["lux" "Bindings"] - (#UnivQ #Nil - (#UnivQ #Nil - (#TupleT (#Cons ## "lux;counter" - Int - (#Cons ## "lux;mappings" - (#AppT List - (#TupleT (#Cons (#BoundT 3) - (#Cons (#BoundT 1) - #Nil)))) - #Nil))))))) -(_lux_export Bindings) -(_lux_declare-tags [#counter #mappings] Bindings) - -## (deftype (Env k v) -## (& #name Text -## #inner-closures Int -## #locals (Bindings k v) -## #closure (Bindings k v))) -(_lux_def Env - (#NamedT ["lux" "Env"] - (#UnivQ #Nil - (#UnivQ #Nil - (#TupleT (#Cons ## "lux;name" - Text - (#Cons ## "lux;inner-closures" - Int - (#Cons ## "lux;locals" - (#AppT (#AppT Bindings (#BoundT 3)) - (#BoundT 1)) - (#Cons ## "lux;closure" - (#AppT (#AppT Bindings (#BoundT 3)) - (#BoundT 1)) - #Nil))))))))) -(_lux_export Env) -(_lux_declare-tags [#name #inner-closures #locals #closure] Env) - -## (deftype Cursor -## (& #module Text -## #line Int -## #column Int)) -(_lux_def Cursor - (#NamedT ["lux" "Cursor"] - (#TupleT (#Cons Text (#Cons Int (#Cons Int #Nil)))))) -(_lux_export Cursor) -(_lux_declare-tags [#module #line #column] Cursor) - -## (deftype (Meta m v) -## (& #meta m -## #datum v)) -(_lux_def Meta - (#NamedT ["lux" "Meta"] - (#UnivQ #Nil - (#UnivQ #Nil - (#TupleT (#Cons (#BoundT 3) - (#Cons (#BoundT 1) - #Nil))))))) -(_lux_export Meta) -(_lux_declare-tags [#meta #datum] Meta) - -## (deftype (AST' w) -## (| (#BoolS Bool) -## (#IntS Int) -## (#RealS Real) -## (#CharS Char) -## (#TextS Text) -## (#SymbolS Text Text) -## (#TagS Text Text) -## (#FormS (List (w (AST' w)))) -## (#TupleS (List (w (AST' w)))) -## (#RecordS (List (, (w (AST' w)) (w (AST' w))))))) -(_lux_def AST' - (#NamedT ["lux" "AST'"] - (_lux_case (#AppT (#BoundT 1) - (#AppT (#BoundT 0) - (#BoundT 1))) - AST - (_lux_case (#AppT [List AST]) - ASTList - (#UnivQ #Nil - (#VariantT (#Cons ## "lux;BoolS" - Bool - (#Cons ## "lux;IntS" - Int - (#Cons ## "lux;RealS" - Real - (#Cons ## "lux;CharS" - Char - (#Cons ## "lux;TextS" - Text - (#Cons ## "lux;SymbolS" - Ident - (#Cons ## "lux;TagS" - Ident - (#Cons ## "lux;FormS" - ASTList - (#Cons ## "lux;TupleS" - ASTList - (#Cons ## "lux;RecordS" - (#AppT List (#TupleT (#Cons AST (#Cons AST #Nil)))) - #Nil) - ))))))))) - )))))) -(_lux_export AST') -(_lux_declare-tags [#BoolS #IntS #RealS #CharS #TextS #SymbolS #TagS #FormS #TupleS #RecordS] AST') - -## (deftype AST -## (Meta Cursor (AST' (Meta Cursor)))) -(_lux_def AST - (#NamedT ["lux" "AST"] - (_lux_case (#AppT Meta Cursor) - w - (#AppT w (#AppT AST' w))))) -(_lux_export AST) - -(_lux_def ASTList (#AppT List AST)) - -## (deftype (Either l r) -## (| (#Left l) -## (#Right r))) -(_lux_def Either - (#NamedT ["lux" "Either"] - (#UnivQ #Nil - (#UnivQ #Nil - (#VariantT (#Cons ## "lux;Left" - (#BoundT 3) - (#Cons ## "lux;Right" - (#BoundT 1) - #Nil))))))) -(_lux_export Either) -(_lux_declare-tags [#Left #Right] Either) - -## (deftype (StateE s a) -## (-> s (Either Text (, s a)))) -(_lux_def StateE - (#UnivQ #Nil - (#UnivQ #Nil - (#LambdaT (#BoundT 3) - (#AppT (#AppT Either Text) - (#TupleT (#Cons (#BoundT 3) - (#Cons (#BoundT 1) - #Nil)))))))) - -## (deftype Source -## (List (Meta Cursor Text))) -(_lux_def Source - (#NamedT ["lux" "Source"] - (#AppT [List - (#AppT [(#AppT [Meta Cursor]) - Text])]))) -(_lux_export Source) - -## (deftype (DefData' m) -## (| (#TypeD Type) -## (#ValueD (, Type Unit)) -## (#MacroD m) -## (#AliasD Ident))) -(_lux_def DefData' - (#NamedT ["lux" "DefData'"] - (#UnivQ #Nil - (#VariantT (#Cons ## "lux;ValueD" - (#TupleT (#Cons Type (#Cons Unit #Nil))) - (#Cons ## "lux;TypeD" - Type - (#Cons ## "lux;MacroD" - (#BoundT 1) - (#Cons ## "lux;AliasD" - Ident - #Nil)))))))) -(_lux_export DefData') - -(_lux_def Analysis - (#NamedT ["lux" "Analysis"] - Void)) -(_lux_export Analysis) - -## (deftype (Module Compiler) -## (& #module-aliases (List (, Text Text)) -## #defs (List (, Text (, Bool (DefData' (-> (List AST) (StateE Compiler (List AST))))))) -## #imports (List Text) -## #tags (List (, Text (, Int (List Ident) Type))) -## #types (List (, Text (, (List Ident) Type))) -## )) -(_lux_def Module - (#NamedT ["lux" "Module"] - (#UnivQ #Nil - (#TupleT (#Cons ## "lux;module-aliases" - (#AppT List (#TupleT (#Cons Text (#Cons Text #Nil)))) - (#Cons ## "lux;defs" - (#AppT List (#TupleT (#Cons Text - (#Cons (#TupleT (#Cons Bool (#Cons (#AppT DefData' (#LambdaT ASTList - (#AppT (#AppT StateE (#BoundT 1)) - ASTList))) - #Nil))) - #Nil)))) - (#Cons ## "lux;imports" - (#AppT List Text) - (#Cons ## "lux;tags" - (#AppT List - (#TupleT (#Cons Text - (#Cons (#TupleT (#Cons Int - (#Cons (#AppT List Ident) - (#Cons Type - #Nil)))) - #Nil)))) - (#Cons ## "lux;types" - (#AppT List - (#TupleT (#Cons Text - (#Cons (#TupleT (#Cons (#AppT List Ident) - (#Cons Type - #Nil))) - #Nil)))) - #Nil))))))))) -(_lux_export Module) -(_lux_declare-tags [#module-aliases #defs #imports #tags #types] Module) - -## (deftype #rec Compiler -## (& #source Source -## #cursor Cursor -## #modules (List (, Text (Module Compiler))) -## #envs (List (Env Text (Meta (, Type Cursor) Analysis))) -## #type-vars (Bindings Int Type) -## #expected Type -## #seed Int -## #eval? Bool -## #host Void -## )) -(_lux_def Compiler - (#NamedT ["lux" "Compiler"] - (#AppT (#UnivQ #Nil - (#TupleT (#Cons ## "lux;source" - Source - (#Cons ## "lux;cursor" - Cursor - (#Cons ## "lux;modules" - (#AppT List (#TupleT (#Cons Text - (#Cons (#AppT Module (#AppT (#BoundT 0) (#BoundT 1))) - #Nil)))) - (#Cons ## "lux;envs" - (#AppT List (#AppT (#AppT Env Text) - (#AppT (#AppT Meta - (#TupleT (#Cons Type (#Cons Cursor #Nil)))) - Analysis))) - (#Cons ## "lux;type-vars" - (#AppT (#AppT Bindings Int) Type) - (#Cons ## "lux;expected" - Type - (#Cons ## "lux;seed" - Int - (#Cons ## "lux;eval?" - Bool - (#Cons ## "lux;host" - Void - #Nil))))))))))) - Void))) -(_lux_export Compiler) -(_lux_declare-tags [#source #cursor #modules #envs #type-vars #expected #seed #eval? #host] Compiler) - -## (deftype Macro -## (-> (List AST) (StateE Compiler (List AST)))) -(_lux_def Macro - (#NamedT ["lux" "Macro"] - (#LambdaT ASTList - (#AppT (#AppT StateE Compiler) - ASTList)))) -(_lux_export Macro) - -(_lux_def DefData - (#NamedT ["lux" "DefData"] - (#AppT DefData' Macro))) -(_lux_export DefData) -(_lux_declare-tags [#ValueD #TypeD #MacroD #AliasD] DefData) - -(_lux_def Definition - (#NamedT ["lux" "Definition"] - (#AppT (#AppT Meta Bool) DefData))) -(_lux_export Definition) - -## Base functions & macros -## (def _cursor -## Cursor -## ["" -1 -1]) -(_lux_def _cursor - (_lux_: Cursor ["" -1 -1])) - -## (def (_meta data) -## (-> (AST' (Meta Cursor)) AST) -## [["" -1 -1] data]) -(_lux_def _meta - (_lux_: (#LambdaT (#AppT AST' - (#AppT Meta Cursor)) - AST) - (_lux_lambda _ data - [_cursor data]))) - -## (def (return x) -## (All [a] -## (-> a Compiler -## (Either Text (, Compiler a)))) -## ...) -(_lux_def return - (_lux_: (#UnivQ #Nil - (#LambdaT (#BoundT 1) - (#LambdaT Compiler - (#AppT (#AppT Either Text) - (#TupleT (#Cons Compiler - (#Cons (#BoundT 1) - #Nil))))))) - (_lux_lambda _ val - (_lux_lambda _ state - (#Right state val))))) - -## (def (fail msg) -## (All [a] -## (-> Text Compiler -## (Either Text (, Compiler a)))) -## ...) -(_lux_def fail - (_lux_: (#UnivQ #Nil - (#LambdaT Text - (#LambdaT Compiler - (#AppT (#AppT Either Text) - (#TupleT (#Cons Compiler - (#Cons (#BoundT 1) - #Nil))))))) - (_lux_lambda _ msg - (_lux_lambda _ state - (#Left msg))))) - -(_lux_def bool$ - (_lux_: (#LambdaT Bool AST) - (_lux_lambda _ value - (_meta (#BoolS value))))) - -(_lux_def int$ - (_lux_: (#LambdaT Int AST) - (_lux_lambda _ value - (_meta (#IntS value))))) - -(_lux_def real$ - (_lux_: (#LambdaT Real AST) - (_lux_lambda _ value - (_meta (#RealS value))))) - -(_lux_def char$ - (_lux_: (#LambdaT Char AST) - (_lux_lambda _ value - (_meta (#CharS value))))) - -(_lux_def text$ - (_lux_: (#LambdaT Text AST) - (_lux_lambda _ text - (_meta (#TextS text))))) - -(_lux_def symbol$ - (_lux_: (#LambdaT Ident AST) - (_lux_lambda _ ident - (_meta (#SymbolS ident))))) - -(_lux_def tag$ - (_lux_: (#LambdaT Ident AST) - (_lux_lambda _ ident - (_meta (#TagS ident))))) - -(_lux_def form$ - (_lux_: (#LambdaT (#AppT List AST) AST) - (_lux_lambda _ tokens - (_meta (#FormS tokens))))) - -(_lux_def tuple$ - (_lux_: (#LambdaT (#AppT List AST) AST) - (_lux_lambda _ tokens - (_meta (#TupleS tokens))))) - -(_lux_def record$ - (_lux_: (#LambdaT (#AppT List (#TupleT (#Cons AST (#Cons AST #Nil)))) AST) - (_lux_lambda _ tokens - (_meta (#RecordS tokens))))) - -(_lux_def let'' - (_lux_: Macro - (_lux_lambda _ tokens - (_lux_case tokens - (#Cons lhs (#Cons rhs (#Cons body #Nil))) - (return (#Cons (form$ (#Cons (symbol$ ["" "_lux_case"]) - (#Cons rhs (#Cons lhs (#Cons body #Nil))))) - #Nil)) - - _ - (fail "Wrong syntax for let''"))))) -(_lux_declare-macro let'') - -(_lux_def lambda'' - (_lux_: Macro - (_lux_lambda _ tokens - (_lux_case tokens - (#Cons [_ (#TupleS (#Cons arg args'))] (#Cons body #Nil)) - (return (#Cons (_meta (#FormS (#Cons (_meta (#SymbolS "" "_lux_lambda")) - (#Cons (_meta (#SymbolS "" "")) - (#Cons arg - (#Cons (_lux_case args' - #Nil - body - - _ - (_meta (#FormS (#Cons (_meta (#SymbolS "lux" "lambda''")) - (#Cons (_meta (#TupleS args')) - (#Cons body #Nil)))))) - #Nil)))))) - #Nil)) - - (#Cons [_ (#SymbolS "" self)] (#Cons [_ (#TupleS (#Cons arg args'))] (#Cons body #Nil))) - (return (#Cons (_meta (#FormS (#Cons (_meta (#SymbolS "" "_lux_lambda")) - (#Cons (_meta (#SymbolS "" self)) - (#Cons arg - (#Cons (_lux_case args' - #Nil - body - - _ - (_meta (#FormS (#Cons (_meta (#SymbolS "lux" "lambda''")) - (#Cons (_meta (#TupleS args')) - (#Cons body #Nil)))))) - #Nil)))))) - #Nil)) - - _ - (fail "Wrong syntax for lambda''"))))) -(_lux_declare-macro lambda'') - -(_lux_def def'' - (_lux_: Macro - (lambda'' [tokens] - (_lux_case tokens - (#Cons [[_ (#TagS ["" "export"])] - (#Cons [[_ (#FormS (#Cons [name args]))] - (#Cons [type (#Cons [body #Nil])])])]) - (return (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_def"])) - (#Cons [name - (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_:"])) - (#Cons [type - (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "lambda''"])) - (#Cons [name - (#Cons [(_meta (#TupleS args)) - (#Cons [body #Nil])])])]))) - #Nil])])]))) - #Nil])])]))) - (#Cons [(_meta (#FormS (#Cons [(symbol$ ["" "_lux_export"]) (#Cons [name #Nil])]))) - #Nil])])) - - (#Cons [[_ (#TagS ["" "export"])] (#Cons [name (#Cons [type (#Cons [body #Nil])])])]) - (return (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_def"])) - (#Cons [name - (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_:"])) - (#Cons [type - (#Cons [body - #Nil])])]))) - #Nil])])]))) - (#Cons [(_meta (#FormS (#Cons [(symbol$ ["" "_lux_export"]) (#Cons [name #Nil])]))) - #Nil])])) - - (#Cons [[_ (#FormS (#Cons [name args]))] - (#Cons [type (#Cons [body #Nil])])]) - (return (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_def"])) - (#Cons [name - (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_:"])) - (#Cons [type - (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "lambda''"])) - (#Cons [name - (#Cons [(_meta (#TupleS args)) - (#Cons [body #Nil])])])]))) - #Nil])])]))) - #Nil])])]))) - #Nil])) - - (#Cons [name (#Cons [type (#Cons [body #Nil])])]) - (return (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_def"])) - (#Cons [name - (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_:"])) - (#Cons [type - (#Cons [body - #Nil])])]))) - #Nil])])]))) - #Nil])) - - _ - (fail "Wrong syntax for def''")) - ))) -(_lux_declare-macro def'') - -(def'' (defmacro' tokens) - Macro - (_lux_case tokens - (#Cons [[_ (#FormS (#Cons [name args]))] (#Cons [body #Nil])]) - (return (#Cons [(form$ (#Cons [(symbol$ ["lux" "def''"]) - (#Cons [(form$ (#Cons [name args])) - (#Cons [(symbol$ ["lux" "Macro"]) - (#Cons [body - #Nil])]) - ])])) - (#Cons [(form$ (#Cons [(symbol$ ["" "_lux_declare-macro"]) (#Cons [name #Nil])])) - #Nil])])) - - (#Cons [[_ (#TagS ["" "export"])] (#Cons [[_ (#FormS (#Cons [name args]))] (#Cons [body #Nil])])]) - (return (#Cons [(form$ (#Cons [(symbol$ ["lux" "def''"]) - (#Cons [(tag$ ["" "export"]) - (#Cons [(form$ (#Cons [name args])) - (#Cons [(symbol$ ["lux" "Macro"]) - (#Cons [body - #Nil])]) - ])])])) - (#Cons [(form$ (#Cons [(symbol$ ["" "_lux_declare-macro"]) (#Cons [name #Nil])])) - #Nil])])) - - _ - (fail "Wrong syntax for defmacro'"))) -(_lux_declare-macro defmacro') - -(defmacro' #export (comment tokens) - (return #Nil)) - -(defmacro' ($' tokens) - (_lux_case tokens - (#Cons x #Nil) - (return tokens) - - (#Cons x (#Cons y xs)) - (return (#Cons (form$ (#Cons (symbol$ ["lux" "$'"]) - (#Cons (form$ (#Cons (tag$ ["lux" "AppT"]) - (#Cons x (#Cons y #Nil)))) - xs))) - #Nil)) - - _ - (fail "Wrong syntax for $'"))) - -(def'' (map f xs) - (#UnivQ #Nil - (#UnivQ #Nil - (#LambdaT (#LambdaT (#BoundT 3) (#BoundT 1)) - (#LambdaT ($' List (#BoundT 3)) - ($' List (#BoundT 1)))))) - (_lux_case xs - #Nil - #Nil - - (#Cons x xs') - (#Cons (f x) (map f xs')))) - -(def'' RepEnv - Type - ($' List (#TupleT (#Cons Text (#Cons AST #Nil))))) - -(def'' (make-env xs ys) - (#LambdaT ($' List Text) (#LambdaT ($' List AST) RepEnv)) - (_lux_case [xs ys] - [(#Cons x xs') (#Cons y ys')] - (#Cons [x y] (make-env xs' ys')) - - _ - #Nil)) - -(def'' (text:= x y) - (#LambdaT Text (#LambdaT Text Bool)) - (_jvm_invokevirtual "java.lang.Object" "equals" ["java.lang.Object"] - x [y])) - -(def'' (get-rep key env) - (#LambdaT Text (#LambdaT RepEnv ($' Maybe AST))) - (_lux_case env - #Nil - #None - - (#Cons [k v] env') - (_lux_case (text:= k key) - true - (#Some v) - - false - (get-rep key env')))) - -(def'' (replace-syntax reps syntax) - (#LambdaT RepEnv (#LambdaT AST AST)) - (_lux_case syntax - [_ (#SymbolS "" name)] - (_lux_case (get-rep name reps) - (#Some replacement) - replacement - - #None - syntax) - - [meta (#FormS parts)] - [meta (#FormS (map (replace-syntax reps) parts))] - - [meta (#TupleS members)] - [meta (#TupleS (map (replace-syntax reps) members))] - - [meta (#RecordS slots)] - [meta (#RecordS (map (_lux_: (#LambdaT (#TupleT (#Cons AST (#Cons AST #Nil))) (#TupleT (#Cons AST (#Cons AST #Nil)))) - (lambda'' [slot] - (_lux_case slot - [k v] - [(replace-syntax reps k) (replace-syntax reps v)]))) - slots))] - - _ - syntax) - ) - -(def'' (update-bounds ast) - (#LambdaT AST AST) - (_lux_case ast - [_ (#BoolS value)] - (bool$ value) - - [_ (#IntS value)] - (int$ value) - - [_ (#RealS value)] - (real$ value) - - [_ (#CharS value)] - (char$ value) - - [_ (#TextS value)] - (text$ value) - - [_ (#SymbolS value)] - (symbol$ value) - - [_ (#TagS value)] - (tag$ value) - - [_ (#TupleS members)] - (tuple$ (map update-bounds members)) - - [_ (#RecordS pairs)] - (record$ (map (_lux_: (#LambdaT (#TupleT (#Cons AST (#Cons AST #Nil))) (#TupleT (#Cons AST (#Cons AST #Nil)))) - (lambda'' [pair] - (let'' [name val] pair - [name (update-bounds val)]))) - pairs)) - - [_ (#FormS (#Cons [_ (#TagS "lux" "BoundT")] (#Cons [_ (#IntS idx)] #Nil)))] - (form$ (#Cons (tag$ ["lux" "BoundT"]) (#Cons (int$ (_jvm_ladd 2 idx)) #Nil))) - - [_ (#FormS members)] - (form$ (map update-bounds members))) - ) - -(def'' (parse-univq-args args next) - ## (All [a] (-> (List AST) (-> (List Text) (Lux a)) (Lux a))) - (#UnivQ #Nil (#LambdaT ($' List AST) - (#LambdaT (#LambdaT ($' List Text) (#AppT (#AppT StateE Compiler) (#BoundT 1))) - (#AppT (#AppT StateE Compiler) (#BoundT 1))))) - (_lux_case args - #Nil - (next #Nil) - - (#Cons [_ (#SymbolS "" arg-name)] args') - (parse-univq-args args' (lambda'' [names] (next (#Cons arg-name names)))) - - _ - (fail "Expected symbol."))) - -(def'' (make-bound idx) - (#LambdaT Int AST) - (form$ (#Cons (tag$ ["lux" "BoundT"]) (#Cons (int$ idx) #Nil)))) - -(def'' (foldL f init xs) - ## (All [a b] (-> (-> a b a) a (List b) a)) - (#UnivQ #Nil (#UnivQ #Nil (#LambdaT (#LambdaT (#BoundT 3) - (#LambdaT (#BoundT 1) - (#BoundT 3))) - (#LambdaT (#BoundT 3) - (#LambdaT ($' List (#BoundT 1)) - (#BoundT 3)))))) - (_lux_case xs - #Nil - init - - (#Cons x xs') - (foldL f (f init x) xs'))) - -(defmacro' #export (All tokens) - (let'' [self-name tokens] (_lux_case tokens - (#Cons [_ (#SymbolS "" self-name)] tokens) - [self-name tokens] - - _ - ["" tokens]) - (_lux_case tokens - (#Cons [_ (#TupleS args)] (#Cons body #Nil)) - (parse-univq-args args - (lambda'' [names] - (let'' body' (foldL (_lux_: (#LambdaT AST (#LambdaT Text AST)) - (lambda'' [body' name'] - (form$ (#Cons (tag$ ["lux" "UnivQ"]) - (#Cons (tag$ ["lux" "Nil"]) - (#Cons (replace-syntax (#Cons [name' (make-bound 1)] #Nil) - (update-bounds body')) #Nil)))))) - (replace-syntax (#Cons [self-name (make-bound -2)] #Nil) - body) - names) - (return (#Cons body' #Nil))))) - - _ - (fail "Wrong syntax for All")) - )) - -(defmacro' #export (Ex tokens) - (let'' [self-name tokens] (_lux_case tokens - (#Cons [_ (#SymbolS "" self-name)] tokens) - [self-name tokens] - - _ - ["" tokens]) - (_lux_case tokens - (#Cons [_ (#TupleS args)] (#Cons body #Nil)) - (parse-univq-args args - (lambda'' [names] - (let'' body' (foldL (_lux_: (#LambdaT AST (#LambdaT Text AST)) - (lambda'' [body' name'] - (form$ (#Cons (tag$ ["lux" "ExQ"]) - (#Cons (tag$ ["lux" "Nil"]) - (#Cons (replace-syntax (#Cons [name' (make-bound 1)] #Nil) - (update-bounds body')) #Nil)))))) - (replace-syntax (#Cons [self-name (make-bound -2)] #Nil) - body) - names) - (return (#Cons body' #Nil))))) - - _ - (fail "Wrong syntax for Ex")) - )) - -(def'' (reverse list) - (All [a] (#LambdaT ($' List a) ($' List a))) - (foldL (lambda'' [tail head] (#Cons head tail)) - #Nil - list)) - -(defmacro' #export (-> tokens) - (_lux_case (reverse tokens) - (#Cons output inputs) - (return (#Cons (foldL (_lux_: (#LambdaT AST (#LambdaT AST AST)) - (lambda'' [o i] (form$ (#Cons (tag$ ["lux" "LambdaT"]) (#Cons i (#Cons o #Nil)))))) - output - inputs) - #Nil)) - - _ - (fail "Wrong syntax for ->"))) - -(defmacro' (@list xs) - (return (#Cons (foldL (lambda'' [tail head] - (form$ (#Cons (tag$ ["lux" "Cons"]) - (#Cons (tuple$ (#Cons [head (#Cons [tail #Nil])])) - #Nil)))) - (tag$ ["lux" "Nil"]) - (reverse xs)) - #Nil))) - -(defmacro' (@list& xs) - (_lux_case (reverse xs) - (#Cons last init) - (return (@list (foldL (lambda'' [tail head] - (form$ (@list (tag$ ["lux" "Cons"]) - (tuple$ (@list head tail))))) - last - init))) - - _ - (fail "Wrong syntax for @list&"))) - -(defmacro' #export (, tokens) - (return (@list (form$ (@list (tag$ ["lux" "TupleT"]) - (foldL (lambda'' [tail head] (form$ (@list (tag$ ["lux" "Cons"]) head tail))) - (tag$ ["lux" "Nil"]) - (reverse tokens))))))) - -(defmacro' (lambda' tokens) - (let'' [name tokens'] (_lux_case tokens - (#Cons [[_ (#SymbolS ["" name])] tokens']) - [name tokens'] - - _ - ["" tokens]) - (_lux_case tokens' - (#Cons [[_ (#TupleS args)] (#Cons [body #Nil])]) - (_lux_case args - #Nil - (fail "lambda' requires a non-empty arguments tuple.") - - (#Cons [harg targs]) - (return (@list (form$ (@list (symbol$ ["" "_lux_lambda"]) - (symbol$ ["" name]) - harg - (foldL (lambda'' [body' arg] - (form$ (@list (symbol$ ["" "_lux_lambda"]) - (symbol$ ["" ""]) - arg - body'))) - body - (reverse targs))))))) - - _ - (fail "Wrong syntax for lambda'")))) - -(defmacro' (def''' tokens) - (_lux_case tokens - (#Cons [[_ (#TagS ["" "export"])] - (#Cons [[_ (#FormS (#Cons [name args]))] - (#Cons [type (#Cons [body #Nil])])])]) - (return (@list (form$ (@list (symbol$ ["" "_lux_def"]) - name - (form$ (@list (symbol$ ["" "_lux_:"]) - type - (form$ (@list (symbol$ ["lux" "lambda'"]) - name - (tuple$ args) - body)))))) - (form$ (@list (symbol$ ["" "_lux_export"]) name)))) - - (#Cons [[_ (#TagS ["" "export"])] (#Cons [name (#Cons [type (#Cons [body #Nil])])])]) - (return (@list (form$ (@list (symbol$ ["" "_lux_def"]) - name - (form$ (@list (symbol$ ["" "_lux_:"]) - type - body)))) - (form$ (@list (symbol$ ["" "_lux_export"]) name)))) - - (#Cons [[_ (#FormS (#Cons [name args]))] - (#Cons [type (#Cons [body #Nil])])]) - (return (@list (form$ (@list (symbol$ ["" "_lux_def"]) - name - (form$ (@list (symbol$ ["" "_lux_:"]) - type - (form$ (@list (symbol$ ["lux" "lambda'"]) - name - (tuple$ args) - body)))))))) - - (#Cons [name (#Cons [type (#Cons [body #Nil])])]) - (return (@list (form$ (@list (symbol$ ["" "_lux_def"]) - name - (form$ (@list (symbol$ ["" "_lux_:"]) type body)))))) - - _ - (fail "Wrong syntax for def'") - )) - -(def''' (as-pairs xs) - (All [a] (-> ($' List a) ($' List (, a a)))) - (_lux_case xs - (#Cons x (#Cons y xs')) - (#Cons [x y] (as-pairs xs')) - - _ - #Nil)) - -(defmacro' (let' tokens) - (_lux_case tokens - (#Cons [[_ (#TupleS bindings)] (#Cons [body #Nil])]) - (return (@list (foldL (_lux_: (-> AST (, AST AST) - AST) - (lambda' [body binding] - (_lux_case binding - [label value] - (form$ (@list (symbol$ ["" "_lux_case"]) value label body))))) - body - (reverse (as-pairs bindings))))) - - _ - (fail "Wrong syntax for let'"))) - -(def''' (any? p xs) - (All [a] - (-> (-> a Bool) ($' List a) Bool)) - (_lux_case xs - #Nil - false - - (#Cons x xs') - (_lux_case (p x) - true true - false (any? p xs')))) - -(def''' (spliced? token) - (-> AST Bool) - (_lux_case token - [_ (#FormS (#Cons [[_ (#SymbolS ["" "~@"])] (#Cons [_ #Nil])]))] - true - - _ - false)) - -(def''' (wrap-meta content) - (-> AST AST) - (tuple$ (@list (tuple$ (@list (text$ "") (int$ -1) (int$ -1))) - content))) - -(def''' (untemplate-list tokens) - (-> ($' List AST) AST) - (_lux_case tokens - #Nil - (_meta (#TagS ["lux" "Nil"])) - - (#Cons [token tokens']) - (_meta (#FormS (@list (_meta (#TagS ["lux" "Cons"])) token (untemplate-list tokens')))))) - -(def''' (list:++ xs ys) - (All [a] (-> ($' List a) ($' List a) ($' List a))) - (_lux_case xs - (#Cons x xs') - (#Cons x (list:++ xs' ys)) - - #Nil - ys)) - -(def''' #export (splice-helper xs ys) - (-> ($' List AST) ($' List AST) ($' List AST)) - (_lux_case xs - (#Cons x xs') - (#Cons x (splice-helper xs' ys)) - - #Nil - ys)) - -(defmacro' #export ($ tokens) - (_lux_case tokens - (#Cons op (#Cons init args)) - (return (@list (foldL (lambda' [a1 a2] (form$ (@list op a1 a2))) - init - args))) - - _ - (fail "Wrong syntax for $"))) - -## (deftype (Lux a) -## (-> Compiler (Either Text (, Compiler a)))) -(def''' #export Lux - Type - (#NamedT ["lux" "Lux"] - (All [a] - (-> Compiler ($' Either Text (, Compiler a)))))) - -## (defsig (Monad m) -## (: (All [a] (-> a (m a))) -## return) -## (: (All [a b] (-> (-> a (m b)) (m a) (m b))) -## bind)) -(def''' Monad - Type - (#NamedT ["lux" "Monad"] - (All [m] - (, (All [a] (-> a ($' m a))) - (All [a b] (-> (-> a ($' m b)) - ($' m a) - ($' m b))))))) -(_lux_declare-tags [#return #bind] Monad) - -(def''' Maybe/Monad - ($' Monad Maybe) - {#return - (lambda' return [x] - (#Some x)) - - #bind - (lambda' [f ma] - (_lux_case ma - #None #None - (#Some a) (f a)))}) - -(def''' Lux/Monad - ($' Monad Lux) - {#return - (lambda' [x] - (lambda' [state] - (#Right state x))) - - #bind - (lambda' [f ma] - (lambda' [state] - (_lux_case (ma state) - (#Left msg) - (#Left msg) - - (#Right state' a) - (f a state'))))}) - -(defmacro' (do tokens) - (_lux_case tokens - (#Cons monad (#Cons [_ (#TupleS bindings)] (#Cons body #Nil))) - (let' [g!wrap (symbol$ ["" "wrap"]) - g!bind (symbol$ ["" "12bind34"]) - body' (foldL (_lux_: (-> AST (, AST AST) AST) - (lambda' [body' binding] - (let' [[var value] binding] - (_lux_case var - [_ (#TagS "" "let")] - (form$ (@list (symbol$ ["lux" "let'"]) value body')) - - _ - (form$ (@list g!bind - (form$ (@list (symbol$ ["" "_lux_lambda"]) (symbol$ ["" ""]) var body')) - value)))))) - body - (reverse (as-pairs bindings)))] - (return (@list (form$ (@list (symbol$ ["" "_lux_case"]) - monad - (record$ (@list [(tag$ ["lux" "return"]) g!wrap] [(tag$ ["lux" "bind"]) g!bind])) - body'))))) - - _ - (fail "Wrong syntax for do"))) - -(def''' (map% m f xs) - ## (All [m a b] - ## (-> (Monad m) (-> a (m b)) (List a) (m (List b)))) - (All [m a b] - (-> ($' Monad m) - (-> a ($' m b)) - ($' List a) - ($' m ($' List b)))) - (let' [{#;return wrap #;bind _} m] - (_lux_case xs - #Nil - (wrap #Nil) - - (#Cons x xs') - (do m - [y (f x) - ys (map% m f xs')] - (wrap (#Cons y ys))) - ))) - -(defmacro' #export (if tokens) - (_lux_case tokens - (#Cons test (#Cons then (#Cons else #Nil))) - (return (@list (form$ (@list (symbol$ ["" "_lux_case"]) test - (bool$ true) then - (bool$ false) else)))) - - _ - (fail "Wrong syntax for if"))) - -(def''' (get k plist) - (All [a] - (-> Text ($' List (, Text a)) ($' Maybe a))) - (_lux_case plist - (#Cons [[k' v] plist']) - (if (text:= k k') - (#Some v) - (get k plist')) - - #Nil - #None)) - -(def''' (put k v dict) - (All [a] - (-> Text a ($' List (, Text a)) ($' List (, Text a)))) - (_lux_case dict - #Nil - (@list [k v]) - - (#Cons [[k' v'] dict']) - (if (text:= k k') - (#Cons [[k' v] dict']) - (#Cons [[k' v'] (put k v dict')])))) - -(def''' (text:++ x y) - (-> Text Text Text) - (_jvm_invokevirtual "java.lang.String" "concat" ["java.lang.String"] - x [y])) - -(def''' (ident->text ident) - (-> Ident Text) - (let' [[module name] ident] - ($ text:++ module ";" name))) - -(def''' (resolve-global-symbol ident state) - (-> Ident ($' Lux Ident)) - (let' [[module name] ident - {#source source #modules modules - #envs envs #type-vars types #host host - #seed seed #eval? eval? #expected expected - #cursor cursor} state] - (_lux_case (get module modules) - (#Some {#module-aliases _ #defs defs #imports _ #tags tags #types types}) - (_lux_case (get name defs) - (#Some [_ def-data]) - (_lux_case def-data - (#AliasD real-name) - (#Right [state real-name]) - - _ - (#Right [state ident])) - - #None - (#Left ($ text:++ "Unknown definition: " (ident->text ident)))) - - #None - (#Left ($ text:++ "Unknown module: " module " @ " (ident->text ident)))))) - -(def''' (splice replace? untemplate tag elems) - (-> Bool (-> AST ($' Lux AST)) AST ($' List AST) ($' Lux AST)) - (_lux_case replace? - true - (_lux_case (any? spliced? elems) - true - (do Lux/Monad - [elems' (_lux_: ($' Lux ($' List AST)) - (map% Lux/Monad - (_lux_: (-> AST ($' Lux AST)) - (lambda' [elem] - (_lux_case elem - [_ (#FormS (#Cons [[_ (#SymbolS ["" "~@"])] (#Cons [spliced #Nil])]))] - (wrap spliced) - - _ - (do Lux/Monad - [=elem (untemplate elem)] - (wrap (form$ (@list (symbol$ ["" "_lux_:"]) - (form$ (@list (tag$ ["lux" "AppT"]) (tuple$ (@list (symbol$ ["lux" "List"]) (symbol$ ["lux" "AST"]))))) - (form$ (@list (tag$ ["lux" "Cons"]) (tuple$ (@list =elem (tag$ ["lux" "Nil"])))))))))))) - elems))] - (wrap (wrap-meta (form$ (@list tag - (form$ (@list& (symbol$ ["lux" "$"]) - (symbol$ ["lux" "splice-helper"]) - elems'))))))) - - false - (do Lux/Monad - [=elems (map% Lux/Monad untemplate elems)] - (wrap (wrap-meta (form$ (@list tag (untemplate-list =elems))))))) - false - (do Lux/Monad - [=elems (map% Lux/Monad untemplate elems)] - (wrap (wrap-meta (form$ (@list tag (untemplate-list =elems)))))))) - -(def''' (untemplate replace? subst token) - (-> Bool Text AST ($' Lux AST)) - (_lux_case [replace? token] - [_ [_ (#BoolS value)]] - (return (wrap-meta (form$ (@list (tag$ ["lux" "BoolS"]) (bool$ value))))) - - [_ [_ (#IntS value)]] - (return (wrap-meta (form$ (@list (tag$ ["lux" "IntS"]) (int$ value))))) - - [_ [_ (#RealS value)]] - (return (wrap-meta (form$ (@list (tag$ ["lux" "RealS"]) (real$ value))))) - - [_ [_ (#CharS value)]] - (return (wrap-meta (form$ (@list (tag$ ["lux" "CharS"]) (char$ value))))) - - [_ [_ (#TextS value)]] - (return (wrap-meta (form$ (@list (tag$ ["lux" "TextS"]) (text$ value))))) - - [_ [_ (#TagS [module name])]] - (let' [module' (_lux_case module - "" - subst - - _ - module)] - (return (wrap-meta (form$ (@list (tag$ ["lux" "TagS"]) (tuple$ (@list (text$ module') (text$ name)))))))) - - [true [_ (#SymbolS [module name])]] - (do Lux/Monad - [real-name (_lux_case module - "" - (resolve-global-symbol [subst name]) - - _ - (wrap [module name])) - #let [[module name] real-name]] - (return (wrap-meta (form$ (@list (tag$ ["lux" "SymbolS"]) (tuple$ (@list (text$ module) (text$ name)))))))) - - [false [_ (#SymbolS [module name])]] - (return (wrap-meta (form$ (@list (tag$ ["lux" "SymbolS"]) (tuple$ (@list (text$ module) (text$ name))))))) - - [_ [_ (#TupleS elems)]] - (splice replace? (untemplate replace? subst) (tag$ ["lux" "TupleS"]) elems) - - [true [_ (#FormS (#Cons [[_ (#SymbolS ["" "~"])] (#Cons [unquoted #Nil])]))]] - (return unquoted) - - [_ [meta (#FormS elems)]] - (do Lux/Monad - [output (splice replace? (untemplate replace? subst) (tag$ ["lux" "FormS"]) elems) - #let [[_ form'] output]] - (return [meta form'])) - - [_ [_ (#RecordS fields)]] - (do Lux/Monad - [=fields (map% Lux/Monad - (_lux_: (-> (, AST AST) ($' Lux AST)) - (lambda' [kv] - (let' [[k v] kv] - (do Lux/Monad - [=k (untemplate replace? subst k) - =v (untemplate replace? subst v)] - (wrap (tuple$ (@list =k =v))))))) - fields)] - (wrap (wrap-meta (form$ (@list (tag$ ["lux" "RecordS"]) (untemplate-list =fields)))))) - )) - -(defmacro' #export (^ tokens) - (_lux_case tokens - (#Cons [_ (#SymbolS "" class-name)] #Nil) - (return (@list (form$ (@list (tag$ ["lux" "DataT"]) (text$ class-name) (tag$ ["lux" "Nil"]))))) - - (#Cons [_ (#SymbolS "" class-name)] params) - (return (@list (form$ (@list (tag$ ["lux" "DataT"]) (text$ class-name) (untemplate-list params))))) - - _ - (fail "Wrong syntax for ^"))) - -(def'' (get-module-name state) - ($' Lux Text) - (_lux_case state - {#source source #modules modules - #envs envs #type-vars types #host host - #seed seed #eval? eval? #expected expected - #cursor cursor} - (_lux_case (reverse envs) - #Nil - (#Left "Can't get the module name without a module!") - - (#Cons {#name module-name #inner-closures _ #locals _ #closure _} _) - (#Right [state module-name])))) - -(defmacro' #export (` tokens) - (_lux_case tokens - (#Cons template #Nil) - (do Lux/Monad - [current-module get-module-name - =template (untemplate true current-module template)] - (wrap (@list (form$ (@list (symbol$ ["" "_lux_:"]) (symbol$ ["lux" "AST"]) =template))))) - - _ - (fail "Wrong syntax for `"))) - -(defmacro' #export (' tokens) - (_lux_case tokens - (#Cons template #Nil) - (do Lux/Monad - [=template (untemplate false "" template)] - (wrap (@list (form$ (@list (symbol$ ["" "_lux_:"]) (symbol$ ["lux" "AST"]) =template))))) - - _ - (fail "Wrong syntax for '"))) - -(defmacro' #export (|> tokens) - (_lux_case tokens - (#Cons [init apps]) - (return (@list (foldL (_lux_: (-> AST AST AST) - (lambda' [acc app] - (_lux_case app - [_ (#TupleS parts)] - (tuple$ (list:++ parts (@list acc))) - - [_ (#FormS parts)] - (form$ (list:++ parts (@list acc))) - - _ - (` ((~ app) (~ acc)))))) - init - apps))) - - _ - (fail "Wrong syntax for |>"))) - -(def''' (. f g) - (All [a b c] - (-> (-> b c) (-> a b) (-> a c))) - (lambda' [x] - (f (g x)))) - -(def''' (get-ident x) - (-> AST ($' Maybe Ident)) - (_lux_case x - [_ (#SymbolS sname)] - (#Some sname) - - _ - #None)) - -(def''' (get-tag x) - (-> AST ($' Maybe Ident)) - (_lux_case x - [_ (#TagS sname)] - (#Some sname) - - _ - #None)) - -(def''' (get-name x) - (-> AST ($' Maybe Text)) - (_lux_case x - [_ (#SymbolS "" sname)] - (#Some sname) - - _ - #None)) - -(def''' (tuple->list tuple) - (-> AST ($' Maybe ($' List AST))) - (_lux_case tuple - [_ (#TupleS members)] - (#Some members) - - _ - #None)) - -(def''' (apply-template env template) - (-> RepEnv AST AST) - (_lux_case template - [_ (#SymbolS "" sname)] - (_lux_case (get-rep sname env) - (#Some subst) - subst - - _ - template) - - [_ (#TupleS elems)] - (tuple$ (map (apply-template env) elems)) - - [_ (#FormS elems)] - (form$ (map (apply-template env) elems)) - - [_ (#RecordS members)] - (record$ (map (_lux_: (-> (, AST AST) (, AST AST)) - (lambda' [kv] - (let' [[slot value] kv] - [(apply-template env slot) (apply-template env value)]))) - members)) - - _ - template)) - -(def''' (join-map f xs) - (All [a b] - (-> (-> a ($' List b)) ($' List a) ($' List b))) - (_lux_case xs - #Nil - #Nil - - (#Cons [x xs']) - (list:++ (f x) (join-map f xs')))) - -(defmacro' #export (do-template tokens) - (_lux_case tokens - (#Cons [[_ (#TupleS bindings)] (#Cons [[_ (#TupleS templates)] data])]) - (_lux_case [(map% Maybe/Monad get-name bindings) - (map% Maybe/Monad tuple->list data)] - [(#Some bindings') (#Some data')] - (let' [apply (_lux_: (-> RepEnv ($' List AST)) - (lambda' [env] (map (apply-template env) templates)))] - (|> data' - (join-map (. apply (make-env bindings'))) - return)) - - _ - (fail "Wrong syntax for do-template")) - - _ - (fail "Wrong syntax for do-template"))) - -(do-template [<name> <cmp> <type>] - [(def''' (<name> x y) - (-> <type> <type> Bool) - (<cmp> x y))] - - [i= _jvm_leq Int] - [i> _jvm_lgt Int] - [i< _jvm_llt Int] - ) - -(do-template [<name> <cmp> <eq> <type>] - [(def''' (<name> x y) - (-> <type> <type> Bool) - (if (<cmp> x y) - true - (<eq> x y)))] - - [i>= i> i= Int] - [i<= i< i= Int] - ) - -(do-template [<name> <cmp> <type>] - [(def''' (<name> x y) - (-> <type> <type> <type>) - (<cmp> x y))] - - [i+ _jvm_ladd Int] - [i- _jvm_lsub Int] - [i* _jvm_lmul Int] - [i/ _jvm_ldiv Int] - [i% _jvm_lrem Int] - ) - -(def''' (multiple? div n) - (-> Int Int Bool) - (i= 0 (i% n div))) - -(def''' (length list) - (All [a] (-> ($' List a) Int)) - (foldL (lambda' [acc _] (_jvm_ladd 1 acc)) 0 list)) - -(def''' #export (not x) - (-> Bool Bool) - (if x false true)) - -(def''' (->text x) - (-> (^ java.lang.Object) Text) - (_jvm_invokevirtual "java.lang.Object" "toString" [] x [])) - -(def''' (find-macro' modules current-module module name) - (-> ($' List (, Text ($' Module Compiler))) - Text Text Text - ($' Maybe Macro)) - (do Maybe/Monad - [$module (get module modules) - gdef (let' [{#module-aliases _ #defs bindings #imports _ #tags tags #types types} (_lux_: ($' Module Compiler) $module)] - (get name bindings))] - (_lux_case (_lux_: Definition gdef) - [exported? (#MacroD macro')] - (if exported? - (#Some macro') - (if (text:= module current-module) - (#Some macro') - #None)) - - [_ (#AliasD [r-module r-name])] - (find-macro' modules current-module r-module r-name) - - _ - #None))) - -(def''' (normalize ident) - (-> Ident ($' Lux Ident)) - (_lux_case ident - ["" name] - (do Lux/Monad - [module-name get-module-name] - (wrap [module-name name])) - - _ - (return ident))) - -(def''' (find-macro ident) - (-> Ident ($' Lux ($' Maybe Macro))) - (do Lux/Monad - [current-module get-module-name] - (let' [[module name] ident] - (lambda' [state] - (_lux_case state - {#source source #modules modules - #envs envs #type-vars types #host host - #seed seed #eval? eval? #expected expected - #cursor cursor} - (#Right state (find-macro' modules current-module module name))))))) - -(def''' (macro? ident) - (-> Ident ($' Lux Bool)) - (do Lux/Monad - [ident (normalize ident) - output (find-macro ident)] - (wrap (_lux_case output - (#Some _) true - #None false)))) - -(def''' (list:join xs) - (All [a] - (-> ($' List ($' List a)) ($' List a))) - (foldL list:++ #Nil xs)) - -(def''' (interpose sep xs) - (All [a] - (-> a ($' List a) ($' List a))) - (_lux_case xs - #Nil - xs - - (#Cons [x #Nil]) - xs - - (#Cons [x xs']) - (@list& x sep (interpose sep xs')))) - -(def''' (macro-expand token) - (-> AST ($' Lux ($' List AST))) - (_lux_case token - [_ (#FormS (#Cons [_ (#SymbolS macro-name)] args))] - (do Lux/Monad - [macro-name' (normalize macro-name) - ?macro (find-macro macro-name')] - (_lux_case ?macro - (#Some macro) - (do Lux/Monad - [expansion (macro args) - expansion' (map% Lux/Monad macro-expand expansion)] - (wrap (list:join expansion'))) - - #None - (return (@list token)))) - - _ - (return (@list token)))) - -(def''' (macro-expand-all syntax) - (-> AST ($' Lux ($' List AST))) - (_lux_case syntax - [_ (#FormS (#Cons [_ (#SymbolS macro-name)] args))] - (do Lux/Monad - [macro-name' (normalize macro-name) - ?macro (find-macro macro-name')] - (_lux_case ?macro - (#Some macro) - (do Lux/Monad - [expansion (macro args) - expansion' (map% Lux/Monad macro-expand-all expansion)] - (wrap (list:join expansion'))) - - #None - (do Lux/Monad - [args' (map% Lux/Monad macro-expand-all args)] - (wrap (@list (form$ (#Cons (symbol$ macro-name) (list:join args')))))))) - - [_ (#FormS members)] - (do Lux/Monad - [members' (map% Lux/Monad macro-expand-all members)] - (wrap (@list (form$ (list:join members'))))) - - [_ (#TupleS members)] - (do Lux/Monad - [members' (map% Lux/Monad macro-expand-all members)] - (wrap (@list (tuple$ (list:join members'))))) - - _ - (return (@list syntax)))) - -(def''' (walk-type type) - (-> AST AST) - (_lux_case type - [_ (#FormS (#Cons [[_ (#TagS tag)] parts]))] - (form$ (#Cons [(tag$ tag) (map walk-type parts)])) - - [_ (#TupleS members)] - (tuple$ (map walk-type members)) - - [_ (#FormS (#Cons [type-fn args]))] - (foldL (_lux_: (-> AST AST AST) - (lambda' [type-fn arg] (` (#;AppT [(~ type-fn) (~ arg)])))) - (walk-type type-fn) - (map walk-type args)) - - _ - type)) - -(defmacro' #export (@type tokens) - (_lux_case tokens - (#Cons type #Nil) - (do Lux/Monad - [type+ (macro-expand-all type)] - (_lux_case type+ - (#Cons type' #Nil) - (wrap (@list (walk-type type'))) - - _ - (fail "The expansion of the type-syntax had to yield a single element."))) - - _ - (fail "Wrong syntax for @type"))) - -(defmacro' #export (: tokens) - (_lux_case tokens - (#Cons type (#Cons value #Nil)) - (return (@list (` (;_lux_: (@type (~ type)) (~ value))))) - - _ - (fail "Wrong syntax for :"))) - -(defmacro' #export (:! tokens) - (_lux_case tokens - (#Cons type (#Cons value #Nil)) - (return (@list (` (;_lux_:! (@type (~ type)) (~ value))))) - - _ - (fail "Wrong syntax for :!"))) - -(def''' (empty? xs) - (All [a] (-> ($' List a) Bool)) - (_lux_case xs - #Nil true - _ false)) - -(do-template [<name> <type> <value>] - [(def''' (<name> xy) - (All [a b] (-> (, a b) <type>)) - (let' [[x y] xy] <value>))] - - [first a x] - [second b y]) - -(def''' (unfold-type-def type) - (-> AST ($' Lux (, AST ($' Maybe ($' List AST))))) - (_lux_case type - [_ (#FormS (#Cons [_ (#SymbolS "" "|")] cases))] - (do Lux/Monad - [members (map% Lux/Monad - (: (-> AST ($' Lux (, Text AST))) - (lambda' [case] - (_lux_case case - [_ (#TagS "" member-name)] - (return [member-name (` Unit)]) - - [_ (#FormS (#Cons [_ (#TagS "" member-name)] (#Cons member-type #Nil)))] - (return [member-name member-type]) - - _ - (fail "Wrong syntax for variant case.")))) - cases)] - (return [(` (#;VariantT (~ (untemplate-list (map second members))))) - (#Some (|> members - (map first) - (map (: (-> Text AST) - (lambda' [name] (tag$ ["" name]))))))])) - - [_ (#FormS (#Cons [_ (#SymbolS "" "&")] pairs))] - (do Lux/Monad - [members (map% Lux/Monad - (: (-> (, AST AST) ($' Lux (, Text AST))) - (lambda' [pair] - (_lux_case pair - [[_ (#TagS "" member-name)] member-type] - (return [member-name member-type]) - - _ - (fail "Wrong syntax for variant case.")))) - (as-pairs pairs))] - (return [(` (#TupleT (~ (untemplate-list (map second members))))) - (#Some (|> members - (map first) - (map (: (-> Text AST) - (lambda' [name] (tag$ ["" name]))))))])) - - _ - (return [type #None]))) - -(def''' (gensym prefix state) - (-> Text ($' Lux AST)) - (_lux_case state - {#source source #modules modules - #envs envs #type-vars types #host host - #seed seed #eval? eval? #expected expected - #cursor cursor} - (#Right {#source source #modules modules - #envs envs #type-vars types #host host - #seed (i+ 1 seed) #eval? eval? #expected expected - #cursor cursor} - (symbol$ ["" ($ text:++ "__gensym__" prefix (->text seed))])))) - -(defmacro' #export (Rec tokens) - (_lux_case tokens - (#Cons [_ (#SymbolS "" name)] (#Cons body #Nil)) - (let' [body' (replace-syntax (@list [name (` (#AppT (~ (make-bound 0)) (~ (make-bound 1))))]) body)] - (return (@list (` (#AppT (#UnivQ #Nil (~ body')) Void))))) - - _ - (fail "Wrong syntax for Rec"))) - -(defmacro' #export (deftype tokens) - (let' [[export? tokens'] (_lux_case tokens - (#Cons [_ (#TagS "" "export")] tokens') - [true tokens'] - - _ - [false tokens]) - [rec? tokens'] (_lux_case tokens' - (#Cons [_ (#TagS "" "rec")] tokens') - [true tokens'] - - _ - [false tokens']) - parts (: (Maybe (, Text (List AST) AST)) - (_lux_case tokens' - (#Cons [_ (#SymbolS "" name)] (#Cons type #Nil)) - (#Some name #Nil type) - - (#Cons [_ (#FormS (#Cons [_ (#SymbolS "" name)] args))] (#Cons type #Nil)) - (#Some name args type) - - _ - #None))] - (_lux_case parts - (#Some name args type) - (do Lux/Monad - [type+tags?? (unfold-type-def type) - module-name get-module-name] - (let' [type-name (symbol$ ["" name]) - [type tags??] type+tags?? - with-export (: (List AST) - (if export? - (@list (` (;_lux_export (~ type-name)))) - #Nil)) - with-tags (: (List AST) - (_lux_case tags?? - (#Some tags) - (@list (` (;_lux_declare-tags [(~@ tags)] (~ type-name)))) - - _ - (@list))) - type' (: (Maybe AST) - (if rec? - (if (empty? args) - (let' [g!param (symbol$ ["" ""]) - prime-name (symbol$ ["" (text:++ name "'")]) - type+ (replace-syntax (@list [name (` ((~ prime-name) (~ g!param)))]) type)] - (#Some (` ((All (~ prime-name) [(~ g!param)] (~ type+)) - Void)))) - #None) - (_lux_case args - #Nil - (#Some type) - - _ - (#Some (` (All (~ type-name) [(~@ args)] (~ type)))))))] - (_lux_case type' - (#Some type'') - (return (@list& (` (;_lux_def (~ type-name) (@type (#;NamedT [(~ (text$ module-name)) - (~ (text$ name))] - (~ type''))))) - (list:++ with-export with-tags))) - - #None - (fail "Wrong syntax for deftype")))) - - #None - (fail "Wrong syntax for deftype")) - )) - -(defmacro' #export (exec tokens) - (_lux_case (reverse tokens) - (#Cons value actions) - (let' [dummy (symbol$ ["" ""])] - (return (@list (foldL (_lux_: (-> AST AST AST) - (lambda' [post pre] (` (;_lux_case (~ pre) (~ dummy) (~ post))))) - value - actions)))) - - _ - (fail "Wrong syntax for exec"))) - -(defmacro' (def' tokens) - (let' [[export? tokens'] (_lux_case tokens - (#Cons [_ (#TagS "" "export")] tokens') - [true tokens'] - - _ - [false tokens]) - parts (: (Maybe (, AST (List AST) (Maybe AST) AST)) - (_lux_case tokens' - (#Cons [_ (#FormS (#Cons name args))] (#Cons type (#Cons body #Nil))) - (#Some name args (#Some type) body) - - (#Cons name (#Cons type (#Cons body #Nil))) - (#Some name #Nil (#Some type) body) - - (#Cons [_ (#FormS (#Cons name args))] (#Cons body #Nil)) - (#Some name args #None body) - - (#Cons name (#Cons body #Nil)) - (#Some name #Nil #None body) - - _ - #None))] - (_lux_case parts - (#Some name args ?type body) - (let' [body' (_lux_case args - #Nil - body - - _ - (` (lambda' (~ name) [(~@ args)] (~ body)))) - body'' (_lux_case ?type - (#Some type) - (` (: (~ type) (~ body'))) - - #None - body')] - (return (@list& (` (;_lux_def (~ name) (~ body''))) - (if export? - (@list (` (;_lux_export (~ name)))) - #Nil)))) - - #None - (fail "Wrong syntax for def'")))) - -(def' (rejoin-pair pair) - (-> (, AST AST) (List AST)) - (let' [[left right] pair] - (@list left right))) - -(defmacro' #export (case tokens) - (_lux_case tokens - (#Cons value branches) - (if (multiple? 2 (length branches)) - (do Lux/Monad - [expansions (map% Lux/Monad - (: (-> (, AST AST) (Lux (List (, AST AST)))) - (lambda' expander [branch] - (let' [[pattern body] branch] - (_lux_case pattern - [_ (#FormS (#Cons [_ (#SymbolS macro-name)] macro-args))] - (do Lux/Monad - [??? (macro? macro-name)] - (if ??? - (do Lux/Monad - [expansion (macro-expand (form$ (@list& (symbol$ macro-name) body macro-args))) - expansions (map% Lux/Monad expander (as-pairs expansion))] - (wrap (list:join expansions))) - (wrap (@list branch)))) - - _ - (wrap (@list branch)))))) - (as-pairs branches))] - (wrap (@list (` (;_lux_case (~ value) - (~@ (|> expansions list:join (map rejoin-pair) list:join))))))) - (fail "case expects an even number of tokens")) - - _ - (fail "Wrong syntax for case"))) - -(defmacro' #export (\ tokens) - (case tokens - (#Cons body (#Cons pattern #Nil)) - (do Lux/Monad - [module-name get-module-name - pattern+ (macro-expand-all pattern)] - (case pattern+ - (#Cons pattern' #Nil) - (wrap (@list pattern' body)) - - _ - (fail "\\ can only expand to 1 pattern."))) - - _ - (fail "Wrong syntax for \\"))) - -(defmacro' #export (\or tokens) - (case tokens - (#Cons body patterns) - (case patterns - #Nil - (fail "\\or can't have 0 patterns") - - _ - (do Lux/Monad - [patterns' (map% Lux/Monad macro-expand-all patterns)] - (wrap (list:join (map (lambda' [pattern] (@list pattern body)) - (list:join patterns')))))) - - _ - (fail "Wrong syntax for \\or"))) - -(def' (symbol? ast) - (-> AST Bool) - (case ast - [_ (#SymbolS _)] - true - - _ - false)) - -(defmacro' #export (let tokens) - (case tokens - (\ (@list [_ (#TupleS bindings)] body)) - (if (multiple? 2 (length bindings)) - (|> bindings as-pairs reverse - (foldL (: (-> AST (, AST AST) AST) - (lambda' [body' lr] - (let' [[l r] lr] - (if (symbol? l) - (` (;_lux_case (~ r) (~ l) (~ body'))) - (` (case (~ r) (~ l) (~ body'))))))) - body) - @list - return) - (fail "let requires an even number of parts")) - - _ - (fail "Wrong syntax for let"))) - -(defmacro' #export (lambda tokens) - (case (: (Maybe (, Ident AST (List AST) AST)) - (case tokens - (\ (@list [_ (#TupleS (#Cons head tail))] body)) - (#Some ["" ""] head tail body) - - (\ (@list [_ (#SymbolS ["" name])] [_ (#TupleS (#Cons head tail))] body)) - (#Some ["" name] head tail body) - - _ - #None)) - (#Some ident head tail body) - (let [g!blank (symbol$ ["" ""]) - g!name (symbol$ ident) - body+ (foldL (: (-> AST AST AST) - (lambda' [body' arg] - (if (symbol? arg) - (` (;_lux_lambda (~ g!blank) (~ arg) (~ body'))) - (` (;_lux_lambda (~ g!blank) (~ g!blank) - (case (~ g!blank) (~ arg) (~ body'))))))) - body - (reverse tail))] - (return (@list (if (symbol? head) - (` (;_lux_lambda (~ g!name) (~ head) (~ body+))) - (` (;_lux_lambda (~ g!name) (~ g!blank) (case (~ g!blank) (~ head) (~ body+)))))))) - - #None - (fail "Wrong syntax for lambda"))) - -(defmacro' #export (def tokens) - (let [[export? tokens'] (case tokens - (#Cons [_ (#TagS "" "export")] tokens') - [true tokens'] - - _ - [false tokens]) - parts (: (Maybe (, AST (List AST) (Maybe AST) AST)) - (case tokens' - (\ (@list [_ (#FormS (#Cons name args))] type body)) - (#Some name args (#Some type) body) - - (\ (@list name type body)) - (#Some name #Nil (#Some type) body) - - (\ (@list [_ (#FormS (#Cons name args))] body)) - (#Some name args #None body) - - (\ (@list name body)) - (#Some name #Nil #None body) - - _ - #None))] - (case parts - (#Some name args ?type body) - (let [body (case args - #Nil - body - - _ - (` (lambda (~ name) [(~@ args)] (~ body)))) - body (case ?type - (#Some type) - (` (: (~ type) (~ body))) - - #None - body)] - (return (@list& (` (;_lux_def (~ name) (~ body))) - (if export? - (@list (` (;_lux_export (~ name)))) - (@list))))) - - #None - (fail "Wrong syntax for def")))) - -(defmacro' #export (defmacro tokens) - (let [[exported? tokens] (case tokens - (\ (@list& [_ (#TagS ["" "export"])] tokens')) - [true tokens'] - - _ - [false tokens]) - name+args+body?? (: (Maybe (, Ident (List AST) AST)) - (case tokens - (\ (@list [_ (#;FormS (@list& [_ (#SymbolS name)] args))] body)) - (#Some [name args body]) - - (\ (@list [_ (#;SymbolS name)] body)) - (#Some [name #Nil body]) - - _ - #None))] - (case name+args+body?? - (#Some [name args body]) - (let [name (symbol$ name) - decls (: (List AST) - (list:++ (if exported? (@list (` (;_lux_export (~ name)))) #;Nil) - (@list (` (;;_lux_declare-macro (~ name)))))) - def-sig (case args - #;Nil name - _ (` ((~ name) (~@ args))))] - (return (@list& (` (;;def (~ def-sig) ;;Macro (~ body))) - decls))) - - - #None - (fail "Wrong syntax for defmacro")))) - -(defmacro #export (defsig tokens) - (let [[export? tokens'] (case tokens - (\ (@list& [_ (#TagS "" "export")] tokens')) - [true tokens'] - - _ - [false tokens]) - ?parts (: (Maybe (, Ident (List AST) (List AST))) - (case tokens' - (\ (@list& [_ (#FormS (@list& [_ (#SymbolS name)] args))] sigs)) - (#Some name args sigs) - - (\ (@list& [_ (#SymbolS name)] sigs)) - (#Some name #Nil sigs) - - _ - #None))] - (case ?parts - (#Some name args sigs) - (do Lux/Monad - [name+ (normalize name) - sigs' (map% Lux/Monad macro-expand sigs) - members (map% Lux/Monad - (: (-> AST (Lux (, Text AST))) - (lambda [token] - (case token - (\ [_ (#FormS (@list [_ (#SymbolS _ "_lux_:")] type [_ (#SymbolS ["" name])]))]) - (wrap [name type]) - - _ - (fail "Signatures require typed members!")))) - (list:join sigs')) - #let [[_module _name] name+ - def-name (symbol$ name) - tags (: (List AST) (map (. (: (-> Text AST) (lambda [n] (tag$ ["" n]))) first) members)) - types (map second members) - sig-type (` (#TupleT (~ (untemplate-list types)))) - sig-decl (` (;_lux_declare-tags [(~@ tags)] (~ def-name))) - sig+ (case args - #Nil - sig-type - - _ - (` (#NamedT [(~ (text$ _module)) (~ (text$ _name))] (;All (~ def-name) [(~@ args)] (~ sig-type)))))]] - (return (@list& (` (;_lux_def (~ def-name) (~ sig+))) - sig-decl - (if export? - (@list (` (;_lux_export (~ def-name)))) - #Nil)))) - - #None - (fail "Wrong syntax for defsig")))) - -(def (some f xs) - (All [a b] - (-> (-> a (Maybe b)) (List a) (Maybe b))) - (case xs - #Nil - #None - - (#Cons x xs') - (case (f x) - #None - (some f xs') - - (#Some y) - (#Some y)))) - -(def (last-index-of part text) - (-> Text Text Int) - (_jvm_i2l (_jvm_invokevirtual "java.lang.String" "lastIndexOf" ["java.lang.String"] - text [part]))) - -(def (index-of part text) - (-> Text Text Int) - (_jvm_i2l (_jvm_invokevirtual "java.lang.String" "indexOf" ["java.lang.String"] - text [part]))) - -(def (substring1 idx text) - (-> Int Text Text) - (_jvm_invokevirtual "java.lang.String" "substring" ["int"] - text [(_jvm_l2i idx)])) - -(def (substring2 idx1 idx2 text) - (-> Int Int Text Text) - (_jvm_invokevirtual "java.lang.String" "substring" ["int" "int"] - text [(_jvm_l2i idx1) (_jvm_l2i idx2)])) - -(def (split-module-contexts module) - (-> Text (List Text)) - (#Cons module (let [idx (last-index-of "/" module)] - (if (i< idx 0) - #Nil - (split-module-contexts (substring2 0 idx module)))))) - -(def (split-module module) - (-> Text (List Text)) - (let [idx (index-of "/" module)] - (if (i< idx 0) - (#Cons module #Nil) - (#Cons (substring2 0 idx module) - (split-module (substring1 (i+ 1 idx) module)))))) - -(def (@ idx xs) - (All [a] - (-> Int (List a) (Maybe a))) - (case xs - #Nil - #None - - (#Cons x xs') - (if (i= idx 0) - (#Some x) - (@ (i- idx 1) xs') - ))) - -(def (beta-reduce env type) - (-> (List Type) Type Type) - (case type - (#VariantT ?cases) - (#VariantT (map (beta-reduce env) ?cases)) - - (#TupleT ?members) - (#TupleT (map (beta-reduce env) ?members)) - - (#AppT ?type-fn ?type-arg) - (#AppT (beta-reduce env ?type-fn) (beta-reduce env ?type-arg)) - - (#UnivQ ?local-env ?local-def) - (case ?local-env - #Nil - (#UnivQ env ?local-def) - - _ - type) - - (#ExQ ?local-env ?local-def) - (case ?local-env - #Nil - (#ExQ env ?local-def) - - _ - type) - - (#LambdaT ?input ?output) - (#LambdaT (beta-reduce env ?input) (beta-reduce env ?output)) - - (#BoundT idx) - (case (@ idx env) - (#Some bound) - bound - - _ - type) - - (#NamedT name type) - (beta-reduce env type) - - _ - type - )) - -(def (apply-type type-fn param) - (-> Type Type (Maybe Type)) - (case type-fn - (#UnivQ env body) - (#Some (beta-reduce (@list& type-fn param env) body)) - - (#AppT F A) - (do Maybe/Monad - [type-fn* (apply-type F A)] - (apply-type type-fn* param)) - - (#NamedT name type) - (apply-type type param) - - _ - #None)) - -(def (resolve-struct-type type) - (-> Type (Maybe (List Type))) - (case type - (#TupleT slots) - (#Some slots) - - (#AppT fun arg) - (do Maybe/Monad - [output (apply-type fun arg)] - (resolve-struct-type output)) - - (#UnivQ _ body) - (resolve-struct-type body) - - (#ExQ _ body) - (resolve-struct-type body) - - (#NamedT name type) - (resolve-struct-type type) - - _ - #None)) - -(def (find-module name) - (-> Text (Lux (Module Compiler))) - (lambda [state] - (let [{#source source #modules modules - #envs envs #type-vars types #host host - #seed seed #eval? eval? #expected expected - #cursor cursor} state] - (case (get name modules) - (#Some module) - (#Right state module) - - _ - (#Left ($ text:++ "Unknown module: " name)))))) - -(def get-current-module - (Lux (Module Compiler)) - (do Lux/Monad - [module-name get-module-name] - (find-module module-name))) - -(def (resolve-tag [module name]) - (-> Ident (Lux (, Int (List Ident) Type))) - (do Lux/Monad - [=module (find-module module) - #let [{#module-aliases _ #defs bindings #imports _ #tags tags-table #types types} =module]] - (case (get name tags-table) - (#Some output) - (return output) - - _ - (fail (text:++ "Unknown tag: " (ident->text [module name])))))) - -(def (resolve-type-tags type) - (-> Type (Lux (Maybe (, (List Ident) (List Type))))) - (case type - (#AppT fun arg) - (resolve-type-tags fun) - - (#UnivQ env body) - (resolve-type-tags body) - - (#ExQ env body) - (resolve-type-tags body) - - (#NamedT [module name] _) - (do Lux/Monad - [=module (find-module module) - #let [{#module-aliases _ #defs bindings #imports _ #tags tags #types types} =module]] - (case (get name types) - (#Some [tags (#NamedT _ _type)]) - (case (resolve-struct-type _type) - (#Some members) - (return (#Some [tags members])) - - _ - (return #None)) - - _ - (return #None))) - - _ - (return #None))) - -(def expected-type - (Lux Type) - (lambda [state] - (let [{#source source #modules modules - #envs envs #type-vars types #host host - #seed seed #eval? eval? #expected expected - #cursor cursor} state] - (#Right state expected)))) - -(defmacro #export (struct tokens) - (do Lux/Monad - [tokens' (map% Lux/Monad macro-expand tokens) - struct-type expected-type - tags+type (resolve-type-tags struct-type) - tags (: (Lux (List Ident)) - (case tags+type - (#Some [tags _]) - (return tags) - - _ - (fail "No tags available for type."))) - #let [tag-mappings (: (List (, Text AST)) - (map (lambda [tag] [(second tag) (tag$ tag)]) - tags))] - members (map% Lux/Monad - (: (-> AST (Lux (, AST AST))) - (lambda [token] - (case token - (\ [_ (#FormS (@list [_ (#SymbolS _ "_lux_def")] [_ (#SymbolS "" tag-name)] value))]) - (case (get tag-name tag-mappings) - (#Some tag) - (wrap [tag value]) - - _ - (fail (text:++ "Unknown structure member: " tag-name))) - - _ - (fail "Invalid structure member.")))) - (list:join tokens'))] - (wrap (@list (record$ members))))) - -(defmacro #export (defstruct tokens) - (let [[export? tokens'] (case tokens - (\ (@list& [_ (#TagS "" "export")] tokens')) - [true tokens'] - - _ - [false tokens]) - ?parts (: (Maybe (, AST (List AST) AST (List AST))) - (case tokens' - (\ (@list& [_ (#FormS (@list& name args))] type defs)) - (#Some name args type defs) - - (\ (@list& name type defs)) - (#Some name #Nil type defs) - - _ - #None))] - (case ?parts - (#Some name args type defs) - (let [defs' (case args - #Nil - (` (struct (~@ defs))) - - _ - (` (lambda (~ name) [(~@ args)] (;struct (~@ defs)))))] - (return (@list& (` (def (~ name) (~ type) (~ defs'))) - (if export? - (@list (` (;_lux_export (~ name)))) - #Nil)))) - - #None - (fail "Wrong syntax for defstruct")))) - -(def #export (id x) - (All [a] (-> a a)) - x) - -(do-template [<name> <form> <message>] - [(defmacro #export (<name> tokens) - (case (reverse tokens) - (\ (@list& last init)) - (return (@list (foldL (: (-> AST AST AST) - (lambda [post pre] (` <form>))) - last - init))) - - _ - (fail <message>)))] - - [and (if (~ pre) (~ post) false) "and requires >=1 clauses."] - [or (if (~ pre) true (~ post)) "or requires >=1 clauses."]) - -(deftype Referrals - (| #All - (#Only (List Text)) - (#Exclude (List Text)) - #Nothing)) - -(deftype Openings - (, Text (List Ident))) - -(deftype Importation - (, Text (Maybe Text) Referrals (Maybe Openings))) - -(def (extract-defs defs) - (-> (List AST) (Lux (List Text))) - (map% Lux/Monad - (: (-> AST (Lux Text)) - (lambda [def] - (case def - [_ (#SymbolS "" name)] - (return name) - - _ - (fail "only/exclude requires symbols.")))) - defs)) - -(def (parse-alias tokens) - (-> (List AST) (Lux (, (Maybe Text) (List AST)))) - (case tokens - (\ (@list& [_ (#TagS "" "as")] [_ (#SymbolS "" alias)] tokens')) - (return [(#Some alias) tokens']) - - _ - (return [#None tokens]))) - -(def (parse-referrals tokens) - (-> (List AST) (Lux (, Referrals (List AST)))) - (case tokens - (\ (@list& [_ (#TagS "" "refer")] referral tokens')) - (case referral - [_ (#TagS "" "all")] - (return [#All tokens']) - - (\ [_ (#FormS (@list& [_ (#TagS "" "only")] defs))]) - (do Lux/Monad - [defs' (extract-defs defs)] - (return [(#Only defs') tokens'])) - - (\ [_ (#FormS (@list& [_ (#TagS "" "exclude")] defs))]) - (do Lux/Monad - [defs' (extract-defs defs)] - (return [(#Exclude defs') tokens'])) - - _ - (fail "Incorrect syntax for referral.")) - - _ - (return [#Nothing tokens]))) - -(def (extract-symbol syntax) - (-> AST (Lux Ident)) - (case syntax - [_ (#SymbolS ident)] - (return ident) - - _ - (fail "Not a symbol."))) - -(def (parse-openings tokens) - (-> (List AST) (Lux (, (Maybe Openings) (List AST)))) - (case tokens - (\ (@list& [_ (#TagS "" "open")] [_ (#FormS (@list& [_ (#TextS prefix)] structs))] tokens')) - (do Lux/Monad - [structs' (map% Lux/Monad extract-symbol structs)] - (return [(#Some prefix structs') tokens'])) - - _ - (return [#None tokens]))) - -(def (decorate-imports super-name tokens) - (-> Text (List AST) (Lux (List AST))) - (map% Lux/Monad - (: (-> AST (Lux AST)) - (lambda [token] - (case token - [_ (#SymbolS "" sub-name)] - (return (symbol$ ["" ($ text:++ super-name "/" sub-name)])) - - (\ [_ (#FormS (@list& [_ (#SymbolS "" sub-name)] parts))]) - (return (form$ (@list& (symbol$ ["" ($ text:++ super-name "/" sub-name)]) parts))) - - _ - (fail "Wrong import syntax.")))) - tokens)) - -(def (parse-imports imports) - (-> (List AST) (Lux (List Importation))) - (do Lux/Monad - [imports' (map% Lux/Monad - (: (-> AST (Lux (List Importation))) - (lambda [token] - (case token - [_ (#SymbolS "" m-name)] - (wrap (@list [m-name #None #All #None])) - - (\ [_ (#FormS (@list& [_ (#SymbolS "" m-name)] extra))]) - (do Lux/Monad - [alias+extra (parse-alias extra) - #let [[alias extra] alias+extra] - referral+extra (parse-referrals extra) - #let [[referral extra] referral+extra] - openings+extra (parse-openings extra) - #let [[openings extra] openings+extra] - extra (decorate-imports m-name extra) - sub-imports (parse-imports extra)] - (wrap (case [referral alias openings] - [#Nothing #None #None] sub-imports - _ (@list& [m-name alias referral openings] sub-imports)))) - - _ - (fail "Wrong syntax for import")))) - imports)] - (wrap (list:join imports')))) - -(def (module-exists? module state) - (-> Text (Lux Bool)) - (case state - {#source source #modules modules - #envs envs #type-vars types #host host - #seed seed #eval? eval? #expected expected - #cursor cursor} - (case (get module modules) - (#Some =module) - (#Right state true) - - #None - (#Right state false)) - )) - -(def (exported-defs module state) - (-> Text (Lux (List Text))) - (case state - {#source source #modules modules - #envs envs #type-vars types #host host - #seed seed #eval? eval? #expected expected - #cursor cursor} - (case (get module modules) - (#Some =module) - (let [to-alias (map (: (-> (, Text Definition) - (List Text)) - (lambda [gdef] - (let [[name [export? _]] gdef] - (if export? - (@list name) - (@list))))) - (let [{#module-aliases _ #defs defs #imports _ #tags tags #types types} =module] - defs))] - (#Right state (list:join to-alias))) - - #None - (#Left ($ text:++ "Unknown module: " module))) - )) - -(def (split-with' p ys xs) - (All [a] - (-> (-> a Bool) (List a) (List a) (, (List a) (List a)))) - (case xs - #Nil - [ys xs] - - (#Cons x xs') - (if (p x) - (split-with' p (@list& x ys) xs') - [ys xs]))) - -(def (split-with p xs) - (All [a] - (-> (-> a Bool) (List a) (, (List a) (List a)))) - (let [[ys' xs'] (split-with' p #Nil xs)] - [(reverse ys') xs'])) - -(def (clean-module module) - (-> Text (Lux Text)) - (do Lux/Monad - [module-name get-module-name] - (case (split-module module) - (\ (@list& "." parts)) - (return (|> (@list& module-name parts) (interpose "/") (foldL text:++ ""))) - - parts - (let [[ups parts'] (split-with (text:= "..") parts) - num-ups (length ups)] - (if (i= num-ups 0) - (return module) - (case (@ num-ups (split-module-contexts module-name)) - #None - (fail (text:++ "Can't clean module: " module)) - - (#Some top-module) - (return (|> (@list& top-module parts') (interpose "/") (foldL text:++ "")))) - ))) - )) - -(def (filter p xs) - (All [a] (-> (-> a Bool) (List a) (List a))) - (case xs - #;Nil - (@list) - - (#;Cons x xs') - (if (p x) - (#;Cons x (filter p xs')) - (filter p xs')))) - -(def (is-member? cases name) - (-> (List Text) Text Bool) - (let [output (foldL (lambda [prev case] - (or prev - (text:= case name))) - false - cases)] - output)) - -(def (try-both f x1 x2) - (All [a b] - (-> (-> a (Maybe b)) a a (Maybe b))) - (case (f x1) - #;None (f x2) - (#;Some y) (#;Some y))) - -(def (find-in-env name state) - (-> Text Compiler (Maybe Type)) - (case state - {#source source #modules modules - #envs envs #type-vars types #host host - #seed seed #eval? eval? #expected expected - #cursor cursor} - (some (: (-> (Env Text (Meta (, Type Cursor) Analysis)) (Maybe Type)) - (lambda [env] - (case env - {#name _ #inner-closures _ #locals {#counter _ #mappings locals} #closure {#counter _ #mappings closure}} - (try-both (some (: (-> (, Text (Meta (, Type Cursor) Analysis)) (Maybe Type)) - (lambda [[bname [[type _] _]]] - (if (text:= name bname) - (#Some type) - #None)))) - locals - closure)))) - envs))) - -(def (find-in-defs name state) - (-> Ident Compiler (Maybe Type)) - (let [[v-prefix v-name] name - {#source source #modules modules - #envs envs #type-vars types #host host - #seed seed #eval? eval? #expected expected - #cursor cursor} state] - (case (get v-prefix modules) - #None - #None - - (#Some {#defs defs #module-aliases _ #imports _ #tags tags #types types}) - (case (get v-name defs) - #None - #None - - (#Some [_ def-data]) - (case def-data - (#TypeD _) (#Some Type) - (#ValueD type _) (#Some type) - (#MacroD m) (#Some Macro) - (#AliasD name') (find-in-defs name' state)))))) - -(def (find-var-type ident) - (-> Ident (Lux Type)) - (do Lux/Monad - [#let [[module name] ident] - current-module get-module-name] - (lambda [state] - (if (text:= "" module) - (case (find-in-env name state) - (#Some struct-type) - (#Right state struct-type) - - _ - (case (find-in-defs [current-module name] state) - (#Some struct-type) - (#Right state struct-type) - - _ - (let [{#source source #modules modules - #envs envs #type-vars types #host host - #seed seed #eval? eval? #expected expected - #cursor cursor} state] - (#Left ($ text:++ "Unknown var: " (ident->text ident)))))) - (case (find-in-defs ident state) - (#Some struct-type) - (#Right state struct-type) - - _ - (let [{#source source #modules modules - #envs envs #type-vars types #host host - #seed seed #eval? eval? #expected expected - #cursor cursor} state] - (#Left ($ text:++ "Unknown var: " (ident->text ident)))))) - ))) - -(def (zip2 xs ys) - (All [a b] (-> (List a) (List b) (List (, a b)))) - (case xs - (#Cons x xs') - (case ys - (#Cons y ys') - (@list& [x y] (zip2 xs' ys')) - - _ - (@list)) - - _ - (@list))) - -(def (use-field [module name] type) - (-> Ident Type (Lux (, AST AST))) - (do Lux/Monad - [output (resolve-type-tags type) - pattern (: (Lux AST) - (case output - (#Some [tags members]) - (do Lux/Monad - [slots (map% Lux/Monad - (: (-> (, Ident Type) (Lux (, AST AST))) - (lambda [[sname stype]] (use-field sname stype))) - (zip2 tags members))] - (return (record$ slots))) - - #None - (return (symbol$ ["" name]))))] - (return [(tag$ [module name]) pattern]))) - -(defmacro #export (using tokens) - (case tokens - (\ (@list struct body)) - (case struct - [_ (#SymbolS name)] - (do Lux/Monad - [struct-type (find-var-type name) - output (resolve-type-tags struct-type)] - (case output - (#Some [tags members]) - (do Lux/Monad - [slots (map% Lux/Monad (: (-> (, Ident Type) (Lux (, AST AST))) - (lambda [[sname stype]] (use-field sname stype))) - (zip2 tags members)) - #let [pattern (record$ slots)]] - (return (@list (` (;_lux_case (~ struct) (~ pattern) (~ body)))))) - - _ - (fail "Can only \"use\" records."))) - - [_ (#TupleS members)] - (return (@list (foldL (: (-> AST AST AST) - (lambda [body' struct'] (` (;;using (~ struct') (~ body'))))) - body - members))) - - _ - (let [dummy (symbol$ ["" ""])] - (return (@list (` (;_lux_case (~ struct) - (~ dummy) - (;;using (~ dummy) - (~ body)))))))) - - _ - (fail "Wrong syntax for using"))) - -(defmacro #export (cond tokens) - (if (i= 0 (i% (length tokens) 2)) - (fail "cond requires an even number of arguments.") - (case (reverse tokens) - (\ (@list& else branches')) - (return (@list (foldL (: (-> AST (, AST AST) AST) - (lambda [else branch] - (let [[right left] branch] - (` (if (~ left) (~ right) (~ else)))))) - else - (as-pairs branches')))) - - _ - (fail "Wrong syntax for cond")))) - -(def (enumerate' idx xs) - (All [a] (-> Int (List a) (List (, Int a)))) - (case xs - (#Cons x xs') - (#Cons [idx x] (enumerate' (i+ 1 idx) xs')) - - #Nil - #Nil)) - -(def (enumerate xs) - (All [a] (-> (List a) (List (, Int a)))) - (enumerate' 0 xs)) - -(defmacro #export (get@ tokens) - (case tokens - (\ (@list [_ (#TagS slot')] record)) - (do Lux/Monad - [slot (normalize slot') - output (resolve-tag slot) - #let [[idx tags type] output] - g!_ (gensym "_") - g!output (gensym "")] - (case (resolve-struct-type type) - (#Some members) - (let [pattern (record$ (map (: (-> (, Ident (, Int Type)) (, AST AST)) - (lambda [[[r-prefix r-name] [r-idx r-type]]] - [(tag$ [r-prefix r-name]) (if (i= idx r-idx) - g!output - g!_)])) - (zip2 tags (enumerate members))))] - (return (@list (` (;_lux_case (~ record) (~ pattern) (~ g!output)))))) - - _ - (fail "get@ can only use records."))) - - _ - (fail "Wrong syntax for get@"))) - -(def (open-field prefix [module name] source type) - (-> Text Ident AST Type (Lux (List AST))) - (do Lux/Monad - [output (resolve-type-tags type) - #let [source+ (` (get@ (~ (tag$ [module name])) (~ source)))]] - (case output - (#Some [tags members]) - (do Lux/Monad - [decls' (map% Lux/Monad - (: (-> (, Ident Type) (Lux (List AST))) - (lambda [[sname stype]] (open-field prefix sname source+ stype))) - (zip2 tags members))] - (return (list:join decls'))) - - _ - (return (@list (` (;_lux_def (~ (symbol$ ["" (text:++ prefix name)])) (~ source+)))))))) - -(defmacro #export (open tokens) - (case tokens - (\ (@list& [_ (#SymbolS struct-name)] tokens')) - (do Lux/Monad - [@module get-module-name - #let [prefix (case tokens' - (\ (@list [_ (#TextS prefix)])) - prefix - - _ - "")] - struct-type (find-var-type struct-name) - output (resolve-type-tags struct-type) - #let [source (symbol$ struct-name)]] - (case output - (#Some [tags members]) - (do Lux/Monad - [decls' (map% Lux/Monad (: (-> (, Ident Type) (Lux (List AST))) - (lambda [[sname stype]] (open-field prefix sname source stype))) - (zip2 tags members))] - (return (list:join decls'))) - - _ - (fail "Can only \"open\" records."))) - - _ - (fail "Wrong syntax for open"))) - -(defmacro #export (import tokens) - (do Lux/Monad - [imports (parse-imports tokens) - imports (map% Lux/Monad - (: (-> Importation (Lux Importation)) - (lambda [import] - (case import - [m-name m-alias m-referrals m-openings] - (do Lux/Monad - [m-name (clean-module m-name)] - (wrap [m-name m-alias m-referrals m-openings]))))) - imports) - unknowns' (map% Lux/Monad - (: (-> Importation (Lux (List Text))) - (lambda [import] - (case import - [m-name _ _ _] - (do Lux/Monad - [? (module-exists? m-name)] - (wrap (if ? - (@list) - (@list m-name))))))) - imports) - #let [unknowns (list:join unknowns')]] - (case unknowns - #Nil - (do Lux/Monad - [output' (map% Lux/Monad - (: (-> Importation (Lux (List AST))) - (lambda [import] - (case import - [m-name m-alias m-referrals m-openings] - (do Lux/Monad - [defs (case m-referrals - #All - (exported-defs m-name) - - (#Only +defs) - (do Lux/Monad - [*defs (exported-defs m-name)] - (wrap (filter (is-member? +defs) *defs))) - - (#Exclude -defs) - (do Lux/Monad - [*defs (exported-defs m-name)] - (wrap (filter (. not (is-member? -defs)) *defs))) - - #Nothing - (wrap (@list))) - #let [openings (: (List AST) - (case m-openings - #None - (@list) - - (#Some prefix structs) - (map (: (-> Ident AST) - (lambda [struct] - (let [[_ name] struct] - (` (open (~ (symbol$ [m-name name])) (~ (text$ prefix))))))) - structs)))]] - (wrap ($ list:++ - (: (List AST) (@list (` (;_lux_import (~ (text$ m-name)))))) - (: (List AST) - (case m-alias - #None (@list) - (#Some alias) (@list (` (;_lux_alias (~ (text$ alias)) (~ (text$ m-name))))))) - (map (: (-> Text AST) - (lambda [def] - (` (;_lux_def (~ (symbol$ ["" def])) (~ (symbol$ [m-name def])))))) - defs) - openings)))))) - imports)] - (wrap (list:join output'))) - - _ - (wrap (list:++ (map (: (-> Text AST) (lambda [m-name] (` (;_lux_import (~ (text$ m-name)))))) - unknowns) - (: (List AST) (@list (` (;import (~@ tokens)))))))))) - -(def (foldL% M f x ys) - (All [m a b] - (-> (Monad m) (-> a b (m a)) a (List b) - (m a))) - (case ys - (#Cons y ys') - (do M - [x' (f x y)] - (foldL% M f x' ys')) - - #Nil - ((get@ #return M) x))) - -(defmacro #export (:: tokens) - (case tokens - (\ (@list& start parts)) - (do Lux/Monad - [output (foldL% Lux/Monad - (: (-> AST AST (Lux AST)) - (lambda [so-far part] - (case part - [_ (#SymbolS slot)] - (return (` (using (~ so-far) (~ (symbol$ slot))))) - - (\ [_ (#FormS (@list& [_ (#SymbolS slot)] args))]) - (return (` ((using (~ so-far) (~ (symbol$ slot))) - (~@ args)))) - - _ - (fail "Wrong syntax for ::")))) - start parts)] - (return (@list output))) - - _ - (fail "Wrong syntax for ::"))) - -(defmacro #export (set@ tokens) - (case tokens - (\ (@list [_ (#TagS slot')] value record)) - (do Lux/Monad - [slot (normalize slot') - output (resolve-tag slot) - #let [[idx tags type] output]] - (case (resolve-struct-type type) - (#Some members) - (do Lux/Monad - [pattern' (map% Lux/Monad - (: (-> (, Ident (, Int Type)) (Lux (, Ident Int AST))) - (lambda [[r-slot-name [r-idx r-type]]] - (do Lux/Monad - [g!slot (gensym "")] - (return [r-slot-name r-idx g!slot])))) - (zip2 tags (enumerate members)))] - (let [pattern (record$ (map (: (-> (, Ident Int AST) (, AST AST)) - (lambda [[r-slot-name r-idx r-var]] - [(tag$ r-slot-name) r-var])) - pattern')) - output (record$ (map (: (-> (, Ident Int AST) (, AST AST)) - (lambda [[r-slot-name r-idx r-var]] - [(tag$ r-slot-name) (if (i= idx r-idx) - value - r-var)])) - pattern'))] - (return (@list (` (;_lux_case (~ record) (~ pattern) (~ output))))))) - - _ - (fail "set@ can only use records."))) - - _ - (fail "Wrong syntax for set@"))) - -(defmacro #export (update@ tokens) - (case tokens - (\ (@list [_ (#TagS slot')] fun record)) - (do Lux/Monad - [slot (normalize slot') - output (resolve-tag slot) - #let [[idx tags type] output]] - (case (resolve-struct-type type) - (#Some members) - (do Lux/Monad - [pattern' (map% Lux/Monad - (: (-> (, Ident (, Int Type)) (Lux (, Ident Int AST))) - (lambda [[r-slot-name [r-idx r-type]]] - (do Lux/Monad - [g!slot (gensym "")] - (return [r-slot-name r-idx g!slot])))) - (zip2 tags (enumerate members)))] - (let [pattern (record$ (map (: (-> (, Ident Int AST) (, AST AST)) - (lambda [[r-slot-name r-idx r-var]] - [(tag$ r-slot-name) r-var])) - pattern')) - output (record$ (map (: (-> (, Ident Int AST) (, AST AST)) - (lambda [[r-slot-name r-idx r-var]] - [(tag$ r-slot-name) (if (i= idx r-idx) - (` ((~ fun) (~ r-var))) - r-var)])) - pattern'))] - (return (@list (` (;_lux_case (~ record) (~ pattern) (~ output))))))) - - _ - (fail "update@ can only use records."))) - - _ - (fail "Wrong syntax for update@"))) - -(defmacro #export (\template tokens) - (case tokens - (\ (@list [_ (#TupleS data)] - [_ (#TupleS bindings)] - [_ (#TupleS templates)])) - (case (: (Maybe (List AST)) - (do Maybe/Monad - [bindings' (map% Maybe/Monad get-name bindings) - data' (map% Maybe/Monad tuple->list data)] - (let [apply (: (-> RepEnv (List AST)) - (lambda [env] (map (apply-template env) templates)))] - (|> data' - (join-map (. apply (make-env bindings'))) - wrap)))) - (#Some output) - (return output) - - #None - (fail "Wrong syntax for \\template")) - - _ - (fail "Wrong syntax for \\template"))) - -(def (interleave xs ys) - (All [a] (-> (List a) (List a) (List a))) - (case xs - #Nil - #Nil - - (#Cons x xs') - (case ys - #Nil - #Nil - - (#Cons y ys') - (@list& x y (interleave xs' ys'))))) - -(do-template [<name> <init> <op>] - [(def (<name> p xs) - (All [a] - (-> (-> a Bool) (List a) Bool)) - (foldL (lambda [_1 _2] (<op> _1 (p _2))) <init> xs))] - - [every? true and]) - -(def (type->ast type) - (-> Type AST) - (case type - (#DataT name params) - (` (#DataT (~ (text$ name)) (~ (untemplate-list (map type->ast params))))) - - (#;VariantT cases) - (` (#VariantT (~ (untemplate-list (map type->ast cases))))) - - (#TupleT parts) - (` (#TupleT (~ (untemplate-list (map type->ast parts))))) - - (#LambdaT in out) - (` (#LambdaT (~ (type->ast in)) (~ (type->ast out)))) - - (#BoundT idx) - (` (#BoundT (~ (int$ idx)))) - - (#VarT id) - (` (#VarT (~ (int$ id)))) - - (#ExT id) - (` (#ExT (~ (int$ id)))) - - (#UnivQ env type) - (let [env' (untemplate-list (map type->ast env))] - (` (#UnivQ (~ env') (~ (type->ast type))))) - - (#ExQ env type) - (let [env' (untemplate-list (map type->ast env))] - (` (#ExQ (~ env') (~ (type->ast type))))) - - (#AppT fun arg) - (` (#AppT (~ (type->ast fun)) (~ (type->ast arg)))) - - (#NamedT [module name] type) - (` (#NamedT [(~ (text$ module)) (~ (text$ name))] (~ (type->ast type)))))) - -(defmacro #export (loop tokens) - (case tokens - (\ (@list [_ (#TupleS bindings)] body)) - (let [pairs (as-pairs bindings) - vars (map first pairs) - inits (map second pairs)] - (if (every? symbol? inits) - (do Lux/Monad - [inits' (: (Lux (List Ident)) - (case (map% Maybe/Monad get-ident inits) - (#Some inits') (return inits') - #None (fail "Wrong syntax for loop"))) - init-types (map% Lux/Monad find-var-type inits') - expected expected-type] - (return (@list (` ((: (-> (~@ (map type->ast init-types)) - (~ (type->ast expected))) - (lambda (~ (symbol$ ["" "recur"])) [(~@ vars)] - (~ body))) - (~@ inits)))))) - (do Lux/Monad - [aliases (map% Lux/Monad - (: (-> AST (Lux AST)) - (lambda [_] (gensym ""))) - inits)] - (return (@list (` (let [(~@ (interleave aliases inits))] - (;loop [(~@ (interleave vars aliases))] - (~ body))))))))) - - _ - (fail "Wrong syntax for loop"))) - -(defmacro #export (export tokens) - (return (map (: (-> AST AST) (lambda [token] (` (;_lux_export (~ token))))) tokens))) - -(defmacro #export (\slots tokens) - (case tokens - (\ (@list body [_ (#TupleS (@list& hslot' tslots'))])) - (do Lux/Monad - [slots (: (Lux (, Ident (List Ident))) - (case (: (Maybe (, Ident (List Ident))) - (do Maybe/Monad - [hslot (get-tag hslot') - tslots (map% Maybe/Monad get-tag tslots')] - (wrap [hslot tslots]))) - (#Some slots) - (return slots) - - #None - (fail "Wrong syntax for \\slots"))) - #let [[hslot tslots] slots] - hslot (normalize hslot) - tslots (map% Lux/Monad normalize tslots) - output (resolve-tag hslot) - g!_ (gensym "_") - #let [[idx tags type] output - slot-pairings (map (: (-> Ident (, Text AST)) - (lambda [[module name]] [name (symbol$ ["" name])])) - (@list& hslot tslots)) - pattern (record$ (map (: (-> Ident (, AST AST)) - (lambda [[module name]] - (let [tag (tag$ [module name])] - (case (get name slot-pairings) - (#Some binding) [tag binding] - #None [tag g!_])))) - tags))]] - (return (@list pattern body))) - - _ - (fail "Wrong syntax for \\slots"))) - -(do-template [<name> <diff>] - [(def #export <name> - (-> Int Int) - (i+ <diff>))] - - [inc 1] - [dec -1]) |