## 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 [ ] [(def''' ( x y) (-> Bool) ( x y))] [i= _jvm_leq Int] [i> _jvm_lgt Int] [i< _jvm_llt Int] ) (do-template [ ] [(def''' ( x y) (-> Bool) (if ( x y) true ( x y)))] [i>= i> i= Int] [i<= i< i= Int] ) (do-template [ ] [(def''' ( x y) (-> ) ( 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 [ ] [(def''' ( xy) (All [a b] (-> (, a b) )) (let' [[x y] xy] ))] [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 [
] [(defmacro #export ( tokens) (case (reverse tokens) (\ (@list& last init)) (return (@list (foldL (: (-> AST AST AST) (lambda [post pre] (` ))) last init))) _ (fail )))] [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 [ ] [(def ( p xs) (All [a] (-> (-> a Bool) (List a) Bool)) (foldL (lambda [_1 _2] ( _1 (p _2))) 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 [ ] [(def #export (-> Int Int) (i+ ))] [inc 1] [dec -1])