## Basic types ("lux def" dummy-cursor ("lux check" (+2 (+0 "#Text" (+0)) (+2 (+0 "#I64" (+1 (+0 "#Nat" (+0)) (+0))) (+0 "#I64" (+1 (+0 "#Nat" (+0)) (+0))))) ["" +0 +0]) [["" +0 +0] (+10 (+1 [[["" +0 +0] (+7 ["lux" "export?"])] [["" +0 +0] (+0 true)]] (+0)))]) ## (type: Any ## (Ex [a] a)) ("lux def" Any (+10 ["lux" "Any"] (+8 (+0) (+4 +1))) [dummy-cursor (+10 (+1 [[dummy-cursor (+7 ["lux" "type?"])] [dummy-cursor (+0 true)]] (+1 [[dummy-cursor (+7 ["lux" "export?"])] [dummy-cursor (+0 true)]] (+1 [[dummy-cursor (+7 ["lux" "doc"])] [dummy-cursor (+5 "The type of things whose type does not matter. It can be used to write functions or data-structures that can take, or return, anything.")]] (+0)))))]) ## (type: Nothing ## (All [a] a)) ("lux def" Nothing (+10 ["lux" "Nothing"] (+7 (+0) (+4 +1))) [dummy-cursor (+10 (+1 [[dummy-cursor (+7 ["lux" "type?"])] [dummy-cursor (+0 true)]] (+1 [[dummy-cursor (+7 ["lux" "export?"])] [dummy-cursor (+0 true)]] (+1 [[dummy-cursor (+7 ["lux" "doc"])] [dummy-cursor (+5 "The type of things whose type is unknown or undefined. Useful for expressions that cause errors or other \"extraordinary\" conditions.")]] (+0)))))]) ## (type: (List a) ## #Nil ## (#Cons a (List a))) ("lux def" List (+10 ["lux" "List"] (+7 (+0) (+1 ## "lux.Nil" Any ## "lux.Cons" (+2 (+4 +1) (+9 (+4 +1) (+4 +0)))))) [dummy-cursor (+10 (+1 [[dummy-cursor (+7 ["lux" "type?"])] [dummy-cursor (+0 true)]] (+1 [[dummy-cursor (+7 ["lux" "export?"])] [dummy-cursor (+0 true)]] (+1 [[dummy-cursor (+7 ["lux" "tags"])] [dummy-cursor (+9 (+1 [dummy-cursor (+5 "Nil")] (+1 [dummy-cursor (+5 "Cons")] (+0))))]] (+1 [[dummy-cursor (+7 ["lux" "type-args"])] [dummy-cursor (+9 (+1 [dummy-cursor (+5 "a")] (+0)))]] (+1 [[dummy-cursor (+7 ["lux" "doc"])] [dummy-cursor (+5 "A potentially empty list of values.")]] (+0)))))))]) ("lux def" Bool (+10 ["lux" "Bool"] (+0 "#Bool" #Nil)) [dummy-cursor (+10 (#Cons [[dummy-cursor (+7 ["lux" "type?"])] [dummy-cursor (+0 true)]] (#Cons [[dummy-cursor (+7 ["lux" "export?"])] [dummy-cursor (+0 true)]] (#Cons [[dummy-cursor (+7 ["lux" "doc"])] [dummy-cursor (+5 "Your standard, run-of-the-mill boolean values.")]] #Nil))))]) ("lux def" I64 (+10 ["lux" "I64"] (+7 (+0) (+0 "#I64" (#Cons (+4 +1) #Nil)))) [dummy-cursor (+10 (#Cons [[dummy-cursor (+7 ["lux" "type?"])] [dummy-cursor (+0 true)]] (#Cons [[dummy-cursor (+7 ["lux" "export?"])] [dummy-cursor (+0 true)]] (#Cons [[dummy-cursor (+7 ["lux" "doc"])] [dummy-cursor (+5 "64-bit integers without any semantics.")]] #Nil))))]) ("lux def" Nat (+10 ["lux" "Nat"] (+0 "#I64" (#Cons (+0 "#Nat" #Nil) #Nil))) [dummy-cursor (+10 (#Cons [[dummy-cursor (+7 ["lux" "type?"])] [dummy-cursor (+0 true)]] (#Cons [[dummy-cursor (+7 ["lux" "export?"])] [dummy-cursor (+0 true)]] (#Cons [[dummy-cursor (+7 ["lux" "doc"])] [dummy-cursor (+5 "Natural numbers (unsigned integers). They start at zero (+0) and extend in the positive direction.")]] #Nil))))]) ("lux def" Int (+10 ["lux" "Int"] (+0 "#I64" (#Cons (+0 "#Int" #Nil) #Nil))) [dummy-cursor (+10 (#Cons [[dummy-cursor (+7 ["lux" "type?"])] [dummy-cursor (+0 true)]] (#Cons [[dummy-cursor (+7 ["lux" "export?"])] [dummy-cursor (+0 true)]] (#Cons [[dummy-cursor (+7 ["lux" "doc"])] [dummy-cursor (+5 "Your standard, run-of-the-mill integer numbers.")]] #Nil))))]) ("lux def" Deg (+10 ["lux" "Deg"] (+0 "#I64" (#Cons (+0 "#Deg" #Nil) #Nil))) [dummy-cursor (+10 (#Cons [[dummy-cursor (+7 ["lux" "type?"])] [dummy-cursor (+0 true)]] (#Cons [[dummy-cursor (+7 ["lux" "export?"])] [dummy-cursor (+0 true)]] (#Cons [[dummy-cursor (+7 ["lux" "doc"])] [dummy-cursor (+5 "Fractional numbers that live in the interval [0,1). Useful for probability, and other domains that work within that interval.")]] #Nil))))]) ("lux def" Frac (+10 ["lux" "Frac"] (+0 "#Frac" #Nil)) [dummy-cursor (+10 (#Cons [[dummy-cursor (+7 ["lux" "type?"])] [dummy-cursor (+0 true)]] (#Cons [[dummy-cursor (+7 ["lux" "export?"])] [dummy-cursor (+0 true)]] (#Cons [[dummy-cursor (+7 ["lux" "doc"])] [dummy-cursor (+5 "Your standard, run-of-the-mill floating-point (fractional) numbers.")]] #Nil))))]) ("lux def" Text (+10 ["lux" "Text"] (+0 "#Text" #Nil)) [dummy-cursor (+10 (#Cons [[dummy-cursor (+7 ["lux" "type?"])] [dummy-cursor (+0 true)]] (#Cons [[dummy-cursor (+7 ["lux" "export?"])] [dummy-cursor (+0 true)]] (#Cons [[dummy-cursor (+7 ["lux" "doc"])] [dummy-cursor (+5 "Your standard, run-of-the-mill string values.")]] #Nil))))]) ("lux def" Ident (+10 ["lux" "Ident"] (+2 Text Text)) [dummy-cursor (+10 (#Cons [[dummy-cursor (+7 ["lux" "type?"])] [dummy-cursor (+0 true)]] (#Cons [[dummy-cursor (+7 ["lux" "export?"])] [dummy-cursor (+0 true)]] (#Cons [[dummy-cursor (+7 ["lux" "doc"])] [dummy-cursor (+5 "An identifier. It is used as part of Lux syntax to represent symbols and tags.")]] #Nil))))]) ## (type: (Maybe a) ## #None ## (#Some a)) ("lux def" Maybe (+10 ["lux" "Maybe"] (+7 #Nil (+1 ## "lux.None" Any ## "lux.Some" (+4 +1)))) [dummy-cursor (+10 (#Cons [[dummy-cursor (+7 ["lux" "type?"])] [dummy-cursor (+0 true)]] (#Cons [[dummy-cursor (+7 ["lux" "export?"])] [dummy-cursor (+0 true)]] (#Cons [[dummy-cursor (+7 ["lux" "tags"])] [dummy-cursor (+9 (#Cons [dummy-cursor (+5 "None")] (#Cons [dummy-cursor (+5 "Some")] #Nil)))]] (#Cons [[dummy-cursor (+7 ["lux" "type-args"])] [dummy-cursor (+9 (#Cons [dummy-cursor (+5 "a")] #Nil))]] (#Cons [[dummy-cursor (+7 ["lux" "doc"])] [dummy-cursor (+5 "A potentially missing value.")]] #Nil))))))]) ## (type: #rec Type ## (#Primitive Text (List Type)) ## (#Sum Type Type) ## (#Product Type Type) ## (#Function Type Type) ## (#Bound Nat) ## (#Var Nat) ## (#Ex Nat) ## (#UnivQ (List Type) Type) ## (#ExQ (List Type) Type) ## (#Apply Type Type) ## (#Named Ident Type) ## ) ("lux def" Type (+10 ["lux" "Type"] ("lux case" ("lux check type" (+9 (+4 +1) (+4 +0))) {Type ("lux case" ("lux check type" (+9 Type List)) {Type-List ("lux case" ("lux check type" (+2 Type Type)) {Type-Pair (+9 Nothing (+7 #Nil (+1 ## "lux.Primitive" (+2 Text Type-List) (+1 ## "lux.Sum" Type-Pair (+1 ## "lux.Product" Type-Pair (+1 ## "lux.Function" Type-Pair (+1 ## "lux.Bound" Nat (+1 ## "lux.Var" Nat (+1 ## "lux.Ex" Nat (+1 ## "lux.UnivQ" (+2 Type-List Type) (+1 ## "lux.ExQ" (+2 Type-List Type) (+1 ## "lux.Apply" Type-Pair ## "lux.Named" (+2 Ident Type)))))))))))))})})})) [dummy-cursor (+10 (#Cons [[dummy-cursor (+7 ["lux" "type?"])] [dummy-cursor (+0 true)]] (#Cons [[dummy-cursor (+7 ["lux" "export?"])] [dummy-cursor (+0 true)]] (#Cons [[dummy-cursor (+7 ["lux" "tags"])] [dummy-cursor (+9 (#Cons [dummy-cursor (+5 "Primitive")] (#Cons [dummy-cursor (+5 "Sum")] (#Cons [dummy-cursor (+5 "Product")] (#Cons [dummy-cursor (+5 "Function")] (#Cons [dummy-cursor (+5 "Bound")] (#Cons [dummy-cursor (+5 "Var")] (#Cons [dummy-cursor (+5 "Ex")] (#Cons [dummy-cursor (+5 "UnivQ")] (#Cons [dummy-cursor (+5 "ExQ")] (#Cons [dummy-cursor (+5 "Apply")] (#Cons [dummy-cursor (+5 "Named")] #Nil))))))))))))]] (#Cons [[dummy-cursor (+7 ["lux" "doc"])] [dummy-cursor (+5 "This type represents the data-structures that are used to specify types themselves.")]] (#Cons [[dummy-cursor (+7 ["lux" "type-rec?"])] [dummy-cursor (+0 true)]] #Nil))))))]) ## (type: Cursor ## {#module Text ## #line Nat ## #column Nat}) ("lux def" Cursor (#Named ["lux" "Cursor"] (#Product Text (#Product Nat Nat))) [dummy-cursor (+10 (#Cons [[dummy-cursor (+7 ["lux" "tags"])] [dummy-cursor (+9 (#Cons [dummy-cursor (+5 "module")] (#Cons [dummy-cursor (+5 "line")] (#Cons [dummy-cursor (+5 "column")] #Nil))))]] (#Cons [[dummy-cursor (+7 ["lux" "doc"])] [dummy-cursor (+5 "Cursors are for specifying the location of Code nodes in Lux files during compilation.")]] (#Cons [[dummy-cursor (+7 ["lux" "type?"])] [dummy-cursor (+0 true)]] (#Cons [[dummy-cursor (+7 ["lux" "export?"])] [dummy-cursor (+0 true)]] #Nil)))))]) ## (type: (Ann m v) ## {#meta m ## #datum v}) ("lux def" Ann (#Named ["lux" "Ann"] (#UnivQ #Nil (#UnivQ #Nil (#Product (#Bound +3) (#Bound +1))))) [dummy-cursor (+10 (#Cons [[dummy-cursor (+7 ["lux" "tags"])] [dummy-cursor (+9 (#Cons [dummy-cursor (+5 "meta")] (#Cons [dummy-cursor (+5 "datum")] #Nil)))]] (#Cons [[dummy-cursor (+7 ["lux" "doc"])] [dummy-cursor (+5 "The type of things that can be annotated with meta-data of arbitrary types.")]] (#Cons [[dummy-cursor (+7 ["lux" "type-args"])] [dummy-cursor (+9 (#Cons [dummy-cursor (+5 "m")] (#Cons [dummy-cursor (+5 "v")] #Nil)))]] (#Cons [[dummy-cursor (+7 ["lux" "type?"])] [dummy-cursor (+0 true)]] (#Cons [[dummy-cursor (+7 ["lux" "export?"])] [dummy-cursor (+0 true)]] #Nil))))))]) ## (type: (Code' w) ## (#Bool Bool) ## (#Nat Nat) ## (#Int Int) ## (#Deg Deg) ## (#Frac Frac) ## (#Text Text) ## (#Symbol Text Text) ## (#Tag Text Text) ## (#Form (List (w (Code' w)))) ## (#Tuple (List (w (Code' w)))) ## (#Record (List [(w (Code' w)) (w (Code' w))]))) ("lux def" Code' (#Named ["lux" "Code'"] ("lux case" ("lux check type" (#Apply (#Apply (#Bound +1) (#Bound +0)) (#Bound +1))) {Code ("lux case" ("lux check type" (#Apply Code List)) {Code-List (#UnivQ #Nil (#Sum ## "lux.Bool" Bool (#Sum ## "lux.Nat" Nat (#Sum ## "lux.Int" Int (#Sum ## "lux.Deg" Deg (#Sum ## "lux.Frac" Frac (#Sum ## "lux.Text" Text (#Sum ## "lux.Symbol" Ident (#Sum ## "lux.Tag" Ident (#Sum ## "lux.Form" Code-List (#Sum ## "lux.Tuple" Code-List ## "lux.Record" (#Apply (#Product Code Code) List) )))))))))) )})})) [dummy-cursor (+10 (#Cons [[dummy-cursor (+7 ["lux" "tags"])] [dummy-cursor (+9 (#Cons [dummy-cursor (+5 "Bool")] (#Cons [dummy-cursor (+5 "Nat")] (#Cons [dummy-cursor (+5 "Int")] (#Cons [dummy-cursor (+5 "Deg")] (#Cons [dummy-cursor (+5 "Frac")] (#Cons [dummy-cursor (+5 "Text")] (#Cons [dummy-cursor (+5 "Symbol")] (#Cons [dummy-cursor (+5 "Tag")] (#Cons [dummy-cursor (+5 "Form")] (#Cons [dummy-cursor (+5 "Tuple")] (#Cons [dummy-cursor (+5 "Record")] #Nil))))))))))))]] (#Cons [[dummy-cursor (+7 ["lux" "type-args"])] [dummy-cursor (+9 (#Cons [dummy-cursor (+5 "w")] #Nil))]] (#Cons [[dummy-cursor (+7 ["lux" "type?"])] [dummy-cursor (+0 true)]] (#Cons [[dummy-cursor (+7 ["lux" "export?"])] [dummy-cursor (+0 true)]] #Nil)))))]) ## (type: Code ## (Ann Cursor (Code' (Ann Cursor)))) ("lux def" Code (#Named ["lux" "Code"] ("lux case" ("lux check type" (#Apply Cursor Ann)) {w (#Apply (#Apply w Code') w)})) [dummy-cursor (#Record (#Cons [[dummy-cursor (#Tag ["lux" "doc"])] [dummy-cursor (#Text "The type of Code nodes for Lux syntax.")]] (#Cons [[dummy-cursor (#Tag ["lux" "type?"])] [dummy-cursor (#Bool true)]] (#Cons [[dummy-cursor (#Tag ["lux" "export?"])] [dummy-cursor (#Bool true)]] #Nil))))]) ("lux def" _ann ("lux check" (#Function (#Apply (#Apply Cursor Ann) Code') Code) ("lux function" _ data [dummy-cursor data])) [dummy-cursor (#Record #Nil)]) ("lux def" bool$ ("lux check" (#Function Bool Code) ("lux function" _ value (_ann (#Bool value)))) [dummy-cursor (#Record #Nil)]) ("lux def" nat$ ("lux check" (#Function Nat Code) ("lux function" _ value (_ann (#Nat value)))) [dummy-cursor (#Record #Nil)]) ("lux def" int$ ("lux check" (#Function Int Code) ("lux function" _ value (_ann (#Int value)))) [dummy-cursor (#Record #Nil)]) ("lux def" deg$ ("lux check" (#Function Deg Code) ("lux function" _ value (_ann (#Deg value)))) [dummy-cursor (#Record #Nil)]) ("lux def" frac$ ("lux check" (#Function Frac Code) ("lux function" _ value (_ann (#Frac value)))) [dummy-cursor (#Record #Nil)]) ("lux def" text$ ("lux check" (#Function Text Code) ("lux function" _ text (_ann (#Text text)))) [dummy-cursor (#Record #Nil)]) ("lux def" symbol$ ("lux check" (#Function Ident Code) ("lux function" _ ident (_ann (#Symbol ident)))) [dummy-cursor (#Record #Nil)]) ("lux def" tag$ ("lux check" (#Function Ident Code) ("lux function" _ ident (_ann (#Tag ident)))) [dummy-cursor (#Record #Nil)]) ("lux def" form$ ("lux check" (#Function (#Apply Code List) Code) ("lux function" _ tokens (_ann (#Form tokens)))) [dummy-cursor (#Record #Nil)]) ("lux def" tuple$ ("lux check" (#Function (#Apply Code List) Code) ("lux function" _ tokens (_ann (#Tuple tokens)))) [dummy-cursor (#Record #Nil)]) ("lux def" record$ ("lux check" (#Function (#Apply (#Product Code Code) List) Code) ("lux function" _ tokens (_ann (#Record tokens)))) [dummy-cursor (#Record #Nil)]) ("lux def" default-def-meta-exported ("lux check" (#Apply (#Product Code Code) List) (#Cons [(tag$ ["lux" "type?"]) (bool$ true)] (#Cons [(tag$ ["lux" "export?"]) (bool$ true)] #Nil))) (record$ #Nil)) ("lux def" default-def-meta-unexported ("lux check" (#Apply (#Product Code Code) List) (#Cons [(tag$ ["lux" "type?"]) (bool$ true)] #Nil)) (record$ #Nil)) ## (type: Definition ## [Type Code Any]) ("lux def" Definition (#Named ["lux" "Definition"] (#Product Type (#Product Code Any))) (record$ (#Cons [(tag$ ["lux" "doc"]) (text$ "Represents all the data associated with a definition: its type, its annotations, and its value.")] default-def-meta-exported))) ## (type: (Bindings k v) ## {#counter Nat ## #mappings (List [k v])}) ("lux def" Bindings (#Named ["lux" "Bindings"] (#UnivQ #Nil (#UnivQ #Nil (#Product ## "lux.counter" Nat ## "lux.mappings" (#Apply (#Product (#Bound +3) (#Bound +1)) List))))) (record$ (#Cons [(tag$ ["lux" "tags"]) (tuple$ (#Cons (text$ "counter") (#Cons (text$ "mappings") #Nil)))] (#Cons [(tag$ ["lux" "type-args"]) (tuple$ (#Cons (text$ "k") (#Cons (text$ "v") #Nil)))] default-def-meta-exported)))) ## (type: #export Ref ## (#Local Nat) ## (#Captured Nat)) ("lux def" Ref (#Named ["lux" "Ref"] (#Sum ## Local Nat ## Captured Nat)) (record$ (#Cons [(tag$ ["lux" "tags"]) (tuple$ (#Cons (text$ "Local") (#Cons (text$ "Captured") #Nil)))] default-def-meta-exported))) ## (type: Scope ## {#name (List Text) ## #inner Nat ## #locals (Bindings Text [Type Nat]) ## #captured (Bindings Text [Type Ref])}) ("lux def" Scope (#Named ["lux" "Scope"] (#Product ## name (#Apply Text List) (#Product ## inner Nat (#Product ## locals (#Apply (#Product Type Nat) (#Apply Text Bindings)) ## captured (#Apply (#Product Type Ref) (#Apply Text Bindings)))))) (record$ (#Cons [(tag$ ["lux" "tags"]) (tuple$ (#Cons (text$ "name") (#Cons (text$ "inner") (#Cons (text$ "locals") (#Cons (text$ "captured") #Nil)))))] default-def-meta-exported))) ("lux def" Code-List (#Apply Code List) (record$ default-def-meta-unexported)) ## (type: (Either l r) ## (#Left l) ## (#Right r)) ("lux def" Either (#Named ["lux" "Either"] (#UnivQ #Nil (#UnivQ #Nil (#Sum ## "lux.Left" (#Bound +3) ## "lux.Right" (#Bound +1))))) (record$ (#Cons [(tag$ ["lux" "tags"]) (tuple$ (#Cons (text$ "Left") (#Cons (text$ "Right") #Nil)))] (#Cons [(tag$ ["lux" "type-args"]) (tuple$ (#Cons (text$ "l") (#Cons (text$ "r") #Nil)))] (#Cons [(tag$ ["lux" "doc"]) (text$ "A choice between two values of different types.")] default-def-meta-exported))))) ## (type: Source ## [Cursor Nat Text]) ("lux def" Source (#Named ["lux" "Source"] (#Product Cursor (#Product Nat Text))) (record$ default-def-meta-exported)) ## (type: Module-State ## #Active ## #Compiled ## #Cached) ("lux def" Module-State (#Named ["lux" "Module-State"] (#Sum ## #Active Any (#Sum ## #Compiled Any ## #Cached Any))) (record$ (#Cons [(tag$ ["lux" "tags"]) (tuple$ (#Cons (text$ "Active") (#Cons (text$ "Compiled") (#Cons (text$ "Cached") #Nil))))] default-def-meta-exported))) ## (type: Module ## {#module-hash Nat ## #module-aliases (List [Text Text]) ## #definitions (List [Text Definition]) ## #imports (List Text) ## #tags (List [Text [Nat (List Ident) Bool Type]]) ## #types (List [Text [(List Ident) Bool Type]]) ## #module-annotations (Maybe Code) ## #module-state Module-State}) ("lux def" Module (#Named ["lux" "Module"] (#Product ## "lux.module-hash" Nat (#Product ## "lux.module-aliases" (#Apply (#Product Text Text) List) (#Product ## "lux.definitions" (#Apply (#Product Text Definition) List) (#Product ## "lux.imports" (#Apply Text List) (#Product ## "lux.tags" (#Apply (#Product Text (#Product Nat (#Product (#Apply Ident List) (#Product Bool Type)))) List) (#Product ## "lux.types" (#Apply (#Product Text (#Product (#Apply Ident List) (#Product Bool Type))) List) (#Product ## "lux.module-annotations" (#Apply Code Maybe) Module-State)) )))))) (record$ (#Cons [(tag$ ["lux" "tags"]) (tuple$ (#Cons (text$ "module-hash") (#Cons (text$ "module-aliases") (#Cons (text$ "definitions") (#Cons (text$ "imports") (#Cons (text$ "tags") (#Cons (text$ "types") (#Cons (text$ "module-annotations") (#Cons (text$ "module-state") #Nil)))))))))] (#Cons [(tag$ ["lux" "doc"]) (text$ "All the information contained within a Lux module.")] default-def-meta-exported)))) ## (type: Type-Context ## {#ex-counter Nat ## #var-counter Nat ## #var-bindings (List [Nat (Maybe Type)])}) ("lux def" Type-Context (#Named ["lux" "Type-Context"] (#Product ## ex-counter Nat (#Product ## var-counter Nat ## var-bindings (#Apply (#Product Nat (#Apply Type Maybe)) List)))) (record$ (#Cons [(tag$ ["lux" "tags"]) (tuple$ (#Cons (text$ "ex-counter") (#Cons (text$ "var-counter") (#Cons (text$ "var-bindings") #Nil))))] default-def-meta-exported))) ## (type: Mode ## #Build ## #Eval ## #REPL) ("lux def" Mode (#Named ["lux" "Mode"] (#Sum ## Build Any (#Sum ## Eval Any ## REPL Any))) (record$ (#Cons [(tag$ ["lux" "tags"]) (tuple$ (#Cons (text$ "Build") (#Cons (text$ "Eval") (#Cons (text$ "REPL") #Nil))))] (#Cons [(tag$ ["lux" "doc"]) (text$ "A sign that shows the conditions under which the compiler is running.")] default-def-meta-exported)))) ## (type: Info ## {#target Text ## #version Text ## #mode Mode}) ("lux def" Info (#Named ["lux" "Info"] (#Product ## target Text (#Product ## version Text ## mode Mode))) (record$ (#Cons [(tag$ ["lux" "tags"]) (tuple$ (#Cons (text$ "target") (#Cons (text$ "version") (#Cons (text$ "mode") #Nil))))] (#Cons [(tag$ ["lux" "doc"]) (text$ "Information about the current version and type of compiler that is running.")] default-def-meta-exported)))) ## (type: Lux ## {#info Info ## #source Source ## #cursor Cursor ## #current-module (Maybe Text) ## #modules (List [Text Module]) ## #scopes (List Scope) ## #type-context Type-Context ## #expected (Maybe Type) ## #seed Nat ## #scope-type-vars (List Nat) ## #extensions Nothing ## #host Nothing}) ("lux def" Lux (#Named ["lux" "Lux"] (#Product ## "lux.info" Info (#Product ## "lux.source" Source (#Product ## "lux.cursor" Cursor (#Product ## "lux.current-module" (#Apply Text Maybe) (#Product ## "lux.modules" (#Apply (#Product Text Module) List) (#Product ## "lux.scopes" (#Apply Scope List) (#Product ## "lux.type-context" Type-Context (#Product ## "lux.expected" (#Apply Type Maybe) (#Product ## "lux.seed" Nat (#Product ## scope-type-vars (#Apply Nat List) (#Product ## extensions Nothing ## "lux.host" Nothing)))))))))))) (record$ (#Cons [(tag$ ["lux" "tags"]) (tuple$ (#Cons (text$ "info") (#Cons (text$ "source") (#Cons (text$ "cursor") (#Cons (text$ "current-module") (#Cons (text$ "modules") (#Cons (text$ "scopes") (#Cons (text$ "type-context") (#Cons (text$ "expected") (#Cons (text$ "seed") (#Cons (text$ "scope-type-vars") (#Cons (text$ "extensions") (#Cons (text$ "host") #Nil)))))))))))))] (#Cons [(tag$ ["lux" "doc"]) (text$ "Represents the state of the Lux compiler during a run. It is provided to macros during their invocation, so they can access compiler data. Caveat emptor: Avoid fiddling with it, unless you know what you're doing.")] default-def-meta-exported)))) ## (type: (Meta a) ## (-> Lux (Either Text [Lux a]))) ("lux def" Meta (#Named ["lux" "Meta"] (#UnivQ #Nil (#Function Lux (#Apply (#Product Lux (#Bound +1)) (#Apply Text Either))))) (record$ (#Cons [(tag$ ["lux" "doc"]) (text$ "Computations that can have access to the state of the compiler. These computations may fail, or modify the state of the compiler.")] (#Cons [(tag$ ["lux" "type-args"]) (tuple$ (#Cons (text$ "a") #Nil))] default-def-meta-exported)))) ## (type: Macro ## (-> (List Code) (Meta (List Code)))) ("lux def" Macro (#Named ["lux" "Macro"] (#Function Code-List (#Apply Code-List Meta))) (record$ (#Cons [(tag$ ["lux" "doc"]) (text$ "Functions that run at compile-time and allow you to transform and extend the language in powerful ways.")] default-def-meta-exported))) ## Base functions & macros ("lux def" return ("lux check" (#UnivQ #Nil (#Function (#Bound +1) (#Function Lux (#Apply (#Product Lux (#Bound +1)) (#Apply Text Either))))) ("lux function" _ val ("lux function" _ state (#Right state val)))) (record$ #Nil)) ("lux def" fail ("lux check" (#UnivQ #Nil (#Function Text (#Function Lux (#Apply (#Product Lux (#Bound +1)) (#Apply Text Either))))) ("lux function" _ msg ("lux function" _ state (#Left msg)))) (record$ #Nil)) ("lux def" default-macro-meta ("lux check" (#Apply (#Product Code Code) List) (#Cons [(tag$ ["lux" "macro?"]) (bool$ true)] #Nil)) (record$ #Nil)) ("lux def" let'' ("lux check" Macro ("lux function" _ tokens ("lux case" tokens {(#Cons lhs (#Cons rhs (#Cons body #Nil))) (return (#Cons (form$ (#Cons (text$ "lux case") (#Cons rhs (#Cons (record$ (#Cons [lhs body] #Nil)) #Nil)))) #Nil)) _ (fail "Wrong syntax for let''")}))) (record$ default-macro-meta)) ("lux def" function'' ("lux check" Macro ("lux function" _ tokens ("lux case" tokens {(#Cons [_ (#Tuple (#Cons arg args'))] (#Cons body #Nil)) (return (#Cons (_ann (#Form (#Cons (_ann (#Text "lux function")) (#Cons (_ann (#Symbol "" "")) (#Cons arg (#Cons ("lux case" args' {#Nil body _ (_ann (#Form (#Cons (_ann (#Symbol "lux" "function''")) (#Cons (_ann (#Tuple args')) (#Cons body #Nil)))))}) #Nil)))))) #Nil)) (#Cons [_ (#Symbol "" self)] (#Cons [_ (#Tuple (#Cons arg args'))] (#Cons body #Nil))) (return (#Cons (_ann (#Form (#Cons (_ann (#Text "lux function")) (#Cons (_ann (#Symbol "" self)) (#Cons arg (#Cons ("lux case" args' {#Nil body _ (_ann (#Form (#Cons (_ann (#Symbol "lux" "function''")) (#Cons (_ann (#Tuple args')) (#Cons body #Nil)))))}) #Nil)))))) #Nil)) _ (fail "Wrong syntax for function''")}))) (record$ default-macro-meta)) ("lux def" cursor-code ("lux check" Code (tuple$ (#Cons (text$ "") (#Cons (nat$ +0) (#Cons (nat$ +0) #Nil))))) (record$ #Nil)) ("lux def" meta-code ("lux check" (#Function Ident (#Function Code Code)) ("lux function" _ tag ("lux function" _ value (tuple$ (#Cons cursor-code (#Cons (form$ (#Cons (tag$ tag) (#Cons value #Nil))) #Nil)))))) (record$ #Nil)) ("lux def" flag-meta ("lux check" (#Function Text Code) ("lux function" _ tag (tuple$ (#Cons [(meta-code ["lux" "Tag"] (tuple$ (#Cons (text$ "lux") (#Cons (text$ tag) #Nil)))) (#Cons [(meta-code ["lux" "Bool"] (bool$ true)) #Nil])])))) (record$ #Nil)) ("lux def" export-meta ("lux check" (#Product Code Code) [(tag$ ["lux" "export?"]) (bool$ true)]) (record$ #Nil)) ("lux def" export?-meta ("lux check" Code (flag-meta "export?")) (record$ #Nil)) ("lux def" macro?-meta ("lux check" Code (flag-meta "macro?")) (record$ #Nil)) ("lux def" with-export-meta ("lux check" (#Function Code Code) (function'' [tail] (form$ (#Cons (tag$ ["lux" "Cons"]) (#Cons export?-meta (#Cons tail #Nil)))))) (record$ #Nil)) ("lux def" with-macro-meta ("lux check" (#Function Code Code) (function'' [tail] (form$ (#Cons (tag$ ["lux" "Cons"]) (#Cons macro?-meta (#Cons tail #Nil)))))) (record$ #Nil)) ("lux def" doc-meta ("lux check" (#Function Text (#Product Code Code)) (function'' [doc] [(tag$ ["lux" "doc"]) (text$ doc)])) (record$ #Nil)) ("lux def" def:'' ("lux check" Macro (function'' [tokens] ("lux case" tokens {(#Cons [[_ (#Tag ["" "export"])] (#Cons [[_ (#Form (#Cons [name args]))] (#Cons [meta (#Cons [type (#Cons [body #Nil])])])])]) (return (#Cons [(_ann (#Form (#Cons [(_ann (#Text "lux def")) (#Cons [name (#Cons [(_ann (#Form (#Cons [(_ann (#Text "lux check")) (#Cons [type (#Cons [(_ann (#Form (#Cons [(_ann (#Symbol ["lux" "function''"])) (#Cons [name (#Cons [(_ann (#Tuple args)) (#Cons [body #Nil])])])]))) #Nil])])]))) (#Cons (form$ (#Cons (symbol$ ["lux" "record$"]) (#Cons (with-export-meta meta) #Nil))) #Nil)])])]))) #Nil])) (#Cons [[_ (#Tag ["" "export"])] (#Cons [name (#Cons [meta (#Cons [type (#Cons [body #Nil])])])])]) (return (#Cons [(_ann (#Form (#Cons [(_ann (#Text "lux def")) (#Cons [name (#Cons [(_ann (#Form (#Cons [(_ann (#Text "lux check")) (#Cons [type (#Cons [body #Nil])])]))) (#Cons (form$ (#Cons (symbol$ ["lux" "record$"]) (#Cons (with-export-meta meta) #Nil))) #Nil)])])]))) #Nil])) (#Cons [[_ (#Form (#Cons [name args]))] (#Cons [meta (#Cons [type (#Cons [body #Nil])])])]) (return (#Cons [(_ann (#Form (#Cons [(_ann (#Text "lux def")) (#Cons [name (#Cons [(_ann (#Form (#Cons [(_ann (#Text "lux check")) (#Cons [type (#Cons [(_ann (#Form (#Cons [(_ann (#Symbol ["lux" "function''"])) (#Cons [name (#Cons [(_ann (#Tuple args)) (#Cons [body #Nil])])])]))) #Nil])])]))) (#Cons (form$ (#Cons (symbol$ ["lux" "record$"]) (#Cons meta #Nil))) #Nil)])])]))) #Nil])) (#Cons [name (#Cons [meta (#Cons [type (#Cons [body #Nil])])])]) (return (#Cons [(_ann (#Form (#Cons [(_ann (#Text "lux def")) (#Cons [name (#Cons [(_ann (#Form (#Cons [(_ann (#Text "lux check")) (#Cons [type (#Cons [body #Nil])])]))) (#Cons (form$ (#Cons (symbol$ ["lux" "record$"]) (#Cons meta #Nil))) #Nil)])])]))) #Nil])) _ (fail "Wrong syntax for def''")}) )) (record$ default-macro-meta)) (def:'' (macro:' tokens) default-macro-meta Macro ("lux case" tokens {(#Cons [_ (#Form (#Cons name args))] (#Cons body #Nil)) (return (#Cons (form$ (#Cons (symbol$ ["lux" "def:''"]) (#Cons (form$ (#Cons name args)) (#Cons (with-macro-meta (tag$ ["lux" "Nil"])) (#Cons (symbol$ ["lux" "Macro"]) (#Cons body #Nil))) ))) #Nil)) (#Cons [_ (#Tag ["" "export"])] (#Cons [_ (#Form (#Cons name args))] (#Cons body #Nil))) (return (#Cons (form$ (#Cons (symbol$ ["lux" "def:''"]) (#Cons (tag$ ["" "export"]) (#Cons (form$ (#Cons name args)) (#Cons (with-macro-meta (tag$ ["lux" "Nil"])) (#Cons (symbol$ ["lux" "Macro"]) (#Cons body #Nil))) )))) #Nil)) (#Cons [_ (#Tag ["" "export"])] (#Cons [_ (#Form (#Cons name args))] (#Cons meta-data (#Cons body #Nil)))) (return (#Cons (form$ (#Cons (symbol$ ["lux" "def:''"]) (#Cons (tag$ ["" "export"]) (#Cons (form$ (#Cons name args)) (#Cons (with-macro-meta meta-data) (#Cons (symbol$ ["lux" "Macro"]) (#Cons body #Nil))) )))) #Nil)) _ (fail "Wrong syntax for macro:'")})) (macro:' #export (comment tokens) (#Cons [(tag$ ["lux" "doc"]) (text$ "## Throws away any code given to it. ## Great for commenting-out code, while retaining syntax high-lighting and formatting in your text editor. (comment 1 2 3 4)")] #Nil) (return #Nil)) (macro:' ($' 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" "Apply"]) (#Cons y (#Cons x #Nil)))) xs))) #Nil)) _ (fail "Wrong syntax for $'")})) (def:'' (list/map f xs) #Nil (#UnivQ #Nil (#UnivQ #Nil (#Function (#Function (#Bound +3) (#Bound +1)) (#Function ($' List (#Bound +3)) ($' List (#Bound +1)))))) ("lux case" xs {#Nil #Nil (#Cons x xs') (#Cons (f x) (list/map f xs'))})) (def:'' RepEnv #Nil Type ($' List (#Product Text Code))) (def:'' (make-env xs ys) #Nil (#Function ($' List Text) (#Function ($' List Code) RepEnv)) ("lux case" [xs ys] {[(#Cons x xs') (#Cons y ys')] (#Cons [x y] (make-env xs' ys')) _ #Nil})) (def:'' (text/= x y) #Nil (#Function Text (#Function Text Bool)) ("lux text =" x y)) (def:'' (get-rep key env) #Nil (#Function Text (#Function RepEnv ($' Maybe Code))) ("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) #Nil (#Function RepEnv (#Function Code Code)) ("lux case" syntax {[_ (#Symbol "" name)] ("lux case" (get-rep name reps) {(#Some replacement) replacement #None syntax}) [meta (#Form parts)] [meta (#Form (list/map (replace-syntax reps) parts))] [meta (#Tuple members)] [meta (#Tuple (list/map (replace-syntax reps) members))] [meta (#Record slots)] [meta (#Record (list/map ("lux check" (#Function (#Product Code Code) (#Product Code Code)) (function'' [slot] ("lux case" slot {[k v] [(replace-syntax reps k) (replace-syntax reps v)]}))) slots))] _ syntax}) ) (def:'' (n/+ param subject) (#.Cons (doc-meta "Nat(ural) addition.") (#.Cons export-meta #.Nil)) (#Function Nat (#Function Nat Nat)) ("lux i64 +" param subject)) (def:'' (n/- param subject) (#.Cons (doc-meta "Nat(ural) substraction.") (#.Cons export-meta #.Nil)) (#Function Nat (#Function Nat Nat)) ("lux i64 -" param subject)) (def:'' (n/* param subject) (#.Cons (doc-meta "Nat(ural) multiplication.") (#.Cons export-meta #.Nil)) (#Function Nat (#Function Nat Nat)) ("lux coerce" Nat ("lux int *" ("lux coerce" Int subject) ("lux coerce" Int param)))) (def:'' (update-bounds code) #Nil (#Function Code Code) ("lux case" code {[_ (#Tuple members)] (tuple$ (list/map update-bounds members)) [_ (#Record pairs)] (record$ (list/map ("lux check" (#Function (#Product Code Code) (#Product Code Code)) (function'' [pair] (let'' [name val] pair [name (update-bounds val)]))) pairs)) [_ (#Form (#Cons [_ (#Tag "lux" "Bound")] (#Cons [_ (#Nat idx)] #Nil)))] (form$ (#Cons (tag$ ["lux" "Bound"]) (#Cons (nat$ (n/+ +2 idx)) #Nil))) [_ (#Form members)] (form$ (list/map update-bounds members)) _ code})) (def:'' (parse-quantified-args args next) #Nil ## (-> (List Code) (-> (List Text) (Meta (List Code))) (Meta (List Code))) (#Function ($' List Code) (#Function (#Function ($' List Text) (#Apply ($' List Code) Meta)) (#Apply ($' List Code) Meta) )) ("lux case" args {#Nil (next #Nil) (#Cons [_ (#Symbol "" arg-name)] args') (parse-quantified-args args' (function'' [names] (next (#Cons arg-name names)))) _ (fail "Expected symbol.")} )) (def:'' (make-bound idx) #Nil (#Function Nat Code) (form$ (#Cons (tag$ ["lux" "Bound"]) (#Cons (nat$ idx) #Nil)))) (def:'' (list/fold f init xs) #Nil ## (All [a b] (-> (-> b a a) a (List b) a)) (#UnivQ #Nil (#UnivQ #Nil (#Function (#Function (#Bound +1) (#Function (#Bound +3) (#Bound +3))) (#Function (#Bound +3) (#Function ($' List (#Bound +1)) (#Bound +3)))))) ("lux case" xs {#Nil init (#Cons x xs') (list/fold f (f x init) xs')})) (def:'' (list/size list) #Nil (#UnivQ #Nil (#Function ($' List (#Bound +1)) Nat)) (list/fold (function'' [_ acc] (n/+ +1 acc)) +0 list)) (macro:' #export (All tokens) (#Cons [(tag$ ["lux" "doc"]) (text$ "## Universal quantification. (All [a] (-> a a)) ## A name can be provided, to specify a recursive type. (All List [a] (| Any [a (List a)]))")] #Nil) (let'' [self-name tokens] ("lux case" tokens {(#Cons [_ (#Symbol "" self-name)] tokens) [self-name tokens] _ ["" tokens]}) ("lux case" tokens {(#Cons [_ (#Tuple args)] (#Cons body #Nil)) (parse-quantified-args args (function'' [names] (let'' body' (list/fold ("lux check" (#Function Text (#Function Code Code)) (function'' [name' body'] (form$ (#Cons (tag$ ["lux" "UnivQ"]) (#Cons (tag$ ["lux" "Nil"]) (#Cons (replace-syntax (#Cons [name' (make-bound +1)] #Nil) (update-bounds body')) #Nil)))))) body names) (return (#Cons ("lux case" [(text/= "" self-name) names] {[true _] body' [_ #Nil] body' [false _] (replace-syntax (#Cons [self-name (make-bound (n/* +2 (n/- +1 (list/size names))))] #Nil) body')}) #Nil))))) _ (fail "Wrong syntax for All")}) )) (macro:' #export (Ex tokens) (#Cons [(tag$ ["lux" "doc"]) (text$ "## Existential quantification. (Ex [a] [(Codec Text a) a]) ## A name can be provided, to specify a recursive type. (Ex Self [a] [(Codec Text a) a (List (Self a))])")] #Nil) (let'' [self-name tokens] ("lux case" tokens {(#Cons [_ (#Symbol "" self-name)] tokens) [self-name tokens] _ ["" tokens]}) ("lux case" tokens {(#Cons [_ (#Tuple args)] (#Cons body #Nil)) (parse-quantified-args args (function'' [names] (let'' body' (list/fold ("lux check" (#Function Text (#Function Code Code)) (function'' [name' body'] (form$ (#Cons (tag$ ["lux" "ExQ"]) (#Cons (tag$ ["lux" "Nil"]) (#Cons (replace-syntax (#Cons [name' (make-bound +1)] #Nil) (update-bounds body')) #Nil)))))) body names) (return (#Cons ("lux case" [(text/= "" self-name) names] {[true _] body' [_ #Nil] body' [false _] (replace-syntax (#Cons [self-name (make-bound (n/* +2 (n/- +1 (list/size names))))] #Nil) body')}) #Nil))))) _ (fail "Wrong syntax for Ex")}) )) (def:'' (list/reverse list) #Nil (All [a] (#Function ($' List a) ($' List a))) (list/fold ("lux check" (All [a] (#Function a (#Function ($' List a) ($' List a)))) (function'' [head tail] (#Cons head tail))) #Nil list)) (macro:' #export (-> tokens) (#Cons [(tag$ ["lux" "doc"]) (text$ "## Function types: (-> Int Int Int) ## This is the type of a function that takes 2 Ints and returns an Int.")] #Nil) ("lux case" (list/reverse tokens) {(#Cons output inputs) (return (#Cons (list/fold ("lux check" (#Function Code (#Function Code Code)) (function'' [i o] (form$ (#Cons (tag$ ["lux" "Function"]) (#Cons i (#Cons o #Nil)))))) output inputs) #Nil)) _ (fail "Wrong syntax for ->")})) (macro:' #export (list xs) (#Cons [(tag$ ["lux" "doc"]) (text$ "## List-construction macro. (list 1 2 3)")] #Nil) (return (#Cons (list/fold (function'' [head tail] (form$ (#Cons (tag$ ["lux" "Cons"]) (#Cons (tuple$ (#Cons [head (#Cons [tail #Nil])])) #Nil)))) (tag$ ["lux" "Nil"]) (list/reverse xs)) #Nil))) (macro:' #export (list& xs) (#Cons [(tag$ ["lux" "doc"]) (text$ "## List-construction macro, with the last element being a tail-list. ## In other words, this macro prepends elements to another list. (list& 1 2 3 (list 4 5 6))")] #Nil) ("lux case" (list/reverse xs) {(#Cons last init) (return (list (list/fold (function'' [head tail] (form$ (list (tag$ ["lux" "Cons"]) (tuple$ (list head tail))))) last init))) _ (fail "Wrong syntax for list&")})) (macro:' #export (& tokens) (#Cons [(tag$ ["lux" "doc"]) (text$ "## Tuple types: (& Text Int Bool) ## Any. (&)")] #Nil) ("lux case" (list/reverse tokens) {#Nil (return (list (symbol$ ["lux" "Any"]))) (#Cons last prevs) (return (list (list/fold (function'' [left right] (form$ (list (tag$ ["lux" "Product"]) left right))) last prevs)))} )) (macro:' #export (| tokens) (#Cons [(tag$ ["lux" "doc"]) (text$ "## Variant types: (| Text Int Bool) ## Nothing. (|)")] #Nil) ("lux case" (list/reverse tokens) {#Nil (return (list (symbol$ ["lux" "Nothing"]))) (#Cons last prevs) (return (list (list/fold (function'' [left right] (form$ (list (tag$ ["lux" "Sum"]) left right))) last prevs)))} )) (macro:' (function' tokens) (let'' [name tokens'] ("lux case" tokens {(#Cons [[_ (#Symbol ["" name])] tokens']) [name tokens'] _ ["" tokens]}) ("lux case" tokens' {(#Cons [[_ (#Tuple args)] (#Cons [body #Nil])]) ("lux case" args {#Nil (fail "function' requires a non-empty arguments tuple.") (#Cons [harg targs]) (return (list (form$ (list (text$ "lux function") (symbol$ ["" name]) harg (list/fold (function'' [arg body'] (form$ (list (text$ "lux function") (symbol$ ["" ""]) arg body'))) body (list/reverse targs))))))}) _ (fail "Wrong syntax for function'")}))) (macro:' (def:''' tokens) ("lux case" tokens {(#Cons [[_ (#Tag ["" "export"])] (#Cons [[_ (#Form (#Cons [name args]))] (#Cons [meta (#Cons [type (#Cons [body #Nil])])])])]) (return (list (form$ (list (text$ "lux def") name (form$ (list (text$ "lux check") type (form$ (list (symbol$ ["lux" "function'"]) name (tuple$ args) body)))) (form$ (#Cons (symbol$ ["lux" "record$"]) (#Cons (with-export-meta meta) #Nil))))))) (#Cons [[_ (#Tag ["" "export"])] (#Cons [name (#Cons [meta (#Cons [type (#Cons [body #Nil])])])])]) (return (list (form$ (list (text$ "lux def") name (form$ (list (text$ "lux check") type body)) (form$ (#Cons (symbol$ ["lux" "record$"]) (#Cons (with-export-meta meta) #Nil))))))) (#Cons [[_ (#Form (#Cons [name args]))] (#Cons [meta (#Cons [type (#Cons [body #Nil])])])]) (return (list (form$ (list (text$ "lux def") name (form$ (list (text$ "lux check") type (form$ (list (symbol$ ["lux" "function'"]) name (tuple$ args) body)))) (form$ (#Cons (symbol$ ["lux" "record$"]) (#Cons meta #Nil))))))) (#Cons [name (#Cons [meta (#Cons [type (#Cons [body #Nil])])])]) (return (list (form$ (list (text$ "lux def") name (form$ (list (text$ "lux check") type body)) (form$ (#Cons (symbol$ ["lux" "record$"]) (#Cons meta #Nil))))))) _ (fail "Wrong syntax for def'''")} )) (def:''' (as-pairs xs) #Nil (All [a] (-> ($' List a) ($' List (& a a)))) ("lux case" xs {(#Cons x (#Cons y xs')) (#Cons [x y] (as-pairs xs')) _ #Nil})) (macro:' (let' tokens) ("lux case" tokens {(#Cons [[_ (#Tuple bindings)] (#Cons [body #Nil])]) (return (list (list/fold ("lux check" (-> (& Code Code) Code Code) (function' [binding body] ("lux case" binding {[label value] (form$ (list (text$ "lux case") value (record$ (list [label body]))))}))) body (list/reverse (as-pairs bindings))))) _ (fail "Wrong syntax for let'")})) (def:''' (any? p xs) #Nil (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:''' (wrap-meta content) #Nil (-> Code Code) (tuple$ (list (tuple$ (list (text$ "") (nat$ +0) (nat$ +0))) content))) (def:''' (untemplate-list tokens) #Nil (-> ($' List Code) Code) ("lux case" tokens {#Nil (_ann (#Tag ["lux" "Nil"])) (#Cons [token tokens']) (_ann (#Form (list (_ann (#Tag ["lux" "Cons"])) token (untemplate-list tokens'))))})) (def:''' (list/compose xs ys) #Nil (All [a] (-> ($' List a) ($' List a) ($' List a))) ("lux case" xs {(#Cons x xs') (#Cons x (list/compose xs' ys)) #Nil ys})) (def:''' #export (splice-helper xs ys) #Nil (-> ($' List Code) ($' List Code) ($' List Code)) ("lux case" xs {(#Cons x xs') (#Cons x (splice-helper xs' ys)) #Nil ys})) (def:''' (_$_joiner op a1 a2) #Nil (-> Code Code Code Code) ("lux case" op {[_ (#Form parts)] (form$ (list/compose parts (list a1 a2))) _ (form$ (list op a1 a2))})) (macro:' #export (_$ tokens) (#Cons [(tag$ ["lux" "doc"]) (text$ "## Left-association for the application of binary functions over variadic arguments. (_$ text/compose \"Hello, \" name \".\\nHow are you?\") ## => (text/compose (text/compose \"Hello, \" name) \".\\nHow are you?\")")] #Nil) ("lux case" tokens {(#Cons op tokens') ("lux case" tokens' {(#Cons first nexts) (return (list (list/fold (_$_joiner op) first nexts))) _ (fail "Wrong syntax for _$")}) _ (fail "Wrong syntax for _$")})) (macro:' #export ($_ tokens) (#Cons [(tag$ ["lux" "doc"]) (text$ "## Right-association for the application of binary functions over variadic arguments. ($_ text/compose \"Hello, \" name \".\\nHow are you?\") ## => (text/compose \"Hello, \" (text/compose name \".\\nHow are you?\"))")] #Nil) ("lux case" tokens {(#Cons op tokens') ("lux case" (list/reverse tokens') {(#Cons last prevs) (return (list (list/fold (_$_joiner op) last prevs))) _ (fail "Wrong syntax for $_")}) _ (fail "Wrong syntax for $_")})) ## (sig: (Monad m) ## (: (All [a] (-> a (m a))) ## wrap) ## (: (All [a b] (-> (-> a (m b)) (m a) (m b))) ## bind)) (def:''' Monad (list& [(tag$ ["lux" "tags"]) (tuple$ (list (text$ "wrap") (text$ "bind")))] default-def-meta-unexported) Type (#Named ["lux" "Monad"] (All [m] (& (All [a] (-> a ($' m a))) (All [a b] (-> (-> a ($' m b)) ($' m a) ($' m b))))))) (def:''' Monad #Nil ($' Monad Maybe) {#wrap (function' [x] (#Some x)) #bind (function' [f ma] ("lux case" ma {#None #None (#Some a) (f a)}))}) (def:''' Monad #Nil ($' Monad Meta) {#wrap (function' [x] (function' [state] (#Right state x))) #bind (function' [f ma] (function' [state] ("lux case" (ma state) {(#Left msg) (#Left msg) (#Right state' a) (f a state')})))}) (macro:' (do tokens) ("lux case" tokens {(#Cons monad (#Cons [_ (#Tuple bindings)] (#Cons body #Nil))) (let' [g!wrap (symbol$ ["" "wrap"]) g!bind (symbol$ ["" " bind "]) body' (list/fold ("lux check" (-> (& Code Code) Code Code) (function' [binding body'] (let' [[var value] binding] ("lux case" var {[_ (#Tag "" "let")] (form$ (list (symbol$ ["lux" "let'"]) value body')) _ (form$ (list g!bind (form$ (list (text$ "lux function") (symbol$ ["" ""]) var body')) value))})))) body (list/reverse (as-pairs bindings)))] (return (list (form$ (list (text$ "lux case") monad (record$ (list [(record$ (list [(tag$ ["lux" "wrap"]) g!wrap] [(tag$ ["lux" "bind"]) g!bind])) body']))))))) _ (fail "Wrong syntax for do")})) (def:''' (monad/map m f xs) #Nil ## (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' [{#wrap wrap #bind _} m] ("lux case" xs {#Nil (wrap #Nil) (#Cons x xs') (do m [y (f x) ys (monad/map m f xs')] (wrap (#Cons y ys))) }))) (def:''' (monad/fold m f y xs) #Nil ## (All [m a b] ## (-> (Monad m) (-> a b (m b)) b (List a) (m b))) (All [m a b] (-> ($' Monad m) (-> a b ($' m b)) b ($' List a) ($' m b))) (let' [{#wrap wrap #bind _} m] ("lux case" xs {#Nil (wrap y) (#Cons x xs') (do m [y' (f x y)] (monad/fold m f y' xs')) }))) (macro:' #export (if tokens) (list [(tag$ ["lux" "doc"]) (text$ "Picks which expression to evaluate based on a boolean test value. (if true \"Oh, yeah!\" \"Aw hell naw!\") => \"Oh, yeah!\"")]) ("lux case" tokens {(#Cons test (#Cons then (#Cons else #Nil))) (return (list (form$ (list (text$ "lux case") test (record$ (list [(bool$ true) then] [(bool$ false) else])))))) _ (fail "Wrong syntax for if")})) (def:''' (get k plist) #Nil (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) #Nil (All [a] (-> Text a ($' List (& Text a)) ($' List (& Text a)))) ("lux case" dict {#Nil (list [k v]) (#Cons [[k' v'] dict']) (if (text/= k k') (#Cons [[k' v] dict']) (#Cons [[k' v'] (put k v dict')]))})) (def:''' #export (log! message) (list [(tag$ ["lux" "doc"]) (text$ "Logs message to standard output. Useful for debugging.")]) (-> Text Any) ("lux io log" message)) (def:''' (text/compose x y) #Nil (-> Text Text Text) ("lux text concat" x y)) (def:''' (ident/encode ident) #Nil (-> Ident Text) (let' [[module name] ident] ("lux case" module {"" name _ ($_ text/compose module "." name)}))) (def:''' (get-meta tag def-meta) #Nil (-> Ident Code ($' Maybe Code)) (let' [[prefix name] tag] ("lux case" def-meta {[_ (#Record def-meta)] ("lux case" def-meta {(#Cons [key value] def-meta') ("lux case" key {[_ (#Tag [prefix' name'])] ("lux case" [(text/= prefix prefix') (text/= name name')] {[true true] (#Some value) _ (get-meta tag (record$ def-meta'))}) _ (get-meta tag (record$ def-meta'))}) #Nil #None}) _ #None}))) (def:''' (resolve-global-symbol ident state) #Nil (-> Ident ($' Meta Ident)) (let' [[module name] ident {#info info #source source #current-module _ #modules modules #scopes scopes #type-context types #host host #seed seed #expected expected #cursor cursor #extensions extensions #scope-type-vars scope-type-vars} state] ("lux case" (get module modules) {(#Some {#module-hash _ #module-aliases _ #definitions definitions #imports _ #tags tags #types types #module-annotations _ #module-state _}) ("lux case" (get name definitions) {(#Some [def-type def-meta def-value]) ("lux case" (get-meta ["lux" "alias"] def-meta) {(#Some [_ (#Symbol real-name)]) (#Right [state real-name]) _ (#Right [state ident])}) #None (#Left ($_ text/compose "Unknown definition: " (ident/encode ident)))}) #None (#Left ($_ text/compose "Unknown module: " module " @ " (ident/encode ident)))}))) (def:''' (splice replace? untemplate elems) #Nil (-> Bool (-> Code ($' Meta Code)) ($' List Code) ($' Meta Code)) ("lux case" replace? {true ("lux case" (list/reverse elems) {#Nil (return (tag$ ["lux" "Nil"])) (#Cons lastI inits) (do Monad [lastO ("lux case" lastI {[_ (#Form (#Cons [[_ (#Symbol ["" "~+"])] (#Cons [spliced #Nil])]))] (let' [[[_module-name _ _] _] spliced] (wrap spliced)) _ (do Monad [lastO (untemplate lastI)] (wrap (form$ (list (tag$ ["lux" "Cons"]) (tuple$ (list lastO (tag$ ["lux" "Nil"])))))))})] (monad/fold Monad (function' [leftI rightO] ("lux case" leftI {[_ (#Form (#Cons [[_ (#Symbol ["" "~+"])] (#Cons [spliced #Nil])]))] (let' [[[_module-name _ _] _] spliced] (wrap (form$ (list (symbol$ ["lux" "splice-helper"]) spliced rightO)))) _ (do Monad [leftO (untemplate leftI)] (wrap (form$ (list (tag$ ["lux" "Cons"]) (tuple$ (list leftO rightO))))))})) lastO inits))}) false (do Monad [=elems (monad/map Monad untemplate elems)] (wrap (untemplate-list =elems)))})) (def:''' (untemplate-text value) #Nil (-> Text Code) (wrap-meta (form$ (list (tag$ ["lux" "Text"]) (text$ value))))) (def:''' (untemplate replace? subst token) #Nil (-> Bool Text Code ($' Meta Code)) ("lux case" [replace? token] {[_ [_ (#Bool value)]] (return (wrap-meta (form$ (list (tag$ ["lux" "Bool"]) (bool$ value))))) [_ [_ (#Nat value)]] (return (wrap-meta (form$ (list (tag$ ["lux" "Nat"]) (nat$ value))))) [_ [_ (#Int value)]] (return (wrap-meta (form$ (list (tag$ ["lux" "Int"]) (int$ value))))) [_ [_ (#Deg value)]] (return (wrap-meta (form$ (list (tag$ ["lux" "Deg"]) (deg$ value))))) [_ [_ (#Frac value)]] (return (wrap-meta (form$ (list (tag$ ["lux" "Frac"]) (frac$ value))))) [_ [_ (#Text value)]] (return (wrap-meta (form$ (list (tag$ ["lux" "Text"]) (text$ value))))) [false [_ (#Tag [module name])]] (return (wrap-meta (form$ (list (tag$ ["lux" "Tag"]) (tuple$ (list (text$ module) (text$ name))))))) [true [_ (#Tag [module name])]] (let' [module' ("lux case" module {"" subst _ module})] (return (wrap-meta (form$ (list (tag$ ["lux" "Tag"]) (tuple$ (list (text$ module') (text$ name)))))))) [true [_ (#Symbol [module name])]] (do Monad [real-name ("lux case" module {"" (if (text/= "" subst) (wrap [module name]) (resolve-global-symbol [subst name])) _ (wrap [module name])}) #let [[module name] real-name]] (return (wrap-meta (form$ (list (tag$ ["lux" "Symbol"]) (tuple$ (list (text$ module) (text$ name)))))))) [false [_ (#Symbol [module name])]] (return (wrap-meta (form$ (list (tag$ ["lux" "Symbol"]) (tuple$ (list (text$ module) (text$ name))))))) [true [_ (#Form (#Cons [[_ (#Symbol ["" "~"])] (#Cons [unquoted #Nil])]))]] (return unquoted) [true [_ (#Form (#Cons [[_ (#Symbol ["" "~!"])] (#Cons [dependent #Nil])]))]] (do Monad [independent (untemplate replace? subst dependent)] (wrap (wrap-meta (form$ (list (tag$ ["lux" "Form"]) (untemplate-list (list (untemplate-text "lux in-module") (untemplate-text subst) independent))))))) [true [_ (#Form (#Cons [[_ (#Symbol ["" "~'"])] (#Cons [keep-quoted #Nil])]))]] (untemplate false subst keep-quoted) [_ [meta (#Form elems)]] (do Monad [output (splice replace? (untemplate replace? subst) elems) #let [[_ output'] (wrap-meta (form$ (list (tag$ ["lux" "Form"]) output)))]] (wrap [meta output'])) [_ [meta (#Tuple elems)]] (do Monad [output (splice replace? (untemplate replace? subst) elems) #let [[_ output'] (wrap-meta (form$ (list (tag$ ["lux" "Tuple"]) output)))]] (wrap [meta output'])) [_ [_ (#Record fields)]] (do Monad [=fields (monad/map Monad ("lux check" (-> (& Code Code) ($' Meta Code)) (function' [kv] (let' [[k v] kv] (do Monad [=k (untemplate replace? subst k) =v (untemplate replace? subst v)] (wrap (tuple$ (list =k =v))))))) fields)] (wrap (wrap-meta (form$ (list (tag$ ["lux" "Record"]) (untemplate-list =fields))))))} )) (macro:' #export (primitive tokens) (list [(tag$ ["lux" "doc"]) (text$ "## Macro to treat define new primitive types. (primitive \"java.lang.Object\") (primitive \"java.util.List\" [(primitive \"java.lang.Long\")])")]) ("lux case" tokens {(#Cons [_ (#Text class-name)] #Nil) (return (list (form$ (list (tag$ ["lux" "Primitive"]) (text$ class-name) (tag$ ["lux" "Nil"]))))) (#Cons [_ (#Text class-name)] (#Cons [_ (#Tuple params)] #Nil)) (return (list (form$ (list (tag$ ["lux" "Primitive"]) (text$ class-name) (untemplate-list params))))) _ (fail "Wrong syntax for primitive")})) (def:'' (current-module-name state) #Nil ($' Meta Text) ("lux case" state {{#info info #source source #current-module current-module #modules modules #scopes scopes #type-context types #host host #seed seed #expected expected #cursor cursor #extensions extensions #scope-type-vars scope-type-vars} ("lux case" current-module {(#Some module-name) (#Right [state module-name]) _ (#Left "Cannot get the module name without a module!")} )})) (macro:' #export (` tokens) (list [(tag$ ["lux" "doc"]) (text$ "## Hygienic quasi-quotation as a macro. Unquote (~) and unquote-splice (~+) must also be used as forms. ## All unprefixed macros will receive their parent module's prefix if imported; otherwise will receive the prefix of the module on which the quasi-quote is being used. (` (def: (~ name) (function ((~' _) (~+ args)) (~ body))))")]) ("lux case" tokens {(#Cons template #Nil) (do Monad [current-module current-module-name =template (untemplate true current-module template)] (wrap (list (form$ (list (text$ "lux check") (symbol$ ["lux" "Code"]) =template))))) _ (fail "Wrong syntax for `")})) (macro:' #export (`' tokens) (list [(tag$ ["lux" "doc"]) (text$ "## Unhygienic quasi-quotation as a macro. Unquote (~) and unquote-splice (~+) must also be used as forms. (`' (def: (~ name) (function (_ (~+ args)) (~ body))))")]) ("lux case" tokens {(#Cons template #Nil) (do Monad [=template (untemplate true "" template)] (wrap (list (form$ (list (text$ "lux check") (symbol$ ["lux" "Code"]) =template))))) _ (fail "Wrong syntax for `")})) (macro:' #export (' tokens) (list [(tag$ ["lux" "doc"]) (text$ "## Quotation as a macro. (' \"YOLO\")")]) ("lux case" tokens {(#Cons template #Nil) (do Monad [=template (untemplate false "" template)] (wrap (list (form$ (list (text$ "lux check") (symbol$ ["lux" "Code"]) =template))))) _ (fail "Wrong syntax for '")})) (macro:' #export (|> tokens) (list [(tag$ ["lux" "doc"]) (text$ "## Piping macro. (|> elems (list/map int/encode) (interpose \" \") (fold text/compose \"\")) ## => (fold text/compose \"\" (interpose \" \" (list/map int/encode elems)))")]) ("lux case" tokens {(#Cons [init apps]) (return (list (list/fold ("lux check" (-> Code Code Code) (function' [app acc] ("lux case" app {[_ (#Tuple parts)] (tuple$ (list/compose parts (list acc))) [_ (#Form parts)] (form$ (list/compose parts (list acc))) _ (` ((~ app) (~ acc)))}))) init apps))) _ (fail "Wrong syntax for |>")})) (macro:' #export (<| tokens) (list [(tag$ ["lux" "doc"]) (text$ "## Reverse piping macro. (<| (fold text/compose \"\") (interpose \" \") (list/map int/encode) elems) ## => (fold text/compose \"\" (interpose \" \" (list/map int/encode elems)))")]) ("lux case" (list/reverse tokens) {(#Cons [init apps]) (return (list (list/fold ("lux check" (-> Code Code Code) (function' [app acc] ("lux case" app {[_ (#Tuple parts)] (tuple$ (list/compose parts (list acc))) [_ (#Form parts)] (form$ (list/compose parts (list acc))) _ (` ((~ app) (~ acc)))}))) init apps))) _ (fail "Wrong syntax for <|")})) (def:''' (compose f g) (list [(tag$ ["lux" "doc"]) (text$ "Function composition.")]) (All [a b c] (-> (-> b c) (-> a b) (-> a c))) (function' [x] (f (g x)))) (def:''' (get-ident x) #Nil (-> Code ($' Maybe Ident)) ("lux case" x {[_ (#Symbol sname)] (#Some sname) _ #None})) (def:''' (get-tag x) #Nil (-> Code ($' Maybe Ident)) ("lux case" x {[_ (#Tag sname)] (#Some sname) _ #None})) (def:''' (get-name x) #Nil (-> Code ($' Maybe Text)) ("lux case" x {[_ (#Symbol "" sname)] (#Some sname) _ #None})) (def:''' (tuple->list tuple) #Nil (-> Code ($' Maybe ($' List Code))) ("lux case" tuple {[_ (#Tuple members)] (#Some members) _ #None})) (def:''' (apply-template env template) #Nil (-> RepEnv Code Code) ("lux case" template {[_ (#Symbol "" sname)] ("lux case" (get-rep sname env) {(#Some subst) subst _ template}) [meta (#Tuple elems)] [meta (#Tuple (list/map (apply-template env) elems))] [meta (#Form elems)] [meta (#Form (list/map (apply-template env) elems))] [meta (#Record members)] [meta (#Record (list/map ("lux check" (-> (& Code Code) (& Code Code)) (function' [kv] (let' [[slot value] kv] [(apply-template env slot) (apply-template env value)]))) members))] _ template})) (def:''' (join-map f xs) #Nil (All [a b] (-> (-> a ($' List b)) ($' List a) ($' List b))) ("lux case" xs {#Nil #Nil (#Cons [x xs']) (list/compose (f x) (join-map f xs'))})) (def:''' (every? p xs) #Nil (All [a] (-> (-> a Bool) ($' List a) Bool)) (list/fold (function' [_2 _1] (if _1 (p _2) false)) true xs)) (def:''' #export (n/= test subject) (list [(tag$ ["lux" "doc"]) (text$ "Nat(ural) equality.")]) (-> Nat Nat Bool) ("lux i64 =" test subject)) (def:''' (high-bits value) (list) (-> ($' I64 Any) I64) ("lux i64 logical-right-shift" +32 value)) (def:''' low-mask (list) I64 (|> +1 ("lux i64 left-shift" +32) ("lux i64 -" +1))) (def:''' (low-bits value) (list) (-> ($' I64 Any) I64) ("lux i64 and" low-mask value)) (def:''' #export (n/< test subject) (list [(tag$ ["lux" "doc"]) (text$ "Nat(ural) less-than.")]) (-> Nat Nat Bool) (let' [testH (high-bits test) subjectH (high-bits subject)] (if ("lux int <" subjectH testH) true (if ("lux i64 =" testH subjectH) ("lux int <" (low-bits subject) (low-bits test)) false)))) (def:''' #export (n/<= test subject) (list [(tag$ ["lux" "doc"]) (text$ "Nat(ural) less-than-equal.")]) (-> Nat Nat Bool) (if (n/< test subject) true ("lux i64 =" test subject))) (def:''' #export (n/> test subject) (list [(tag$ ["lux" "doc"]) (text$ "Nat(ural) greater-than.")]) (-> Nat Nat Bool) (n/< subject test)) (def:''' #export (n/>= test subject) (list [(tag$ ["lux" "doc"]) (text$ "Nat(ural) greater-than-equal.")]) (-> Nat Nat Bool) (if (n/< subject test) true ("lux i64 =" test subject))) (macro:' #export (do-template tokens) (list [(tag$ ["lux" "doc"]) (text$ "## By specifying a pattern (with holes), and the input data to fill those holes, repeats the pattern as many times as necessary. (do-template [ ] [(def: #export (-> Int Int) (i/+ ))] [inc 1] [dec -1])")]) ("lux case" tokens {(#Cons [[_ (#Tuple bindings)] (#Cons [[_ (#Tuple templates)] data])]) ("lux case" [(monad/map Monad get-name bindings) (monad/map Monad tuple->list data)] {[(#Some bindings') (#Some data')] (let' [apply ("lux check" (-> RepEnv ($' List Code)) (function' [env] (list/map (apply-template env) templates))) num-bindings (list/size bindings')] (if (every? (n/= num-bindings) (list/map list/size data')) (|> data' (join-map (compose apply (make-env bindings'))) return) (fail "Irregular arguments tuples for do-template."))) _ (fail "Wrong syntax for do-template")}) _ (fail "Wrong syntax for do-template")})) (def:''' #export (d/= test subject) (list [(tag$ ["lux" "doc"]) (text$ "Deg(ree) equality.")]) (-> Deg Deg Bool) ("lux i64 =" test subject)) (def:''' #export (d/< test subject) (list [(tag$ ["lux" "doc"]) (text$ "Deg(ree) less-than.")]) (-> Deg Deg Bool) (n/< ("lux coerce" Nat test) ("lux coerce" Nat subject))) (def:''' #export (d/<= test subject) (list [(tag$ ["lux" "doc"]) (text$ "Deg(ree) less-than-equal.")]) (-> Deg Deg Bool) (if (n/< ("lux coerce" Nat test) ("lux coerce" Nat subject)) true ("lux i64 =" test subject))) (def:''' #export (d/> test subject) (list [(tag$ ["lux" "doc"]) (text$ "Deg(ree) greater-than.")]) (-> Deg Deg Bool) (d/< subject test)) (def:''' #export (d/>= test subject) (list [(tag$ ["lux" "doc"]) (text$ "Deg(ree) greater-than-equal.")]) (-> Deg Deg Bool) (if (d/< subject test) true ("lux i64 =" test subject))) (do-template [ <<-doc> <<=-doc> <>-doc> <>=-doc>] [(def:''' #export ( test subject) (list [(tag$ ["lux" "doc"]) (text$ )]) (-> Bool) ( subject test)) (def:''' #export ( test subject) (list [(tag$ ["lux" "doc"]) (text$ <<-doc>)]) (-> Bool) ( subject test)) (def:''' #export ( test subject) (list [(tag$ ["lux" "doc"]) (text$ <<=-doc>)]) (-> Bool) (if ( subject test) true ( subject test))) (def:''' #export ( test subject) (list [(tag$ ["lux" "doc"]) (text$ <>-doc>)]) (-> Bool) ( test subject)) (def:''' #export ( test subject) (list [(tag$ ["lux" "doc"]) (text$ <>=-doc>)]) (-> Bool) (if ( test subject) true ( subject test)))] [ Int "lux i64 =" "lux int <" i/= i/< i/<= i/> i/>= "Int(eger) equality." "Int(eger) less-than." "Int(eger) less-than-equal." "Int(eger) greater-than." "Int(eger) greater-than-equal."] [Frac "lux frac =" "lux frac <" f/= f/< f/<= f/> f/>= "Frac(tion) equality." "Frac(tion) less-than." "Frac(tion) less-than-equal." "Frac(tion) greater-than." "Frac(tion) greater-than-equal."] ) (def:''' #export (n// param subject) (list [(tag$ ["lux" "doc"]) (text$ "Nat(ural) division.")]) (-> Nat Nat Nat) (if ("lux int <" ("lux coerce" Int param) 0) (if (n/< param subject) +0 +1) (let' [quotient ("lux i64 left-shift" +1 ("lux int /" ("lux i64 logical-right-shift" +1 subject) ("lux coerce" Int param))) flat ("lux int *" ("lux coerce" Int quotient) ("lux coerce" Int param)) remainder ("lux i64 -" flat subject)] (if (n/< param remainder) quotient ("lux i64 +" +1 quotient))))) (def:''' #export (n//% param subject) (list [(tag$ ["lux" "doc"]) (text$ "Nat(ural) [division remainder].")]) (-> Nat Nat (#Product Nat Nat)) (let' [div (n// param subject) flat ("lux int *" ("lux coerce" Int div) ("lux coerce" Int param))] [div ("lux i64 -" flat subject)])) (def:''' #export (n/% param subject) (list [(tag$ ["lux" "doc"]) (text$ "Nat(ural) remainder.")]) (-> Nat Nat Nat) (let' [flat ("lux int *" ("lux coerce" Int (n// param subject)) ("lux coerce" Int param))] ("lux i64 -" flat subject))) (do-template [ ] [(def:''' #export ( param subject) (list [(tag$ ["lux" "doc"]) (text$ )]) (-> ) ( param subject))] [ Int i/+ "lux i64 +" "Int(eger) addition."] [ Int i/- "lux i64 -" "Int(eger) substraction."] [ Deg d/+ "lux i64 +" "Deg(ree) addition."] [ Deg d/- "lux i64 -" "Deg(ree) substraction."] ) (do-template [ ] [(def:''' #export ( param subject) (list [(tag$ ["lux" "doc"]) (text$ )]) (-> ) ( subject param))] [ Int i/* "lux int *" "Int(eger) multiplication."] [ Int i// "lux int /" "Int(eger) division."] [ Int i/% "lux int %" "Int(eger) remainder."] [Frac f/+ "lux frac +" "Frac(tion) addition."] [Frac f/- "lux frac -" "Frac(tion) substraction."] [Frac f/* "lux frac *" "Frac(tion) multiplication."] [Frac f// "lux frac /" "Frac(tion) division."] [Frac f/% "lux frac %" "Frac(tion) remainder."] ) (def:''' #export (d/* param subject) (list [(tag$ ["lux" "doc"]) (text$ "Deg(ree) multiplication.")]) (-> Deg Deg Deg) (let' [subjectH (high-bits subject) subjectL (low-bits subject) paramH (high-bits param) paramL (low-bits param) bottom (|> subjectL ("lux int *" paramL) ("lux i64 logical-right-shift" +32)) middle ("lux i64 +" ("lux int *" subjectH paramL) ("lux int *" subjectL paramH)) top ("lux int *" subjectH paramH)] (|> bottom ("lux i64 +" middle) high-bits ("lux i64 +" top)))) (def:''' least-significant-bit-mask (list) Nat +1) (def:''' (without-trailing-zeroes count remaining) (list) (-> Nat Nat (#Product Nat Nat)) (if (|> remaining ("lux i64 and" least-significant-bit-mask) ("lux i64 =" +0)) (without-trailing-zeroes ("lux i64 +" +1 count) ("lux i64 logical-right-shift" +1 remaining)) [count remaining])) (def:''' #export (d// param subject) (list [(tag$ ["lux" "doc"]) (text$ "Deg(ree) division.")]) (-> Deg Deg Deg) (if ("lux i64 =" 0 param) ("lux io error" "Cannot divide Deg by zero!") (let' [[trailing-zeroes remaining] (without-trailing-zeroes +0 ("lux coerce" Nat param)) [trailing-zeroes denominator] ("lux check" (#Product Nat Nat) (if ("lux i64 =" 0 trailing-zeroes) [+1 ("lux i64 logical-right-shift" +1 remaining)] [trailing-zeroes remaining])) shift ("lux i64 -" trailing-zeroes +64) numerator ("lux i64 left-shift" shift +1)] ("lux coerce" Deg ("lux int *" ("lux coerce" Int subject) ("lux int /" ("lux coerce" Int numerator) ("lux coerce" Int denominator))))))) (def:''' #export (d/% param subject) (list [(tag$ ["lux" "doc"]) (text$ "Deg(ree) remainder.")]) (-> Deg Deg Deg) ("lux coerce" Deg (n/% ("lux coerce" Nat subject) ("lux coerce" Nat param)))) (def:''' #export (d/scale param subject) (list [(tag$ ["lux" "doc"]) (text$ "Deg(ree) scale.")]) (-> Nat Deg Deg) ("lux coerce" Deg ("lux int *" ("lux coerce" Int subject) ("lux coerce" Int param)))) (def:''' #export (d/reciprocal numerator) (list [(tag$ ["lux" "doc"]) (text$ "Deg(ree) reciprocal of a Nat(ural).")]) (-> Nat Deg) ("lux coerce" Deg (let' [[trailing-zeroes remaining] (without-trailing-zeroes +0 numerator)] (n// remaining ("lux case" trailing-zeroes {+0 ("lux coerce" Nat -1) _ ("lux i64 left-shift" (n/- trailing-zeroes +64) +1)}))))) (do-template [ ] [(def:''' #export ( left right) (list [(tag$ ["lux" "doc"]) (text$ )]) (-> ) (if ( right left) left right))] [n/min Nat n/< "Nat(ural) minimum."] [n/max Nat n/> "Nat(ural) maximum."] [i/min Int i/< "Int(eger) minimum."] [i/max Int i/> "Int(eger) maximum."] [d/min Deg d/< "Deg(ree) minimum."] [d/max Deg d/> "Deg(ree) maximum."] [f/min Frac f/< "Frac(tion) minimum."] [f/max Frac f/> "Frac(tion) minimum."] ) (def:''' (bool/encode x) #Nil (-> Bool Text) (if x "true" "false")) (def:''' (digit-to-text digit) #Nil (-> Nat Text) ("lux case" digit {+0 "0" +1 "1" +2 "2" +3 "3" +4 "4" +5 "5" +6 "6" +7 "7" +8 "8" +9 "9" _ ("lux io error" "undefined")})) (def:''' (nat/encode value) #Nil (-> Nat Text) ("lux case" value {+0 "+0" _ (let' [loop ("lux check" (-> Nat Text Text) (function' recur [input output] (if (n/= +0 input) (text/compose "+" output) (recur (n// +10 input) (text/compose (|> input (n/% +10) digit-to-text) output)))))] (loop value ""))})) (def:''' (int/abs value) #Nil (-> Int Int) (if (i/< 0 value) (i/* -1 value) value)) (def:''' (int/encode value) #Nil (-> Int Text) (if (i/= 0 value) "0" (let' [sign (if (i/> 0 value) "" "-")] (("lux check" (-> Int Text Text) (function' recur [input output] (if (i/= 0 input) (text/compose sign output) (recur (i// 10 input) (text/compose (|> input (i/% 10) ("lux coerce" Nat) digit-to-text) output))))) (|> value (i// 10) int/abs) (|> value (i/% 10) int/abs ("lux coerce" Nat) digit-to-text))))) (def:''' (frac/encode x) #Nil (-> Frac Text) ("lux frac encode" x)) (def:''' (multiple? div n) #Nil (-> Nat Nat Bool) (|> n (n/% div) (n/= +0))) (def:''' #export (not x) (list [(tag$ ["lux" "doc"]) (text$ "## Boolean negation. (not true) => false (not false) => true")]) (-> Bool Bool) (if x false true)) (def:''' (find-macro' modules current-module module name) #Nil (-> ($' List (& Text Module)) Text Text Text ($' Maybe Macro)) (do Monad [$module (get module modules) gdef (let' [{#module-hash _ #module-aliases _ #definitions bindings #imports _ #tags tags #types types #module-annotations _ #module-state _} ("lux check" Module $module)] (get name bindings))] (let' [[def-type def-meta def-value] ("lux check" Definition gdef)] ("lux case" (get-meta ["lux" "macro?"] def-meta) {(#Some [_ (#Bool true)]) ("lux case" (get-meta ["lux" "export?"] def-meta) {(#Some [_ (#Bool true)]) (#Some ("lux coerce" Macro def-value)) _ (if (text/= module current-module) (#Some ("lux coerce" Macro def-value)) #None)}) _ ("lux case" (get-meta ["lux" "alias"] def-meta) {(#Some [_ (#Symbol [r-module r-name])]) (find-macro' modules current-module r-module r-name) _ #None})} )) )) (def:''' (normalize ident) #Nil (-> Ident ($' Meta Ident)) ("lux case" ident {["" name] (do Monad [module-name current-module-name] (wrap [module-name name])) _ (return ident)})) (def:''' (find-macro ident) #Nil (-> Ident ($' Meta ($' Maybe Macro))) (do Monad [current-module current-module-name] (let' [[module name] ident] (function' [state] ("lux case" state {{#info info #source source #current-module _ #modules modules #scopes scopes #type-context types #host host #seed seed #expected expected #cursor cursor #extensions extensions #scope-type-vars scope-type-vars} (#Right state (find-macro' modules current-module module name))}))))) (def:''' (macro? ident) #Nil (-> Ident ($' Meta Bool)) (do Monad [ident (normalize ident) output (find-macro ident)] (wrap ("lux case" output {(#Some _) true #None false})))) (def:''' (list/join xs) #Nil (All [a] (-> ($' List ($' List a)) ($' List a))) (list/fold list/compose #Nil (list/reverse xs))) (def:''' (interpose sep xs) #Nil (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-once token) #Nil (-> Code ($' Meta ($' List Code))) ("lux case" token {[_ (#Form (#Cons [_ (#Symbol macro-name)] args))] (do Monad [macro-name' (normalize macro-name) ?macro (find-macro macro-name')] ("lux case" ?macro {(#Some macro) (macro args) #None (return (list token))})) _ (return (list token))})) (def:''' (macro-expand token) #Nil (-> Code ($' Meta ($' List Code))) ("lux case" token {[_ (#Form (#Cons [_ (#Symbol macro-name)] args))] (do Monad [macro-name' (normalize macro-name) ?macro (find-macro macro-name')] ("lux case" ?macro {(#Some macro) (do Monad [expansion (macro args) expansion' (monad/map Monad macro-expand expansion)] (wrap (list/join expansion'))) #None (return (list token))})) _ (return (list token))})) (def:''' (macro-expand-all syntax) #Nil (-> Code ($' Meta ($' List Code))) ("lux case" syntax {[_ (#Form (#Cons [_ (#Symbol macro-name)] args))] (do Monad [macro-name' (normalize macro-name) ?macro (find-macro macro-name')] ("lux case" ?macro {(#Some macro) (do Monad [expansion (macro args) expansion' (monad/map Monad macro-expand-all expansion)] (wrap (list/join expansion'))) #None (do Monad [args' (monad/map Monad macro-expand-all args)] (wrap (list (form$ (#Cons (symbol$ macro-name) (list/join args'))))))})) [_ (#Form members)] (do Monad [members' (monad/map Monad macro-expand-all members)] (wrap (list (form$ (list/join members'))))) [_ (#Tuple members)] (do Monad [members' (monad/map Monad macro-expand-all members)] (wrap (list (tuple$ (list/join members'))))) [_ (#Record pairs)] (do Monad [pairs' (monad/map Monad (function' [kv] (let' [[key val] kv] (do Monad [val' (macro-expand-all val)] ("lux case" val' {(#Cons val'' #Nil) (return [key val'']) _ (fail "The value-part of a KV-pair in a record must macro-expand to a single Code.")})))) pairs)] (wrap (list (record$ pairs')))) _ (return (list syntax))})) (def:''' (walk-type type) #Nil (-> Code Code) ("lux case" type {[_ (#Form (#Cons [_ (#Tag tag)] parts))] (form$ (#Cons [(tag$ tag) (list/map walk-type parts)])) [_ (#Tuple members)] (` (& (~+ (list/map walk-type members)))) [_ (#Form (#Cons [_ (#Text "lux in-module")] (#Cons [_ (#Text module)] (#Cons type' #Nil))))] (` ("lux in-module" (~ (text$ module)) (~ (walk-type type')))) [_ (#Form (#Cons [_ (#Symbol ["" "~"])] (#Cons expression #Nil)))] expression [_ (#Form (#Cons type-fn args))] (list/fold ("lux check" (-> Code Code Code) (function' [arg type-fn] (` (#.Apply (~ arg) (~ type-fn))))) (walk-type type-fn) (list/map walk-type args)) _ type})) (macro:' #export (type tokens) (list [(tag$ ["lux" "doc"]) (text$ "## Takes a type expression and returns it's representation as data-structure. (type (All [a] (Maybe (List a))))")]) ("lux case" tokens {(#Cons type #Nil) (do 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")})) (macro:' #export (: tokens) (list [(tag$ ["lux" "doc"]) (text$ "## The type-annotation macro. (: (List Int) (list 1 2 3))")]) ("lux case" tokens {(#Cons type (#Cons value #Nil)) (return (list (` ("lux check" (type (~ type)) (~ value))))) _ (fail "Wrong syntax for :")})) (macro:' #export (:! tokens) (list [(tag$ ["lux" "doc"]) (text$ "## The type-coercion macro. (:! Dinosaur (list 1 2 3))")]) ("lux case" tokens {(#Cons type (#Cons value #Nil)) (return (list (` ("lux coerce" (type (~ type)) (~ value))))) _ (fail "Wrong syntax for :!")})) (def:''' (empty? xs) #Nil (All [a] (-> ($' List a) Bool)) ("lux case" xs {#Nil true _ false})) (do-template [ ] [(def:''' ( xy) #Nil (All [a b] (-> (& a b) )) (let' [[x y] xy] ))] [first a x] [second b y]) (def:''' (unfold-type-def type-codes) #Nil (-> ($' List Code) ($' Meta (& Code ($' Maybe ($' List Text))))) ("lux case" type-codes {(#Cons [_ (#Record pairs)] #Nil) (do Monad [members (monad/map Monad (: (-> [Code Code] (Meta [Text Code])) (function' [pair] ("lux case" pair {[[_ (#Tag "" member-name)] member-type] (return [member-name member-type]) _ (fail "Wrong syntax for variant case.")}))) pairs)] (return [(` (& (~+ (list/map second members)))) (#Some (list/map first members))])) (#Cons type #Nil) ("lux case" type {[_ (#Tag "" member-name)] (return [(` .Any) (#Some (list member-name))]) [_ (#Form (#Cons [_ (#Tag "" member-name)] member-types))] (return [(` (& (~+ member-types))) (#Some (list member-name))]) _ (return [type #None])}) (#Cons case cases) (do Monad [members (monad/map Monad (: (-> Code (Meta [Text Code])) (function' [case] ("lux case" case {[_ (#Tag "" member-name)] (return [member-name (` .Any)]) [_ (#Form (#Cons [_ (#Tag "" member-name)] (#Cons member-type #Nil)))] (return [member-name member-type]) [_ (#Form (#Cons [_ (#Tag "" member-name)] member-types))] (return [member-name (` (& (~+ member-types)))]) _ (fail "Wrong syntax for variant case.")}))) (list& case cases))] (return [(` (| (~+ (list/map second members)))) (#Some (list/map first members))])) _ (fail "Improper type-definition syntax")})) (def:''' (gensym prefix state) #Nil (-> Text ($' Meta Code)) ("lux case" state {{#info info #source source #current-module _ #modules modules #scopes scopes #type-context types #host host #seed seed #expected expected #cursor cursor #extensions extensions #scope-type-vars scope-type-vars} (#Right {#info info #source source #current-module _ #modules modules #scopes scopes #type-context types #host host #seed (n/+ +1 seed) #expected expected #cursor cursor #extensions extensions #scope-type-vars scope-type-vars} (symbol$ ["" ($_ text/compose "__gensym__" prefix (nat/encode seed))]))})) (macro:' #export (Rec tokens) (list [(tag$ ["lux" "doc"]) (text$ "## Parameter-less recursive types. ## A name has to be given to the whole type, to use it within its body. (Rec Self [Int (List Self)])")]) ("lux case" tokens {(#Cons [_ (#Symbol "" name)] (#Cons body #Nil)) (let' [body' (replace-syntax (list [name (` (#.Apply (~ (make-bound +1)) (~ (make-bound +0))))]) (update-bounds body))] (return (list (` (#.Apply .Nothing (#.UnivQ #.Nil (~ body'))))))) _ (fail "Wrong syntax for Rec")})) (macro:' #export (exec tokens) (list [(tag$ ["lux" "doc"]) (text$ "## Sequential execution of expressions (great for side-effects). (exec (log! \"#1\") (log! \"#2\") (log! \"#3\") \"YOLO\")")]) ("lux case" (list/reverse tokens) {(#Cons value actions) (let' [dummy (symbol$ ["" ""])] (return (list (list/fold ("lux check" (-> Code Code Code) (function' [pre post] (` ("lux case" (~ pre) {(~ dummy) (~ post)})))) value actions)))) _ (fail "Wrong syntax for exec")})) (macro:' (def:' tokens) (let' [[export? tokens'] ("lux case" tokens {(#Cons [_ (#Tag ["" "export"])] tokens') [true tokens'] _ [false tokens]}) parts (: (Maybe [Code (List Code) (Maybe Code) Code]) ("lux case" tokens' {(#Cons [_ (#Form (#Cons name args))] (#Cons type (#Cons body #Nil))) (#Some name args (#Some type) body) (#Cons name (#Cons type (#Cons body #Nil))) (#Some name #Nil (#Some type) body) (#Cons [_ (#Form (#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 _ (` (function' (~ name) [(~+ args)] (~ body)))}) body'' ("lux case" ?type {(#Some type) (` (: (~ type) (~ body'))) #None body'})] (return (list (` ("lux def" (~ name) (~ body'') [(~ cursor-code) (#.Record (~ (if export? (with-export-meta (tag$ ["lux" "Nil"])) (tag$ ["lux" "Nil"]))))]))))) #None (fail "Wrong syntax for def'")}))) (def:' (rejoin-pair pair) (-> [Code Code] (List Code)) (let' [[left right] pair] (list left right))) (def:' (code-to-text code) (-> Code Text) ("lux case" code {[_ (#Bool value)] (bool/encode value) [_ (#Nat value)] (nat/encode value) [_ (#Int value)] (int/encode value) [_ (#Deg value)] ("lux io error" "Undefined behavior.") [_ (#Frac value)] (frac/encode value) [_ (#Text value)] ($_ text/compose "\"" value "\"") [_ (#Symbol [prefix name])] (if (text/= "" prefix) name ($_ text/compose prefix "." name)) [_ (#Tag [prefix name])] (if (text/= "" prefix) ($_ text/compose "#" name) ($_ text/compose "#" prefix "." name)) [_ (#Form xs)] ($_ text/compose "(" (|> xs (list/map code-to-text) (interpose " ") list/reverse (list/fold text/compose "")) ")") [_ (#Tuple xs)] ($_ text/compose "[" (|> xs (list/map code-to-text) (interpose " ") list/reverse (list/fold text/compose "")) "]") [_ (#Record kvs)] ($_ text/compose "{" (|> kvs (list/map (function' [kv] ("lux case" kv {[k v] ($_ text/compose (code-to-text k) " " (code-to-text v))}))) (interpose " ") list/reverse (list/fold text/compose "")) "}")} )) (def:' (expander branches) (-> (List Code) (Meta (List Code))) ("lux case" branches {(#Cons [_ (#Form (#Cons [_ (#Symbol macro-name)] macro-args))] (#Cons body branches')) (do Monad [??? (macro? macro-name)] (if ??? (do Monad [init-expansion (macro-expand-once (form$ (list& (symbol$ macro-name) (form$ macro-args) body branches')))] (expander init-expansion)) (do Monad [sub-expansion (expander branches')] (wrap (list& (form$ (list& (symbol$ macro-name) macro-args)) body sub-expansion))))) (#Cons pattern (#Cons body branches')) (do Monad [sub-expansion (expander branches')] (wrap (list& pattern body sub-expansion))) #Nil (do Monad [] (wrap (list))) _ (fail ($_ text/compose "\"lux.case\" expects an even number of tokens: " (|> branches (list/map code-to-text) (interpose " ") list/reverse (list/fold text/compose ""))))})) (macro:' #export (case tokens) (list [(tag$ ["lux" "doc"]) (text$ "## The pattern-matching macro. ## Allows the usage of macros within the patterns to provide custom syntax. (case (: (List Int) (list 1 2 3)) (#Cons x (#Cons y (#Cons z #Nil))) (#Some ($_ i/* x y z)) _ #None)")]) ("lux case" tokens {(#Cons value branches) (do Monad [expansion (expander branches)] (wrap (list (` ("lux case" (~ value) (~ (record$ (as-pairs expansion)))))))) _ (fail "Wrong syntax for case")})) (macro:' #export (^ tokens) (list [(tag$ ["lux" "doc"]) (text$ "## Macro-expanding patterns. ## It's a special macro meant to be used with 'case'. (case (: (List Int) (list 1 2 3)) (^ (list x y z)) (#Some ($_ i/* x y z)) _ #None)")]) (case tokens (#Cons [_ (#Form (#Cons pattern #Nil))] (#Cons body branches)) (do Monad [pattern+ (macro-expand-all pattern)] (case pattern+ (#Cons pattern' #Nil) (wrap (list& pattern' body branches)) _ (fail "^ can only expand to 1 pattern."))) _ (fail "Wrong syntax for ^ macro"))) (macro:' #export (^or tokens) (list [(tag$ ["lux" "doc"]) (text$ "## Or-patterns. ## It's a special macro meant to be used with 'case'. (type: Weekday #Monday #Tuesday #Wednesday #Thursday #Friday #Saturday #Sunday) (def: (weekend? day) (-> Weekday Bool) (case day (^or #Saturday #Sunday) true _ false))")]) (case tokens (^ (list& [_ (#Form patterns)] body branches)) (case patterns #Nil (fail "^or cannot have 0 patterns") _ (let' [pairs (|> patterns (list/map (function' [pattern] (list pattern body))) (list/join))] (return (list/compose pairs branches)))) _ (fail "Wrong syntax for ^or"))) (def:' (symbol? code) (-> Code Bool) (case code [_ (#Symbol _)] true _ false)) (macro:' #export (let tokens) (list [(tag$ ["lux" "doc"]) (text$ "## Creates local bindings. ## Can (optionally) use pattern-matching macros when binding. (let [x (foo bar) y (baz quux)] (op x y))")]) (case tokens (^ (list [_ (#Tuple bindings)] body)) (if (multiple? +2 (list/size bindings)) (|> bindings as-pairs list/reverse (list/fold (: (-> [Code Code] Code Code) (function' [lr body'] (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"))) (macro:' #export (function tokens) (list [(tag$ ["lux" "doc"]) (text$ "## Syntax for creating functions. ## Allows for giving the function itself a name, for the sake of recursion. (: (All [a b] (-> a b a)) (function (_ x y) x)) (: (All [a b] (-> a b a)) (function (const x y) x))")]) (case (: (Maybe [Text Code (List Code) Code]) (case tokens (^ (list [_ (#Form (list& [_ (#Symbol ["" name])] head tail))] body)) (#Some name head tail body) _ #None)) (#Some g!name head tail body) (let [g!blank (symbol$ ["" ""]) g!name (symbol$ ["" g!name]) body+ (list/fold (: (-> Code Code Code) (function' [arg body'] (if (symbol? arg) (` ("lux function" (~ g!blank) (~ arg) (~ body'))) (` ("lux function" (~ g!blank) (~ g!blank) (case (~ g!blank) (~ arg) (~ body'))))))) body (list/reverse tail))] (return (list (if (symbol? head) (` ("lux function" (~ g!name) (~ head) (~ body+))) (` ("lux function" (~ g!name) (~ g!blank) (case (~ g!blank) (~ head) (~ body+)))))))) #None (fail "Wrong syntax for function"))) (def:' (process-def-meta-value code) (-> Code Code) (case code [_ (#Bool value)] (meta-code ["lux" "Bool"] (bool$ value)) [_ (#Nat value)] (meta-code ["lux" "Nat"] (nat$ value)) [_ (#Int value)] (meta-code ["lux" "Int"] (int$ value)) [_ (#Deg value)] (meta-code ["lux" "Deg"] (deg$ value)) [_ (#Frac value)] (meta-code ["lux" "Frac"] (frac$ value)) [_ (#Text value)] (meta-code ["lux" "Text"] (text$ value)) [_ (#Tag [prefix name])] (meta-code ["lux" "Tag"] (` [(~ (text$ prefix)) (~ (text$ name))])) (^or [_ (#Form _)] [_ (#Symbol _)]) code [_ (#Tuple xs)] (|> xs (list/map process-def-meta-value) untemplate-list (meta-code ["lux" "Tuple"])) [_ (#Record kvs)] (|> kvs (list/map (: (-> [Code Code] Code) (function (_ [k v]) (` [(~ (process-def-meta-value k)) (~ (process-def-meta-value v))])))) untemplate-list (meta-code ["lux" "Record"])) )) (def:' (process-def-meta kvs) (-> (List [Code Code]) Code) (untemplate-list (list/map (: (-> [Code Code] Code) (function (_ [k v]) (` [(~ (process-def-meta-value k)) (~ (process-def-meta-value v))]))) kvs))) (def:' (with-func-args args meta) (-> (List Code) Code Code) (case args #Nil meta _ (` (#.Cons [[(~ cursor-code) (#.Tag ["lux" "func-args"])] [(~ cursor-code) (#.Tuple (.list (~+ (list/map (function (_ arg) (` [(~ cursor-code) (#.Text (~ (text$ (code-to-text arg))))])) args))))]] (~ meta))))) (def:' (with-type-args args) (-> (List Code) Code) (` {#.type-args [(~+ (list/map (function (_ arg) (text$ (code-to-text arg))) args))]})) (def:' (export^ tokens) (-> (List Code) [Bool (List Code)]) (case tokens (#Cons [_ (#Tag [_ "export"])] tokens') [true tokens'] _ [false tokens])) (def:' (export ?) (-> Bool (List Code)) (if ? (list (' #export)) (list))) (macro:' #export (def: tokens) (list [(tag$ ["lux" "doc"]) (text$ "## Defines global constants/functions. (def: (rejoin-pair pair) (-> [Code Code] (List Code)) (let [[left right] pair] (list left right))) (def: branching-exponent Int 5)")]) (let [[export? tokens'] (export^ tokens) parts (: (Maybe [Code (List Code) (Maybe Code) Code (List [Code Code])]) (case tokens' (^ (list [_ (#Form (#Cons name args))] [_ (#Record meta-kvs)] type body)) (#Some [name args (#Some type) body meta-kvs]) (^ (list name [_ (#Record meta-kvs)] type body)) (#Some [name #Nil (#Some type) body meta-kvs]) (^ (list [_ (#Form (#Cons name args))] [_ (#Record meta-kvs)] body)) (#Some [name args #None body meta-kvs]) (^ (list name [_ (#Record meta-kvs)] body)) (#Some [name #Nil #None body meta-kvs]) (^ (list [_ (#Form (#Cons name args))] type body)) (#Some [name args (#Some type) body #Nil]) (^ (list name type body)) (#Some [name #Nil (#Some type) body #Nil]) (^ (list [_ (#Form (#Cons name args))] body)) (#Some [name args #None body #Nil]) (^ (list name body)) (#Some [name #Nil #None body #Nil]) _ #None))] (case parts (#Some name args ?type body meta) (let [body (case args #Nil body _ (` (function ((~ name) (~+ args)) (~ body)))) body (case ?type (#Some type) (` (: (~ type) (~ body))) #None body) =meta (process-def-meta meta)] (return (list (` ("lux def" (~ name) (~ body) [(~ cursor-code) (#Record (~ (with-func-args args (if export? (with-export-meta =meta) =meta))))]))))) #None (fail "Wrong syntax for def:")))) (def: (meta-code-add addition meta) (-> [Code Code] Code Code) (case [addition meta] [[name value] [cursor (#Record pairs)]] [cursor (#Record (#Cons [name value] pairs))] _ meta)) (def: (meta-code-merge addition base) (-> Code Code Code) (case addition [cursor (#Record pairs)] (list/fold meta-code-add base pairs) _ base)) (macro:' #export (macro: tokens) (list [(tag$ ["lux" "doc"]) (text$ "Macro-definition macro. (macro: #export (ident-for tokens) (case tokens (^template [] (^ (list [_ ( [prefix name])])) (return (list (` [(~ (text$ prefix)) (~ (text$ name))])))) ([#Symbol] [#Tag]) _ (fail \"Wrong syntax for ident-for\")))")]) (let [[exported? tokens] (export^ tokens) name+args+meta+body?? (: (Maybe [Ident (List Code) Code Code]) (case tokens (^ (list [_ (#Form (list& [_ (#Symbol name)] args))] body)) (#Some [name args (` {}) body]) (^ (list [_ (#Symbol name)] body)) (#Some [name #Nil (` {}) body]) (^ (list [_ (#Form (list& [_ (#Symbol name)] args))] [meta-rec-cursor (#Record meta-rec-parts)] body)) (#Some [name args [meta-rec-cursor (#Record meta-rec-parts)] body]) (^ (list [_ (#Symbol name)] [meta-rec-cursor (#Record meta-rec-parts)] body)) (#Some [name #Nil [meta-rec-cursor (#Record meta-rec-parts)] body]) _ #None))] (case name+args+meta+body?? (#Some [name args meta body]) (let [name (symbol$ name) def-sig (case args #Nil name _ (` ((~ name) (~+ args))))] (return (list (` (..def: (~+ (export exported?)) (~ def-sig) (~ (meta-code-merge (` {#.macro? true}) meta)) ..Macro (~ body)))))) #None (fail "Wrong syntax for macro:")))) (macro: #export (sig: tokens) {#.doc "## Definition of signatures ala ML. (sig: #export (Ord a) (: (Eq a) eq) (: (-> a a Bool) <) (: (-> a a Bool) <=) (: (-> a a Bool) >) (: (-> a a Bool) >=))"} (let [[exported? tokens'] (export^ tokens) ?parts (: (Maybe [Ident (List Code) Code (List Code)]) (case tokens' (^ (list& [_ (#Form (list& [_ (#Symbol name)] args))] [meta-rec-cursor (#Record meta-rec-parts)] sigs)) (#Some name args [meta-rec-cursor (#Record meta-rec-parts)] sigs) (^ (list& [_ (#Symbol name)] [meta-rec-cursor (#Record meta-rec-parts)] sigs)) (#Some name #Nil [meta-rec-cursor (#Record meta-rec-parts)] sigs) (^ (list& [_ (#Form (list& [_ (#Symbol name)] args))] sigs)) (#Some name args (` {}) sigs) (^ (list& [_ (#Symbol name)] sigs)) (#Some name #Nil (` {}) sigs) _ #None))] (case ?parts (#Some name args meta sigs) (do Monad [name+ (normalize name) sigs' (monad/map Monad macro-expand sigs) members (: (Meta (List [Text Code])) (monad/map Monad (: (-> Code (Meta [Text Code])) (function (_ token) (case token (^ [_ (#Form (list [_ (#Text "lux check")] type [_ (#Symbol ["" name])]))]) (wrap [name type]) _ (fail "Signatures require typed members!")))) (list/join sigs'))) #let [[_module _name] name+ def-name (symbol$ name) sig-type (record$ (list/map (: (-> [Text Code] [Code Code]) (function (_ [m-name m-type]) [(tag$ ["" m-name]) m-type])) members)) sig-meta (meta-code-merge (` {#.sig? true}) meta) usage (case args #Nil def-name _ (` ((~ def-name) (~+ args))))]] (return (list (` (..type: (~+ (export exported?)) (~ usage) (~ sig-meta) (~ sig-type)))))) #None (fail "Wrong syntax for sig:")))) (def: (find f xs) (All [a b] (-> (-> a (Maybe b)) (List a) (Maybe b))) (case xs #Nil #None (#Cons x xs') (case (f x) #None (find f xs') (#Some y) (#Some y)))) (do-template [
] [(macro: #export ( tokens) {#.doc } (case (list/reverse tokens) (^ (list& last init)) (return (list (list/fold (: (-> Code Code Code) (function (_ pre post) (` ))) last init))) _ (fail )))] [and (if (~ pre) (~ post) false) "'and' requires >=1 clauses." "Short-circuiting \"and\".\n(and true false true) ## => false"] [or (if (~ pre) true (~ post)) "'or' requires >=1 clauses." "Short-circuiting \"or\".\n(or true false true) ## => true"]) (def: (index-of part text) (-> Text Text (Maybe Nat)) ("lux text index" text part +0)) (def: (last-index-of' part part-size since text) (-> Text Nat Nat Text (Maybe Nat)) (case ("lux text index" text part (n/+ part-size since)) #None (#Some since) (#Some since') (last-index-of' part part-size since' text))) (def: (last-index-of part text) (-> Text Text (Maybe Nat)) (case ("lux text index" text part +0) (#Some since) (last-index-of' part ("lux text size" part) since text) #None #None)) (def: (clip1 from text) (-> Nat Text (Maybe Text)) ("lux text clip" text from ("lux text size" text))) (def: (clip2 from to text) (-> Nat Nat Text (Maybe Text)) ("lux text clip" text from to)) (def: #export (error! message) {#.doc "## Causes an error, with the given error message. (error! \"OH NO!\")"} (-> Text Nothing) ("lux io error" message)) (macro: (default tokens state) {#.doc "## Allows you to provide a default value that will be used ## if a (Maybe x) value turns out to be #.None. (default 20 (#.Some 10)) => 10 (default 20 #.None) => 20"} (case tokens (^ (list else maybe)) (let [g!temp (: Code [dummy-cursor (#Symbol ["" ""])]) code (` (case (~ maybe) (#.Some (~ g!temp)) (~ g!temp) #.None (~ else)))] (#Right [state (list code)])) _ (#Left "Wrong syntax for default"))) (def: (text/split splitter input) (-> Text Text (List Text)) (case (index-of splitter input) #None (list input) (#Some idx) (list& (default (error! "UNDEFINED") (clip2 +0 idx input)) (text/split splitter (default (error! "UNDEFINED") (clip1 (n/+ +1 idx) input)))))) (def: (nth idx xs) (All [a] (-> Nat (List a) (Maybe a))) (case xs #Nil #None (#Cons x xs') (if (n/= +0 idx) (#Some x) (nth (n/- +1 idx) xs') ))) (def: (beta-reduce env type) (-> (List Type) Type Type) (case type (#Sum left right) (#Sum (beta-reduce env left) (beta-reduce env right)) (#Product left right) (#Product (beta-reduce env left) (beta-reduce env right)) (#Apply arg func) (#Apply (beta-reduce env arg) (beta-reduce env func)) (#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) (#Function ?input ?output) (#Function (beta-reduce env ?input) (beta-reduce env ?output)) (#Bound idx) (case (nth idx env) (#Some bound) bound _ type) (#Named 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)) (#ExQ env body) (#Some (beta-reduce (list& type-fn param env) body)) (#Apply A F) (do Monad [type-fn* (apply-type F A)] (apply-type type-fn* param)) (#Named name type) (apply-type type param) _ #None)) (do-template [ ] [(def: ( type) (-> Type (List Type)) (case type ( left right) (list& left ( right)) _ (list type)))] [flatten-variant #Sum] [flatten-tuple #Product] [flatten-lambda #Function] ) (def: (flatten-app type) (-> Type [Type (List Type)]) (case type (#Apply head func') (let [[func tail] (flatten-app func')] [func (#Cons head tail)]) _ [type (list)])) (def: (resolve-struct-type type) (-> Type (Maybe (List Type))) (case type (#Product _) (#Some (flatten-tuple type)) (#Apply arg func) (do Monad [output (apply-type func arg)] (resolve-struct-type output)) (#UnivQ _ body) (resolve-struct-type body) (#ExQ _ body) (resolve-struct-type body) (#Named name type) (resolve-struct-type type) (#Sum _) #None _ (#Some (list type)))) (def: (find-module name) (-> Text (Meta Module)) (function (_ state) (let [{#info info #source source #current-module _ #modules modules #scopes scopes #type-context types #host host #seed seed #expected expected #cursor cursor #extensions extensions #scope-type-vars scope-type-vars} state] (case (get name modules) (#Some module) (#Right state module) _ (#Left ($_ text/compose "Unknown module: " name)))))) (def: get-current-module (Meta Module) (do Monad [module-name current-module-name] (find-module module-name))) (def: (resolve-tag [module name]) (-> Ident (Meta [Nat (List Ident) Bool Type])) (do Monad [=module (find-module module) #let [{#module-hash _ #module-aliases _ #definitions bindings #imports _ #tags tags-table #types types #module-annotations _ #module-state _} =module]] (case (get name tags-table) (#Some output) (return output) _ (fail (text/compose "Unknown tag: " (ident/encode [module name])))))) (def: (resolve-type-tags type) (-> Type (Meta (Maybe [(List Ident) (List Type)]))) (case type (#Apply arg func) (resolve-type-tags func) (#UnivQ env body) (resolve-type-tags body) (#ExQ env body) (resolve-type-tags body) (#Named [module name] unnamed) (do Monad [=module (find-module module) #let [{#module-hash _ #module-aliases _ #definitions bindings #imports _ #tags tags #types types #module-annotations _ #module-state _} =module]] (case (get name types) (#Some [tags exported? (#Named _ _type)]) (case (resolve-struct-type _type) (#Some members) (return (#Some [tags members])) _ (return #None)) _ (resolve-type-tags unnamed))) _ (return #None))) (def: get-expected-type (Meta Type) (function (_ state) (let [{#info info #source source #current-module _ #modules modules #scopes scopes #type-context types #host host #seed seed #expected expected #cursor cursor #extensions extensions #scope-type-vars scope-type-vars} state] (case expected (#Some type) (#Right state type) #None (#Left "Not expecting any type."))))) (macro: #export (struct tokens) {#.doc "Not meant to be used directly. Prefer \"struct:\"."} (do Monad [tokens' (monad/map Monad macro-expand tokens) struct-type get-expected-type tags+type (resolve-type-tags struct-type) tags (: (Meta (List Ident)) (case tags+type (#Some [tags _]) (return tags) _ (fail "No tags available for type."))) #let [tag-mappings (: (List [Text Code]) (list/map (function (_ tag) [(second tag) (tag$ tag)]) tags))] members (monad/map Monad (: (-> Code (Meta [Code Code])) (function (_ token) (case token (^ [_ (#Form (list [_ (#Text "lux def")] [_ (#Symbol "" tag-name)] value meta))]) (case (get tag-name tag-mappings) (#Some tag) (wrap [tag value]) _ (fail (text/compose "Unknown structure member: " tag-name))) _ (fail "Invalid structure member.")))) (list/join tokens'))] (wrap (list (record$ members))))) (def: (text/join parts) (-> (List Text) Text) (|> parts list/reverse (list/fold text/compose ""))) (macro: #export (struct: tokens) {#.doc "## Definition of structures ala ML. (struct: #export Ord (Ord Int) (def: eq Eq) (def: (< test subject) (lux.< test subject)) (def: (<= test subject) (or (lux.< test subject) (lux.= test subject))) (def: (lux.> test subject) (lux.> test subject)) (def: (lux.>= test subject) (or (lux.> test subject) (lux.= test subject))))"} (let [[exported? tokens'] (export^ tokens) ?parts (: (Maybe [Code (List Code) Code Code (List Code)]) (case tokens' (^ (list& [_ (#Form (list& name args))] [meta-rec-cursor (#Record meta-rec-parts)] type definitions)) (#Some name args type [meta-rec-cursor (#Record meta-rec-parts)] definitions) (^ (list& name [meta-rec-cursor (#Record meta-rec-parts)] type definitions)) (#Some name #Nil type [meta-rec-cursor (#Record meta-rec-parts)] definitions) (^ (list& [_ (#Form (list& name args))] type definitions)) (#Some name args type (` {}) definitions) (^ (list& name type definitions)) (#Some name #Nil type (` {}) definitions) _ #None))] (case ?parts (#Some [name args type meta definitions]) (case (case name [_ (#Symbol ["" "_"])] (case type (^ [_ (#Form (list& [_ (#Symbol [_ sig-name])] sig-args))]) (case (: (Maybe (List Text)) (monad/map Monad (function (_ sa) (case sa [_ (#Symbol [_ arg-name])] (#Some arg-name) _ #None)) sig-args)) (^ (#Some params)) (#Some (symbol$ ["" ($_ text/compose sig-name "<" (|> params (interpose ",") text/join) ">")])) _ #None) _ #None) _ (#Some name) ) (#Some name) (let [usage (case args #Nil name _ (` ((~ name) (~+ args))))] (return (list (` (..def: (~+ (export exported?)) (~ usage) (~ (meta-code-merge (` {#.struct? true}) meta)) (~ type) (struct (~+ definitions))))))) #None (fail "Cannot infer name, so struct must have a name other than \"_\"!")) #None (fail "Wrong syntax for struct:")))) (def: #export (id x) {#.doc "Identity function. Does nothing to it's argument and just returns it."} (All [a] (-> a a)) x) (macro: #export (type: tokens) {#.doc "## The type-definition macro. (type: (List a) #Nil (#Cons a (List a)))"} (let [[exported? tokens'] (export^ tokens) [rec? tokens'] (case tokens' (#Cons [_ (#Tag [_ "rec"])] tokens') [true tokens'] _ [false tokens']) parts (: (Maybe [Text (List Code) Code (List Code)]) (case tokens' (^ (list [_ (#Symbol "" name)] [meta-cursor (#Record meta-parts)] [type-cursor (#Record type-parts)])) (#Some [name #Nil [meta-cursor (#Record meta-parts)] (list [type-cursor (#Record type-parts)])]) (^ (list& [_ (#Symbol "" name)] [meta-cursor (#Record meta-parts)] type-code1 type-codes)) (#Some [name #Nil [meta-cursor (#Record meta-parts)] (#Cons type-code1 type-codes)]) (^ (list& [_ (#Symbol "" name)] type-codes)) (#Some [name #Nil (` {}) type-codes]) (^ (list [_ (#Form (#Cons [_ (#Symbol "" name)] args))] [meta-cursor (#Record meta-parts)] [type-cursor (#Record type-parts)])) (#Some [name args [meta-cursor (#Record meta-parts)] (list [type-cursor (#Record type-parts)])]) (^ (list& [_ (#Form (#Cons [_ (#Symbol "" name)] args))] [meta-cursor (#Record meta-parts)] type-code1 type-codes)) (#Some [name args [meta-cursor (#Record meta-parts)] (#Cons type-code1 type-codes)]) (^ (list& [_ (#Form (#Cons [_ (#Symbol "" name)] args))] type-codes)) (#Some [name args (` {}) type-codes]) _ #None))] (case parts (#Some name args meta type-codes) (do Monad [type+tags?? (unfold-type-def type-codes) module-name current-module-name] (let [type-name (symbol$ ["" name]) [type tags??] type+tags?? type-meta (: Code (case tags?? (#Some tags) (` {#.tags [(~+ (list/map text$ tags))] #.type? true}) _ (` {#.type? true}))) type' (: (Maybe Code) (if rec? (if (empty? args) (let [g!param (symbol$ ["" ""]) prime-name (symbol$ ["" name]) type+ (replace-syntax (list [name (` ((~ prime-name) .Nothing))]) type)] (#Some (` ((All (~ prime-name) [(~ g!param)] (~ type+)) .Nothing)))) #None) (case args #Nil (#Some type) _ (#Some (` (All (~ type-name) [(~+ args)] (~ type)))))))] (case type' (#Some type'') (return (list (` (..def: (~+ (export exported?)) (~ type-name) (~ ($_ meta-code-merge (with-type-args args) (if rec? (' {#.type-rec? true}) (' {})) type-meta meta)) Type (#.Named [(~ (text$ module-name)) (~ (text$ name))] (type (~ type''))))))) #None (fail "Wrong syntax for type:")))) #None (fail "Wrong syntax for type:")) )) (type: Referrals #All (#Only (List Text)) (#Exclude (List Text)) #Nothing) (type: Openings [Text (List Ident)]) (type: Refer {#refer-defs Referrals #refer-open (List Openings)}) (type: Importation {#import-name Text #import-alias (Maybe Text) #import-refer Refer}) (def: (extract-defs defs) (-> (List Code) (Meta (List Text))) (monad/map Monad (: (-> Code (Meta Text)) (function (_ def) (case def [_ (#Symbol ["" name])] (return name) _ (fail "only/exclude requires symbols.")))) defs)) (def: (parse-alias tokens) (-> (List Code) (Meta [(Maybe Text) (List Code)])) (case tokens (^ (list& [_ (#Tag "" "as")] [_ (#Symbol "" alias)] tokens')) (return [(#Some alias) tokens']) _ (return [#None tokens]))) (def: (parse-referrals tokens) (-> (List Code) (Meta [Referrals (List Code)])) (case tokens (^ (list& [_ (#Tag ["" "refer"])] referral tokens')) (case referral [_ (#Tag "" "all")] (return [#All tokens']) (^ [_ (#Form (list& [_ (#Tag ["" "only"])] defs))]) (do Monad [defs' (extract-defs defs)] (return [(#Only defs') tokens'])) (^ [_ (#Form (list& [_ (#Tag ["" "exclude"])] defs))]) (do Monad [defs' (extract-defs defs)] (return [(#Exclude defs') tokens'])) _ (fail "Incorrect syntax for referral.")) _ (return [#Nothing tokens]))) (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)] [(list/reverse ys') xs'])) (def: (parse-short-referrals tokens) (-> (List Code) (Meta [Referrals (List Code)])) (case tokens (^ (list& [_ (#Tag "" "+")] tokens')) (let [[defs tokens'] (split-with symbol? tokens')] (do Monad [defs' (extract-defs defs)] (return [(#Only defs') tokens']))) (^ (list& [_ (#Tag "" "-")] tokens')) (let [[defs tokens'] (split-with symbol? tokens')] (do Monad [defs' (extract-defs defs)] (return [(#Exclude defs') tokens']))) (^ (list& [_ (#Tag "" "*")] tokens')) (return [#All tokens']) _ (return [#Nothing tokens]))) (def: (extract-symbol syntax) (-> Code (Meta Ident)) (case syntax [_ (#Symbol ident)] (return ident) _ (fail "Not a symbol."))) (def: (parse-openings tokens) (-> (List Code) (Meta [(List Openings) (List Code)])) (case tokens (^ (list& [_ (#Tag "" "open")] [_ (#Form parts)] tokens')) (if (|> parts (list/map (: (-> Code Bool) (function (_ part) (case part (^or [_ (#Text _)] [_ (#Symbol _)]) true _ false)))) (list/fold (function (_ r l) (and l r)) true)) (let [openings (list/fold (: (-> Code (List Openings) (List Openings)) (function (_ part openings) (case part [_ (#Text prefix)] (list& [prefix (list)] openings) [_ (#Symbol struct-name)] (case openings #Nil (list ["" (list struct-name)]) (#Cons [prefix structs] openings') (#Cons [prefix (#Cons struct-name structs)] openings')) _ openings))) (: (List Openings) (list)) parts)] (return [openings tokens'])) (fail "Expected all parts of opening form to be of either prefix (text) or struct (symbol).")) _ (return [(list) tokens]))) (def: (parse-short-openings parts) (-> (List Code) (Meta [(List Openings) (List Code)])) (if (|> parts (list/map (: (-> Code Bool) (function (_ part) (case part (^or [_ (#Text _)] [_ (#Symbol _)]) true _ false)))) (list/fold (function (_ r l) (and l r)) true)) (let [openings (list/fold (: (-> Code (List Openings) (List Openings)) (function (_ part openings) (case part [_ (#Text prefix)] (list& [prefix (list)] openings) [_ (#Symbol struct-name)] (case openings #Nil (list ["" (list struct-name)]) (#Cons [prefix structs] openings') (#Cons [prefix (#Cons struct-name structs)] openings')) _ openings))) (: (List Openings) (list)) parts)] (return [openings (list)])) (fail "Expected all parts of opening form to be of either prefix (text) or struct (symbol)."))) (def: (decorate-sub-importations super-name) (-> Text (List Importation) (List Importation)) (list/map (: (-> Importation Importation) (function (_ importation) (let [{#import-name _name #import-alias _alias #import-refer {#refer-defs _referrals #refer-open _openings}} importation] {#import-name ($_ text/compose super-name "/" _name) #import-alias _alias #import-refer {#refer-defs _referrals #refer-open _openings}}))))) (def: (replace-all pattern value template) (-> Text Text Text Text) ("lux text replace-all" template pattern value)) (def: (count-ups ups input) (-> Nat Text Nat) (case ("lux text index" input "/" ups) #None ups (#Some found) (if (n/= ups found) (count-ups (n/+ +1 ups) input) ups))) (def: (list/drop amount a+) (All [a] (-> Nat (List a) (List a))) (case [amount a+] (^or [+0 _] [_ #Nil]) a+ [_ (#Cons _ a+')] (list/drop (n/- +1 amount) a+'))) (def: (clean-module relative-root module) (-> Text Text (Meta Text)) (case (count-ups +0 module) +0 (return module) ups (let [parts (text/split "/" relative-root)] (if (n/< (list/size parts) (n/- +1 ups)) (let [prefix (|> parts list/reverse (list/drop (n/- +1 ups)) list/reverse (interpose "/") text/join) clean (|> module (clip1 ups) (default (error! "UNDEFINED"))) output (case ("lux text size" clean) +0 prefix _ ($_ text/compose prefix "/" clean))] (return output)) (fail ($_ text/compose "Cannot climb the module hierarchy...\n" "Importing module: " module "\n" " Relative Root: " relative-root "\n")))))) (def: (parse-imports relative-root imports) (-> Text (List Code) (Meta (List Importation))) (do Monad [imports' (monad/map Monad (: (-> Code (Meta (List Importation))) (function (_ token) (case token [_ (#Symbol "" m-name)] (do Monad [m-name (clean-module relative-root m-name)] (wrap (list [m-name #None {#refer-defs #All #refer-open (list)}]))) (^ [_ (#Form (list& [_ (#Symbol "" m-name)] extra))]) (do Monad [m-name (clean-module relative-root m-name) 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] sub-imports (parse-imports relative-root extra) #let [sub-imports (decorate-sub-importations m-name sub-imports)]] (wrap (case [referral alias openings] [#Nothing #None #Nil] sub-imports _ (list& {#import-name m-name #import-alias alias #import-refer {#refer-defs referral #refer-open openings}} sub-imports)))) (^ [_ (#Tuple (list& [_ (#Text alias)] [_ (#Symbol "" m-name)] extra))]) (do Monad [m-name (clean-module relative-root m-name) referral+extra (parse-short-referrals extra) #let [[referral extra] referral+extra] openings+extra (parse-short-openings extra) #let [[openings extra] openings+extra]] (wrap (list {#import-name m-name #import-alias (#Some (replace-all "." m-name alias)) #import-refer {#refer-defs referral #refer-open openings}}))) (^ [_ (#Tuple (list& [_ (#Symbol "" raw-m-name)] extra))]) (do Monad [m-name (clean-module relative-root raw-m-name) referral+extra (parse-short-referrals extra) #let [[referral extra] referral+extra] openings+extra (parse-short-openings extra) #let [[openings extra] openings+extra]] (wrap (list {#import-name m-name #import-alias (#Some raw-m-name) #import-refer {#refer-defs referral #refer-open openings}}))) _ (do Monad [current-module current-module-name] (fail (text/compose "Wrong syntax for import @ " current-module)))))) imports)] (wrap (list/join imports')))) (def: (exported-definitions module state) (-> Text (Meta (List Text))) (let [modules (case state {#info info #source source #current-module _ #modules modules #scopes scopes #type-context types #host host #seed seed #expected expected #cursor cursor #extensions extensions #scope-type-vars scope-type-vars} modules)] (case (get module modules) (#Some =module) (let [to-alias (list/map (: (-> [Text Definition] (List Text)) (function (_ [name [def-type def-meta def-value]]) (case (get-meta ["lux" "export?"] def-meta) (#Some [_ (#Bool true)]) (list name) _ (list)))) (let [{#module-hash _ #module-aliases _ #definitions definitions #imports _ #tags tags #types types #module-annotations _ #module-state _} =module] definitions))] (#Right state (list/join to-alias))) #None (#Left ($_ text/compose "Unknown module: " module))) )) (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 (list/fold (function (_ case prev) (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 Lux (Maybe Type)) (case state {#info info #source source #current-module _ #modules modules #scopes scopes #type-context types #host host #seed seed #expected expected #cursor cursor #extensions extensions #scope-type-vars scope-type-vars} (find (: (-> Scope (Maybe Type)) (function (_ env) (case env {#name _ #inner _ #locals {#counter _ #mappings locals} #captured {#counter _ #mappings closure}} (try-both (find (: (-> [Text [Type Any]] (Maybe Type)) (function (_ [bname [type _]]) (if (text/= name bname) (#Some type) #None)))) (: (List [Text [Type Any]]) locals) (: (List [Text [Type Any]]) closure))))) scopes))) (def: (find-def-type name state) (-> Ident Lux (Maybe Type)) (let [[v-prefix v-name] name {#info info #source source #current-module _ #modules modules #scopes scopes #type-context types #host host #seed seed #expected expected #cursor cursor #extensions extensions #scope-type-vars scope-type-vars} state] (case (get v-prefix modules) #None #None (#Some {#definitions definitions #module-hash _ #module-aliases _ #imports _ #tags tags #types types #module-annotations _ #module-state _}) (case (get v-name definitions) #None #None (#Some [def-type def-meta def-value]) (#Some def-type))))) (def: (find-def-value name state) (-> Ident (Meta [Type Any])) (let [[v-prefix v-name] name {#info info #source source #current-module _ #modules modules #scopes scopes #type-context types #host host #seed seed #expected expected #cursor cursor #extensions extensions #scope-type-vars scope-type-vars} state] (case (get v-prefix modules) #None (#Left (text/compose "Unknown definition: " (ident/encode name))) (#Some {#definitions definitions #module-hash _ #module-aliases _ #imports _ #tags tags #types types #module-annotations _ #module-state _}) (case (get v-name definitions) #None (#Left (text/compose "Unknown definition: " (ident/encode name))) (#Some [def-type def-meta def-value]) (#Right [state [def-type def-value]]))))) (def: (find-type-var idx bindings) (-> Nat (List [Nat (Maybe Type)]) (Maybe Type)) (case bindings #Nil #Nil (#Cons [var bound] bindings') (if (n/= idx var) bound (find-type-var idx bindings')))) (def: (find-type ident) (-> Ident (Meta Type)) (do Monad [#let [[module name] ident] current-module current-module-name] (function (_ compiler) (let [temp (if (text/= "" module) (case (find-in-env name compiler) (#Some struct-type) (#Right [compiler struct-type]) _ (case (find-def-type [current-module name] compiler) (#Some struct-type) (#Right [compiler struct-type]) _ (#Left ($_ text/compose "Unknown var: " (ident/encode ident))))) (case (find-def-type ident compiler) (#Some struct-type) (#Right [compiler struct-type]) _ (#Left ($_ text/compose "Unknown var: " (ident/encode ident)))))] (case temp (#Right [compiler (#Var type-id)]) (let [{#info _ #source _ #current-module _ #modules _ #scopes _ #type-context type-context #host _ #seed _ #expected _ #cursor _ #extensions extensions #scope-type-vars _} compiler {#ex-counter _ #var-counter _ #var-bindings var-bindings} type-context] (case (find-type-var type-id var-bindings) #None temp (#Some actualT) (#Right [compiler actualT]))) _ temp)) ))) (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: (type/show type) (-> Type Text) (case type (#Primitive name params) (case params #Nil name _ ($_ text/compose "(" name " " (|> params (list/map type/show) (interpose " ") list/reverse (list/fold text/compose "")) ")")) (#Sum _) ($_ text/compose "(| " (|> (flatten-variant type) (list/map type/show) (interpose " ") list/reverse (list/fold text/compose "")) ")") (#Product _) ($_ text/compose "[" (|> (flatten-tuple type) (list/map type/show) (interpose " ") list/reverse (list/fold text/compose "")) "]") (#Function _) ($_ text/compose "(-> " (|> (flatten-lambda type) (list/map type/show) (interpose " ") list/reverse (list/fold text/compose "")) ")") (#Bound id) (nat/encode id) (#Var id) ($_ text/compose "⌈v:" (nat/encode id) "⌋") (#Ex id) ($_ text/compose "⟨e:" (nat/encode id) "⟩") (#UnivQ env body) ($_ text/compose "(All " (type/show body) ")") (#ExQ env body) ($_ text/compose "(Ex " (type/show body) ")") (#Apply _) (let [[func args] (flatten-app type)] ($_ text/compose "(" (type/show func) " " (|> args (list/map type/show) (interpose " ") list/reverse (list/fold text/compose "")) ")")) (#Named [prefix name] _) ($_ text/compose prefix "." name) )) (macro: #export (^open tokens) {#.doc "## Same as the \"open\" macro, but meant to be used as a pattern-matching macro for generating local bindings. ## Can optionally take a \"prefix\" text for the generated local bindings. (def: #export (range (^open) from to) (All [a] (-> (Enum a) a a (List a))) (range' <= succ from to))"} (case tokens (^ (list& [_ (#Form (list))] body branches)) (do Monad [g!temp (gensym "temp")] (wrap (list& g!temp (` (..^open (~ g!temp) "" (~ body))) branches))) (^ (list& [_ (#Form (list [_ (#Text prefix)]))] body branches)) (do Monad [g!temp (gensym "temp")] (wrap (list& g!temp (` (..^open (~ g!temp) (~ (text$ prefix)) (~ body))) branches))) (^ (list [_ (#Symbol name)] [_ (#Text prefix)] body)) (do Monad [init-type (find-type name) struct-evidence (resolve-type-tags init-type)] (case struct-evidence #None (fail (text/compose "Can only \"open\" structs: " (type/show init-type))) (#Some tags&members) (do Monad [full-body ((: (-> Ident [(List Ident) (List Type)] Code (Meta Code)) (function (recur source [tags members] target) (let [pattern (record$ (list/map (function (_ [t-module t-name]) [(tag$ [t-module t-name]) (symbol$ ["" (text/compose prefix t-name)])]) tags))] (do Monad [enhanced-target (monad/fold Monad (function (_ [[_ m-name] m-type] enhanced-target) (do Monad [m-structure (resolve-type-tags m-type)] (case m-structure (#Some m-tags&members) (recur ["" (text/compose prefix m-name)] m-tags&members enhanced-target) #None (wrap enhanced-target)))) target (zip2 tags members))] (wrap (` ("lux case" (~ (symbol$ source)) {(~ pattern) (~ enhanced-target)}))))))) name tags&members body)] (wrap (list full-body))))) _ (fail "Wrong syntax for ^open"))) (macro: #export (cond tokens) {#.doc "## Branching structures with multiple test conditions. (cond (n/even? num) \"even\" (n/odd? num) \"odd\" ## else-branch \"???\")"} (if (n/= +0 (n/% +2 (list/size tokens))) (fail "cond requires an uneven number of arguments.") (case (list/reverse tokens) (^ (list& else branches')) (return (list (list/fold (: (-> [Code Code] Code Code) (function (_ branch else) (let [[right left] branch] (` (if (~ left) (~ right) (~ else)))))) else (as-pairs branches')))) _ (fail "Wrong syntax for cond")))) (def: (enumerate' idx xs) (All [a] (-> Nat (List a) (List [Nat a]))) (case xs (#Cons x xs') (#Cons [idx x] (enumerate' (n/+ +1 idx) xs')) #Nil #Nil)) (def: (enumerate xs) (All [a] (-> (List a) (List [Nat a]))) (enumerate' +0 xs)) (macro: #export (get@ tokens) {#.doc "## Accesses the value of a record at a given tag. (get@ #field my-record) ## Can also work with multiple levels of nesting: (get@ [#foo #bar #baz] my-record) ## And, if only the slot/path is given, generates an ## accessor function: (let [getter (get@ [#foo #bar #baz])] (getter my-record))"} (case tokens (^ (list [_ (#Tag slot')] record)) (do Monad [slot (normalize slot') output (resolve-tag slot) #let [[idx tags exported? type] output] g!_ (gensym "_") g!output (gensym "")] (case (resolve-struct-type type) (#Some members) (let [pattern (record$ (list/map (: (-> [Ident [Nat Type]] [Code Code]) (function (_ [[r-prefix r-name] [r-idx r-type]]) [(tag$ [r-prefix r-name]) (if (n/= idx r-idx) g!output g!_)])) (zip2 tags (enumerate members))))] (return (list (` ("lux case" (~ record) {(~ pattern) (~ g!output)}))))) _ (fail "get@ can only use records."))) (^ (list [_ (#Tuple slots)] record)) (return (list (list/fold (: (-> Code Code Code) (function (_ slot inner) (` (..get@ (~ slot) (~ inner))))) record slots))) (^ (list selector)) (do Monad [g!_ (gensym "_") g!record (gensym "record")] (wrap (list (` (function ((~ g!_) (~ g!record)) (..get@ (~ selector) (~ g!record))))))) _ (fail "Wrong syntax for get@"))) (def: (open-field prefix [module name] source type) (-> Text Ident Code Type (Meta (List Code))) (do Monad [output (resolve-type-tags type) #let [source+ (` (get@ (~ (tag$ [module name])) (~ source)))]] (case output (#Some [tags members]) (do Monad [decls' (monad/map Monad (: (-> [Ident Type] (Meta (List Code))) (function (_ [sname stype]) (open-field prefix sname source+ stype))) (zip2 tags members))] (return (list/join decls'))) _ (return (list (` ("lux def" (~ (symbol$ ["" (text/compose prefix name)])) (~ source+) [(~ cursor-code) (#.Record #Nil)]))))))) (macro: #export (open tokens) {#.doc "## Opens a structure and generates a definition for each of its members (including nested members). ## For example: (open Number \"i:\") ## Will generate: (def: i:+ (:: Number +)) (def: i:- (:: Number -)) (def: i:* (:: Number *)) ..."} (case tokens (^ (list& [_ (#Symbol struct-name)] tokens')) (do Monad [@module current-module-name #let [prefix (case tokens' (^ (list [_ (#Text prefix)])) prefix _ "")] struct-type (find-type struct-name) output (resolve-type-tags struct-type) #let [source (symbol$ struct-name)]] (case output (#Some [tags members]) (do Monad [decls' (monad/map Monad (: (-> [Ident Type] (Meta (List Code))) (function (_ [sname stype]) (open-field prefix sname source stype))) (zip2 tags members))] (return (list/join decls'))) _ (fail (text/compose "Can only \"open\" structs: " (type/show struct-type))))) _ (fail "Wrong syntax for open"))) (macro: #export (|>> tokens) {#.doc "## Similar to the piping macro, but rather than taking an initial object to work on, creates a function for taking it. (|>> (list/map int/encode) (interpose \" \") (fold text/compose \"\")) ## => (function (_ ) (fold text/compose \"\" (interpose \" \" (list/map int/encode ))))"} (do Monad [g!_ (gensym "_") g!arg (gensym "arg")] (return (list (` (function ((~ g!_) (~ g!arg)) (|> (~ g!arg) (~+ tokens)))))))) (macro: #export (<<| tokens) {#.doc "## Similar to the piping macro, but rather than taking an initial object to work on, creates a function for taking it. (<<| (fold text/compose \"\") (interpose \" \") (list/map int/encode)) ## => (function (_ ) (fold text/compose \"\" (interpose \" \" (list/map int/encode ))))"} (do Monad [g!_ (gensym "_") g!arg (gensym "arg")] (return (list (` (function ((~ g!_) (~ g!arg)) (<| (~+ tokens) (~ g!arg)))))))) (def: (imported-by? import-name module-name) (-> Text Text (Meta Bool)) (do Monad [module (find-module module-name) #let [{#module-hash _ #module-aliases _ #definitions _ #imports imports #tags _ #types _ #module-annotations _ #module-state _} module]] (wrap (is-member? imports import-name)))) (def: (read-refer module-name options) (-> Text (List Code) (Meta Refer)) (do Monad [referral+options (parse-referrals options) #let [[referral options] referral+options] openings+options (parse-openings options) #let [[openings options] openings+options] current-module current-module-name #let [test-referrals (: (-> Text (List Text) (List Text) (Meta (List Any))) (function (_ module-name all-defs referred-defs) (monad/map Monad (: (-> Text (Meta Any)) (function (_ _def) (if (is-member? all-defs _def) (return []) (fail ($_ text/compose _def " is not defined in module " module-name " @ " current-module))))) referred-defs)))]] (case options #Nil (wrap {#refer-defs referral #refer-open openings}) _ (fail ($_ text/compose "Wrong syntax for refer @ " current-module "\n" (|> options (list/map code-to-text) (interpose " ") (list/fold text/compose ""))))))) (def: (write-refer module-name [r-defs r-opens]) (-> Text Refer (Meta (List Code))) (do Monad [current-module current-module-name #let [test-referrals (: (-> Text (List Text) (List Text) (Meta (List Any))) (function (_ module-name all-defs referred-defs) (monad/map Monad (: (-> Text (Meta Any)) (function (_ _def) (if (is-member? all-defs _def) (return []) (fail ($_ text/compose _def " is not defined in module " module-name " @ " current-module))))) referred-defs)))] defs' (case r-defs #All (exported-definitions module-name) (#Only +defs) (do Monad [*defs (exported-definitions module-name) _ (test-referrals module-name *defs +defs)] (wrap +defs)) (#Exclude -defs) (do Monad [*defs (exported-definitions module-name) _ (test-referrals module-name *defs -defs)] (wrap (filter (|>> (is-member? -defs) not) *defs))) #Nothing (wrap (list))) #let [defs (list/map (: (-> Text Code) (function (_ def) (` ("lux def" (~ (symbol$ ["" def])) (~ (symbol$ [module-name def])) [(~ cursor-code) (#.Record (#Cons [[(~ cursor-code) (#.Tag ["lux" "alias"])] [(~ cursor-code) (#.Symbol [(~ (text$ module-name)) (~ (text$ def))])]] #Nil))])))) defs') openings (join-map (: (-> Openings (List Code)) (function (_ [prefix structs]) (list/map (function (_ [_ name]) (` (open (~ (symbol$ [module-name name])) (~ (text$ prefix))))) structs))) r-opens)]] (wrap (list/compose defs openings)) )) (macro: #export (refer tokens) (case tokens (^ (list& [_ (#Text module-name)] options)) (do Monad [=refer (read-refer module-name options)] (write-refer module-name =refer)) _ (fail "Wrong syntax for refer"))) (def: (refer-to-code module-name [r-defs r-opens]) (-> Text Refer Code) (let [=defs (: (List Code) (case r-defs #All (list (' #refer) (' #all)) (#Only defs) (list (' #refer) (`' (#only (~+ (list/map (|>> [""] symbol$) defs))))) (#Exclude defs) (list (' #refer) (`' (#exclude (~+ (list/map (|>> [""] symbol$) defs))))) #Nothing (list))) =opens (join-map (function (_ [prefix structs]) (list& (text$ prefix) (list/map symbol$ structs))) r-opens)] (` (..refer (~ (text$ module-name)) (~+ =defs) (~' #open) ((~+ =opens)))))) (macro: #export (module: tokens) {#.doc "Module-definition macro. Can take optional annotations and allows the specification of modules to import. ## Examples (.module: {#.doc \"Some documentation...\"} lux (lux (control (monad #as M #refer #all)) (data (text #open (\"text/\" Monoid)) (coll (list #open (\"list/\" Monad))) maybe (ident #open (\"ident/\" Codec))) meta (macro code)) (// (type #open (\"\" Eq)))) (.module: {#.doc \"Some documentation...\"} lux (lux (control [\"M\" monad #*]) (data [text \"text/\" Monoid] (coll [list \"list/\" Monad]) maybe [ident \"ident/\" Codec]) meta (macro code)) (// [type \"\" Eq]))"} (do Monad [#let [[_meta _imports] (: [(List [Code Code]) (List Code)] (case tokens (^ (list& [_ (#Record _meta)] _imports)) [_meta _imports] _ [(list) tokens]))] current-module current-module-name imports (parse-imports current-module _imports) #let [=imports (list/map (: (-> Importation Code) (function (_ [m-name m-alias =refer]) (` [(~ (text$ m-name)) (~ (text$ (default "" m-alias)))]))) imports) =refers (list/map (: (-> Importation Code) (function (_ [m-name m-alias =refer]) (refer-to-code m-name =refer))) imports) =meta (process-def-meta (list& [(` #.imports) (` [(~+ =imports)])] _meta)) =module (` ("lux module" [(~ cursor-code) (#.Record (~ =meta))]))]] (wrap (#Cons =module =refers)))) (macro: #export (:: tokens) {#.doc "## Allows accessing the value of a structure's member. (:: Codec encode) ## Also allows using that value as a function. (:: Codec encode 123)"} (case tokens (^ (list struct [_ (#Symbol member)])) (return (list (` (let [(^open) (~ struct)] (~ (symbol$ member)))))) (^ (list& struct [_ (#Symbol member)] args)) (return (list (` ((let [(^open) (~ struct)] (~ (symbol$ member))) (~+ args))))) _ (fail "Wrong syntax for ::"))) (macro: #export (set@ tokens) {#.doc "## Sets the value of a record at a given tag. (set@ #name \"Lux\" lang) ## Can also work with multiple levels of nesting: (set@ [#foo #bar #baz] value my-record) ## And, if only the slot/path and (optionally) the value are given, generates a ## mutator function: (let [setter (set@ [#foo #bar #baz] value)] (setter my-record)) (let [setter (set@ [#foo #bar #baz])] (setter value my-record))"} (case tokens (^ (list [_ (#Tag slot')] value record)) (do Monad [slot (normalize slot') output (resolve-tag slot) #let [[idx tags exported? type] output]] (case (resolve-struct-type type) (#Some members) (do Monad [pattern' (monad/map Monad (: (-> [Ident [Nat Type]] (Meta [Ident Nat Code])) (function (_ [r-slot-name [r-idx r-type]]) (do Monad [g!slot (gensym "")] (return [r-slot-name r-idx g!slot])))) (zip2 tags (enumerate members)))] (let [pattern (record$ (list/map (: (-> [Ident Nat Code] [Code Code]) (function (_ [r-slot-name r-idx r-var]) [(tag$ r-slot-name) r-var])) pattern')) output (record$ (list/map (: (-> [Ident Nat Code] [Code Code]) (function (_ [r-slot-name r-idx r-var]) [(tag$ r-slot-name) (if (n/= idx r-idx) value r-var)])) pattern'))] (return (list (` ("lux case" (~ record) {(~ pattern) (~ output)})))))) _ (fail "set@ can only use records."))) (^ (list [_ (#Tuple slots)] value record)) (case slots #Nil (fail "Wrong syntax for set@") _ (do Monad [bindings (monad/map Monad (: (-> Code (Meta Code)) (function (_ _) (gensym "temp"))) slots) #let [pairs (zip2 slots bindings) update-expr (list/fold (: (-> [Code Code] Code Code) (function (_ [s b] v) (` (..set@ (~ s) (~ v) (~ b))))) value (list/reverse pairs)) [_ accesses'] (list/fold (: (-> [Code Code] [Code (List (List Code))] [Code (List (List Code))]) (function (_ [new-slot new-binding] [old-record accesses']) [(` (get@ (~ new-slot) (~ new-binding))) (#Cons (list new-binding old-record) accesses')])) [record (: (List (List Code)) #Nil)] pairs) accesses (list/join (list/reverse accesses'))]] (wrap (list (` (let [(~+ accesses)] (~ update-expr))))))) (^ (list selector value)) (do Monad [g!_ (gensym "_") g!record (gensym "record")] (wrap (list (` (function ((~ g!_) (~ g!record)) (..set@ (~ selector) (~ value) (~ g!record))))))) (^ (list selector)) (do Monad [g!_ (gensym "_") g!value (gensym "value") g!record (gensym "record")] (wrap (list (` (function ((~ g!_) (~ g!value) (~ g!record)) (..set@ (~ selector) (~ g!value) (~ g!record))))))) _ (fail "Wrong syntax for set@"))) (macro: #export (update@ tokens) {#.doc "## Modifies the value of a record at a given tag, based on some function. (update@ #age inc person) ## Can also work with multiple levels of nesting: (update@ [#foo #bar #baz] func my-record) ## And, if only the slot/path and (optionally) the value are given, generates a ## mutator function: (let [updater (update@ [#foo #bar #baz] func)] (updater my-record)) (let [updater (update@ [#foo #bar #baz])] (updater func my-record))"} (case tokens (^ (list [_ (#Tag slot')] fun record)) (do Monad [slot (normalize slot') output (resolve-tag slot) #let [[idx tags exported? type] output]] (case (resolve-struct-type type) (#Some members) (do Monad [pattern' (monad/map Monad (: (-> [Ident [Nat Type]] (Meta [Ident Nat Code])) (function (_ [r-slot-name [r-idx r-type]]) (do Monad [g!slot (gensym "")] (return [r-slot-name r-idx g!slot])))) (zip2 tags (enumerate members)))] (let [pattern (record$ (list/map (: (-> [Ident Nat Code] [Code Code]) (function (_ [r-slot-name r-idx r-var]) [(tag$ r-slot-name) r-var])) pattern')) output (record$ (list/map (: (-> [Ident Nat Code] [Code Code]) (function (_ [r-slot-name r-idx r-var]) [(tag$ r-slot-name) (if (n/= idx r-idx) (` ((~ fun) (~ r-var))) r-var)])) pattern'))] (return (list (` ("lux case" (~ record) {(~ pattern) (~ output)})))))) _ (fail "update@ can only use records."))) (^ (list [_ (#Tuple slots)] fun record)) (case slots #Nil (fail "Wrong syntax for update@") _ (do Monad [g!record (gensym "record") g!temp (gensym "temp")] (wrap (list (` (let [(~ g!record) (~ record) (~ g!temp) (get@ [(~+ slots)] (~ g!record))] (set@ [(~+ slots)] ((~ fun) (~ g!temp)) (~ g!record)))))))) (^ (list selector fun)) (do Monad [g!_ (gensym "_") g!record (gensym "record")] (wrap (list (` (function ((~ g!_) (~ g!record)) (..update@ (~ selector) (~ fun) (~ g!record))))))) (^ (list selector)) (do Monad [g!_ (gensym "_") g!fun (gensym "fun") g!record (gensym "record")] (wrap (list (` (function ((~ g!_) (~ g!fun) (~ g!record)) (..update@ (~ selector) (~ g!fun) (~ g!record))))))) _ (fail "Wrong syntax for update@"))) (macro: #export (^template tokens) {#.doc "## It's similar to do-template, but meant to be used during pattern-matching. (def: (beta-reduce env type) (-> (List Type) Type Type) (case type (#.Primitive name params) (#.Primitive name (list/map (beta-reduce env) params)) (^template [] ( left right) ( (beta-reduce env left) (beta-reduce env right))) ([#.Sum] [#.Product]) (^template [] ( left right) ( (beta-reduce env left) (beta-reduce env right))) ([#.Function] [#.Apply]) (^template [] ( old-env def) (case old-env #.Nil ( env def) _ type)) ([#.UnivQ] [#.ExQ]) (#.Bound idx) (default type (list.nth idx env)) _ type ))"} (case tokens (^ (list& [_ (#Form (list& [_ (#Tuple bindings)] templates))] [_ (#Form data)] branches)) (case (: (Maybe (List Code)) (do Monad [bindings' (monad/map Monad get-name bindings) data' (monad/map Monad tuple->list data)] (if (every? (n/= (list/size bindings')) (list/map list/size data')) (let [apply (: (-> RepEnv (List Code)) (function (_ env) (list/map (apply-template env) templates)))] (|> data' (join-map (compose apply (make-env bindings'))) wrap)) #None))) (#Some output) (return (list/compose output branches)) #None (fail "Wrong syntax for ^template")) _ (fail "Wrong syntax for ^template"))) (do-template [ ] [(def: #export ( n) (-> ) ( [n]))] [frac-to-int Frac Int "lux frac int"] [int-to-frac Int Frac "lux int frac"] ) (def: (find-baseline-column code) (-> Code Nat) (case code (^template [] [[_ _ column] ( _)] column) ([#Bool] [#Nat] [#Int] [#Deg] [#Frac] [#Text] [#Symbol] [#Tag]) (^template [] [[_ _ column] ( parts)] (list/fold n/min column (list/map find-baseline-column parts))) ([#Form] [#Tuple]) [[_ _ column] (#Record pairs)] (list/fold n/min column (list/compose (list/map (|>> first find-baseline-column) pairs) (list/map (|>> second find-baseline-column) pairs))) )) (type: Doc-Fragment (#Doc-Comment Text) (#Doc-Example Code)) (def: (identify-doc-fragment code) (-> Code Doc-Fragment) (case code [_ (#Text comment)] (#Doc-Comment comment) _ (#Doc-Example code))) (def: (text/encode original) (-> Text Text) (let [escaped (|> original (replace-all "\t" "\\t") (replace-all "\v" "\\v") (replace-all "\b" "\\b") (replace-all "\n" "\\n") (replace-all "\r" "\\r") (replace-all "\f" "\\f") (replace-all "\"" "\\\"") (replace-all "\\" "\\\\") )] ($_ text/compose "\"" escaped "\""))) (do-template [ ] [(def: #export {#.doc } (All [s] (-> (I64 s) (I64 s))) (|>> ( +1)))] [inc "lux i64 +" "Increment function."] [dec "lux i64 -" "Decrement function."] ) (def: tag/encode (-> Ident Text) (|>> ident/encode (text/compose "#"))) (do-template [ ] [(def: #export (-> (I64 Any) ) (|>> (:! )))] [i64 I64] [nat Nat] [int Int] [deg Deg] ) (def: (repeat n x) (All [a] (-> Int a (List a))) (if (i/> 0 n) (#Cons x (repeat (i/+ -1 n) x)) #Nil)) (def: (cursor-padding baseline [_ old-line old-column] [_ new-line new-column]) (-> Nat Cursor Cursor Text) (if (n/= old-line new-line) (text/join (repeat (.int (n/- old-column new-column)) " ")) (let [extra-lines (text/join (repeat (.int (n/- old-line new-line)) "\n")) space-padding (text/join (repeat (.int (n/- baseline new-column)) " "))] (text/compose extra-lines space-padding)))) (def: (text/size x) (-> Text Nat) ("lux text size" x)) (def: (update-cursor [file line column] code-text) (-> Cursor Text Cursor) [file line (n/+ column (text/size code-text))]) (def: (delim-update-cursor [file line column]) (-> Cursor Cursor) [file line (inc column)]) (def: rejoin-all-pairs (-> (List [Code Code]) (List Code)) (|>> (list/map rejoin-pair) list/join)) (def: (doc-example->Text prev-cursor baseline example) (-> Cursor Nat Code [Cursor Text]) (case example (^template [ ] [new-cursor ( value)] (let [as-text ( value)] [(update-cursor new-cursor as-text) (text/compose (cursor-padding baseline prev-cursor new-cursor) as-text)])) ([#Bool bool/encode] [#Nat nat/encode] [#Int int/encode] [#Frac frac/encode] [#Text text/encode] [#Symbol ident/encode] [#Tag tag/encode]) (^template [ ] [group-cursor ( parts)] (let [[group-cursor' parts-text] (list/fold (function (_ part [last-cursor text-accum]) (let [[part-cursor part-text] (doc-example->Text last-cursor baseline part)] [part-cursor (text/compose text-accum part-text)])) [(delim-update-cursor group-cursor) ""] ( parts))] [(delim-update-cursor group-cursor') ($_ text/compose (cursor-padding baseline prev-cursor group-cursor) parts-text )])) ([#Form "(" ")" id] [#Tuple "[" "]" id] [#Record "{" "}" rejoin-all-pairs]) [new-cursor (#Deg value)] ("lux io error" "Undefined behavior.") )) (def: (with-baseline baseline [file line column]) (-> Nat Cursor Cursor) [file line baseline]) (def: (doc-fragment->Text fragment) (-> Doc-Fragment Text) (case fragment (#Doc-Comment comment) (|> comment (text/split "\n") (list/map (function (_ line) ($_ text/compose "## " line "\n"))) text/join) (#Doc-Example example) (let [baseline (find-baseline-column example) [cursor _] example [_ text] (doc-example->Text (with-baseline baseline cursor) baseline example)] (text/compose text "\n\n")))) (macro: #export (doc tokens) {#.doc "## Creates code documentation, embedding text as comments and properly formatting the forms it's being given. ## For Example: (doc \"Allows arbitrary looping, using the \\\"recur\\\" form to re-start the loop. Can be used in monadic code to create monadic loops.\" (loop [count 0 x init] (if (< 10 count) (recur (inc count) (f x)) x)))"} (return (list (` [(~ cursor-code) (#.Text (~ (|> tokens (list/map (|>> identify-doc-fragment doc-fragment->Text)) text/join text$)))])))) (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'))))) (def: (type-to-code type) (-> Type Code) (case type (#Primitive name params) (` (#Primitive (~ (text$ name)) (~ (untemplate-list (list/map type-to-code params))))) (^template [] ( left right) (` ( (~ (type-to-code left)) (~ (type-to-code right))))) ([#Sum] [#Product]) (#Function in out) (` (#Function (~ (type-to-code in)) (~ (type-to-code out)))) (#Bound idx) (` (#Bound (~ (nat$ idx)))) (#Var id) (` (#Var (~ (nat$ id)))) (#Ex id) (` (#Ex (~ (nat$ id)))) (#UnivQ env type) (let [env' (untemplate-list (list/map type-to-code env))] (` (#UnivQ (~ env') (~ (type-to-code type))))) (#ExQ env type) (let [env' (untemplate-list (list/map type-to-code env))] (` (#ExQ (~ env') (~ (type-to-code type))))) (#Apply arg fun) (` (#Apply (~ (type-to-code arg)) (~ (type-to-code fun)))) (#Named [module name] type) (symbol$ [module name]))) (macro: #export (loop tokens) {#.doc (doc "Allows arbitrary looping, using the \"recur\" form to re-start the loop." "Can be used in monadic code to create monadic loops." (loop [count 0 x init] (if (< 10 count) (recur (inc count) (f x)) x)) "Loops can also be given custom names." (loop my-loop [count 0 x init] (if (< 10 count) (my-loop (inc count) (f x)) x)))} (let [?params (case tokens (^ (list name [_ (#Tuple bindings)] body)) (#.Some [name bindings body]) (^ (list [_ (#Tuple bindings)] body)) (#.Some [(symbol$ ["" "recur"]) bindings body]) _ #.None)] (case ?params (#.Some [name bindings body]) (let [pairs (as-pairs bindings) vars (list/map first pairs) inits (list/map second pairs)] (if (every? symbol? inits) (do Monad [inits' (: (Meta (List Ident)) (case (monad/map Monad get-ident inits) (#Some inits') (return inits') #None (fail "Wrong syntax for loop"))) init-types (monad/map Monad find-type inits') expected get-expected-type] (return (list (` (("lux check" (-> (~+ (list/map type-to-code init-types)) (~ (type-to-code expected))) (function ((~ name) (~+ vars)) (~ body))) (~+ inits)))))) (do Monad [aliases (monad/map Monad (: (-> Code (Meta Code)) (function (_ _) (gensym ""))) inits)] (return (list (` (let [(~+ (interleave aliases inits))] (.loop [(~+ (interleave vars aliases))] (~ body))))))))) #.None (fail "Wrong syntax for loop")))) (macro: #export (^slots tokens) {#.doc (doc "Allows you to extract record members as local variables with the same names." "For example:" (let [(^slots [#foo #bar #baz]) quux] (f foo bar baz)))} (case tokens (^ (list& [_ (#Form (list [_ (#Tuple (list& hslot' tslots'))]))] body branches)) (do Monad [slots (: (Meta [Ident (List Ident)]) (case (: (Maybe [Ident (List Ident)]) (do Monad [hslot (get-tag hslot') tslots (monad/map 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 (monad/map Monad normalize tslots) output (resolve-tag hslot) g!_ (gensym "_") #let [[idx tags exported? type] output slot-pairings (list/map (: (-> Ident [Text Code]) (function (_ [module name]) [name (symbol$ ["" name])])) (list& hslot tslots)) pattern (record$ (list/map (: (-> Ident [Code Code]) (function (_ [module name]) (let [tag (tag$ [module name])] (case (get name slot-pairings) (#Some binding) [tag binding] #None [tag g!_])))) tags))]] (return (list& pattern body branches))) _ (fail "Wrong syntax for ^slots"))) (def: (place-tokens label tokens target) (-> Text (List Code) Code (Maybe (List Code))) (case target (^or [_ (#Bool _)] [_ (#Nat _)] [_ (#Int _)] [_ (#Deg _)] [_ (#Frac _)] [_ (#Text _)] [_ (#Tag _)]) (#Some (list target)) [_ (#Symbol [prefix name])] (if (and (text/= "" prefix) (text/= label name)) (#Some tokens) (#Some (list target))) (^template [ ] [_ ( elems)] (do Monad [placements (monad/map Monad (place-tokens label tokens) elems)] (wrap (list ( (list/join placements)))))) ([#Tuple tuple$] [#Form form$]) [_ (#Record pairs)] (do Monad [=pairs (monad/map Monad (: (-> [Code Code] (Maybe [Code Code])) (function (_ [slot value]) (do Monad [slot' (place-tokens label tokens slot) value' (place-tokens label tokens value)] (case [slot' value'] (^ [(list =slot) (list =value)]) (wrap [=slot =value]) _ #None)))) pairs)] (wrap (list (record$ =pairs)))) )) (macro: #export (with-expansions tokens) {#.doc (doc "Controlled macro-expansion." "Bind an arbitraty number of Codes resulting from macro-expansion to local bindings." "Wherever a binding appears, the bound Codes will be spliced in there." (test: "Code operations & structures" (with-expansions [ (do-template [ ] [(compare ) (compare (:: Code/encode show )) (compare true (:: Eq = ))] [(bool true) "true" [_ (#.Bool true)]] [(bool false) "false" [_ (#.Bool false)]] [(int 123) "123" [_ (#.Int 123)]] [(frac 123.0) "123.0" [_ (#.Frac 123.0)]] [(text "\n") "\"\\n\"" [_ (#.Text "\n")]] [(tag ["yolo" "lol"]) "#yolo.lol" [_ (#.Tag ["yolo" "lol"])]] [(symbol ["yolo" "lol"]) "yolo.lol" [_ (#.Symbol ["yolo" "lol"])]] [(form (list (bool true) (int 123))) "(true 123)" (^ [_ (#.Form (list [_ (#.Bool true)] [_ (#.Int 123)]))])] [(tuple (list (bool true) (int 123))) "[true 123]" (^ [_ (#.Tuple (list [_ (#.Bool true)] [_ (#.Int 123)]))])] [(record (list [(bool true) (int 123)])) "{true 123}" (^ [_ (#.Record (list [[_ (#.Bool true)] [_ (#.Int 123)]]))])] [(local-tag "lol") "#lol" [_ (#.Tag ["" "lol"])]] [(local-symbol "lol") "lol" [_ (#.Symbol ["" "lol"])]] )] (test-all ))))} (case tokens (^ (list& [_ (#Tuple bindings)] bodies)) (case bindings (^ (list& [_ (#Symbol ["" var-name])] macro-expr bindings')) (do Monad [expansion (macro-expand-once macro-expr)] (case (place-tokens var-name expansion (` (.with-expansions [(~+ bindings')] (~+ bodies)))) (#Some output) (wrap output) _ (fail "[with-expansions] Improper macro expansion."))) #Nil (return bodies) _ (fail "Wrong syntax for with-expansions")) _ (fail "Wrong syntax for with-expansions"))) (def: (flatten-alias type) (-> Type Type) (case type (^template [] (#Named ["lux" ] _) type) (["Bool"] ["Nat"] ["Int"] ["Deg"] ["Frac"] ["Text"]) (#Named _ type') type' _ type)) (def: (anti-quote-def name) (-> Ident (Meta Code)) (do Monad [type+value (find-def-value name) #let [[type value] type+value]] (case (flatten-alias type) (^template [ ] (#Named ["lux" ] _) (wrap ( (:! value)))) (["Bool" Bool bool$] ["Nat" Nat nat$] ["Int" Int int$] ["Deg" Deg deg$] ["Frac" Frac frac$] ["Text" Text text$]) _ (fail (text/compose "Cannot anti-quote type: " (ident/encode name)))))) (def: (anti-quote token) (-> Code (Meta Code)) (case token [_ (#Symbol [def-prefix def-name])] (if (text/= "" def-prefix) (:: Monad return token) (anti-quote-def [def-prefix def-name])) (^template [] [meta ( parts)] (do Monad [=parts (monad/map Monad anti-quote parts)] (wrap [meta ( =parts)]))) ([#Form] [#Tuple]) [meta (#Record pairs)] (do Monad [=pairs (monad/map Monad (: (-> [Code Code] (Meta [Code Code])) (function (_ [slot value]) (do Monad [=value (anti-quote value)] (wrap [slot =value])))) pairs)] (wrap [meta (#Record =pairs)])) _ (:: Monad return token) )) (macro: #export (^~ tokens) {#.doc (doc "Use global definitions with simple values, such as text, int, frac and bool in place of literals in patterns." "The definitions must be properly-qualified (though you may use one of the short-cuts Lux provides)." (def: (empty?' node) (All [K V] (-> (Node K V) Bool)) (case node (^~ (#Base ..clean-bitmap _)) true _ false)))} (case tokens (^ (list& [_ (#Form (list pattern))] body branches)) (do Monad [module-name current-module-name pattern+ (macro-expand-all pattern)] (case pattern+ (^ (list pattern')) (do Monad [pattern'' (anti-quote pattern')] (wrap (list& pattern'' body branches))) _ (fail "^~ can only expand to 1 pattern."))) _ (fail "Wrong syntax for ^~"))) (type: Multi-Level-Case [Code (List [Code Code])]) (def: (case-level^ level) (-> Code (Meta [Code Code])) (case level (^ [_ (#Tuple (list expr binding))]) (return [expr binding]) _ (return [level (` true)]) )) (def: (multi-level-case^ levels) (-> (List Code) (Meta Multi-Level-Case)) (case levels #Nil (fail "Multi-level patterns cannot be empty.") (#Cons init extras) (do Monad [extras' (monad/map Monad case-level^ extras)] (wrap [init extras'])))) (def: (multi-level-case$ g!_ [[init-pattern levels] body]) (-> Code [Multi-Level-Case Code] (List Code)) (let [inner-pattern-body (list/fold (function (_ [calculation pattern] success) (` (case (~ calculation) (~ pattern) (~ success) (~ g!_) #.None))) (` (#.Some (~ body))) (: (List [Code Code]) (list/reverse levels)))] (list init-pattern inner-pattern-body))) (macro: #export (^multi tokens) {#.doc (doc "Multi-level pattern matching." "Useful in situations where the result of a branch depends on further refinements on the values being matched." "For example:" (case (split (size static) uri) (^multi (#.Some [chunk uri']) [(text/= static chunk) true]) (match-uri endpoint? parts' uri') _ (#.Left (format "Static part " (%t static) " does not match URI: " uri))) "Short-cuts can be taken when using boolean tests." "The example above can be rewritten as..." (case (split (size static) uri) (^multi (#.Some [chunk uri']) (text/= static chunk)) (match-uri endpoint? parts' uri') _ (#.Left (format "Static part " (%t static) " does not match URI: " uri))))} (case tokens (^ (list& [_meta (#Form levels)] body next-branches)) (do Monad [mlc (multi-level-case^ levels) expected get-expected-type g!temp (gensym "temp")] (let [output (list g!temp (` ("lux case" ("lux check" (#.Apply (~ (type-to-code expected)) Maybe) (case (~ g!temp) (~+ (multi-level-case$ g!temp [mlc body])) (~ g!temp) #.None)) {(#Some (~ g!temp)) (~ g!temp) #None (case (~ g!temp) (~+ next-branches))})))] (wrap output))) _ (fail "Wrong syntax for ^multi"))) (macro: #export (ident-for tokens) {#.doc (doc "Given a symbol or a tag, gives back a 2 tuple with the prefix and name parts, both as Text." (ident-for #.doc) "=>" ["lux" "doc"])} (case tokens (^template [] (^ (list [_ ( [prefix name])])) (return (list (` [(~ (text$ prefix)) (~ (text$ name))])))) ([#Symbol] [#Tag]) _ (fail "Wrong syntax for ident-for"))) (do-template [ <%> <=> <0> <2>] [(def: #export ( n) (-> Bool) (<=> <0> (<%> <2> n))) (def: #export ( n) (-> Bool) (not ( n)))] [Nat n/even? n/odd? n/% n/= +0 +2] [Int i/even? i/odd? i/% i/= 0 2]) (def: (get-scope-type-vars state) (Meta (List Nat)) (case state {#info info #source source #current-module _ #modules modules #scopes scopes #type-context types #host host #seed seed #expected expected #cursor cursor #extensions extensions #scope-type-vars scope-type-vars} (#Right state scope-type-vars) )) (def: (list-at idx xs) (All [a] (-> Nat (List a) (Maybe a))) (case xs #Nil #None (#Cons x xs') (if (n/= +0 idx) (#Some x) (list-at (dec idx) xs')))) (macro: #export ($ tokens) {#.doc (doc "Allows you to refer to the type-variables in a polymorphic function's type, by their index." "In the example below, +0 corresponds to the 'a' variable." (def: #export (from-list list) (All [a] (-> (List a) (Sequence a))) (list/fold add (: (Sequence ($ +0)) empty) list)))} (case tokens (^ (list [_ (#Nat idx)])) (do Monad [stvs get-scope-type-vars] (case (list-at idx (list/reverse stvs)) (#Some var-id) (wrap (list (` (#Ex (~ (nat$ var-id)))))) #None (fail (text/compose "Indexed-type does not exist: " (nat/encode idx))))) _ (fail "Wrong syntax for $"))) (def: #export (is? reference sample) {#.doc (doc "Tests whether the 2 values are identical (not just \"equal\")." "This one should succeed:" (let [value 5] (is? value value)) "This one should fail:" (is? 5 (i/+ 2 3)))} (All [a] (-> a a Bool)) ("lux is" reference sample)) (macro: #export (^@ tokens) {#.doc (doc "Allows you to simultaneously bind and de-structure a value." (def: (hash (^@ set [Hash _])) (list/fold (function (_ elem acc) (n/+ (:: Hash hash elem) acc)) +0 (to-list set))))} (case tokens (^ (list& [_meta (#Form (list [_ (#Symbol ["" name])] pattern))] body branches)) (let [g!whole (symbol$ ["" name])] (return (list& g!whole (` (case (~ g!whole) (~ pattern) (~ body))) branches))) _ (fail "Wrong syntax for ^@"))) (macro: #export (^|> tokens) {#.doc (doc "Pipes the value being pattern-matched against prior to binding it to a variable." (case input (^|> value [inc (n/% +10) (n/max +1)]) (foo value)))} (case tokens (^ (list& [_meta (#Form (list [_ (#Symbol ["" name])] [_ (#Tuple steps)]))] body branches)) (let [g!name (symbol$ ["" name])] (return (list& g!name (` (let [(~ g!name) (|> (~ g!name) (~+ steps))] (~ body))) branches))) _ (fail "Wrong syntax for ^|>"))) (macro: #export (:!! tokens) {#.doc (doc "Coerces the given expression to the type of whatever is expected." (: Dinosaur (:!! (list 1 2 3))))} (case tokens (^ (list expr)) (do Monad [type get-expected-type] (wrap (list (` ("lux coerce" (~ (type-to-code type)) (~ expr)))))) _ (fail "Wrong syntax for :!!"))) (macro: #export (undefined tokens) {#.doc (doc "Meant to be used as a stand-in for functions with undefined implementations." "Undefined expressions will type-check against everything, so they make good dummy implementations." "However, if an undefined expression is ever evaluated, it will raise a runtime error." (def: (square x) (-> Int Int) (undefined)))} (case tokens #Nil (return (list (` (error! "Undefined behavior.")))) _ (fail "Wrong syntax for undefined"))) (macro: #export (type-of tokens) {#.doc (doc "Generates the type corresponding to a given definition or variable." (let [my-num (: Int 123)] (type-of my-num)) "==" Int)} (case tokens (^ (list [_ (#Symbol var-name)])) (do Monad [var-type (find-type var-name)] (wrap (list (type-to-code var-type)))) _ (fail "Wrong syntax for type-of"))) (def: (parse-complex-declaration tokens) (-> (List Code) (Meta [[Text (List Text)] (List Code)])) (case tokens (^ (list& [_ (#Form (list& [_ (#Symbol ["" name])] args'))] tokens')) (do Monad [args (monad/map Monad (function (_ arg') (case arg' [_ (#Symbol ["" arg-name])] (wrap arg-name) _ (fail "Could not parse an argument."))) args')] (wrap [[name args] tokens'])) _ (fail "Could not parse a complex declaration.") )) (def: (parse-any tokens) (-> (List Code) (Meta [Code (List Code)])) (case tokens (^ (list& token tokens')) (return [token tokens']) _ (fail "Could not parse anything.") )) (def: (parse-many tokens) (-> (List Code) (Meta [(List Code) (List Code)])) (case tokens (^ (list& head tail)) (return [tokens (list)]) _ (fail "Could not parse anything.") )) (def: (parse-end tokens) (-> (List Code) (Meta Any)) (case tokens (^ (list)) (return []) _ (fail "Expected input Codes to be empty.") )) (def: (parse-anns tokens) (-> (List Code) (Meta [Code (List Code)])) (case tokens (^ (list& [_ (#Record _anns)] tokens')) (return [(record$ _anns) tokens']) _ (return [(' {}) tokens]) )) (macro: #export (template: tokens) {#.doc (doc "Define macros in the style of do-template and ^template." "For simple macros that do not need any fancy features." (template: (square x) (i/* x x)))} (do Monad [#let [[export? tokens] (export^ tokens)] name+args|tokens (parse-complex-declaration tokens) #let [[[name args] tokens] name+args|tokens] anns|tokens (parse-anns tokens) #let [[anns tokens] anns|tokens] input-templates|tokens (parse-many tokens) #let [[input-templates tokens] input-templates|tokens] _ (parse-end tokens) g!tokens (gensym "tokens") g!compiler (gensym "compiler") g!_ (gensym "_") #let [rep-env (list/map (function (_ arg) [arg (` ((~' ~) (~ (symbol$ ["" arg]))))]) args)]] (wrap (list (` (macro: (~+ (export export?)) ((~ (symbol$ ["" name])) (~ g!tokens) (~ g!compiler)) (~ anns) (case (~ g!tokens) (^ (list (~+ (list/map (|>> [""] symbol$) args)))) (#.Right [(~ g!compiler) (list (~+ (list/map (function (_ template) (` (` (~ (replace-syntax rep-env template))))) input-templates)))]) (~ g!_) (#.Left (~ (text$ (text/compose "Wrong syntax for " name)))) ))))) )) (macro: #export (as-is tokens compiler) (#Right [compiler tokens])) (macro: #export (char tokens compiler) (case tokens (^multi (^ (list [_ (#Text input)])) (n/= +1 ("lux text size" input))) (|> ("lux text char" input +0) (default (undefined)) nat$ list [compiler] #Right) _ (#Left "Wrong syntax for char"))) (def: #export (when test f) (All [a] (-> Bool (-> a a) (-> a a))) (function (_ value) (if test (f value) value))) (type: #export (Array a) {#.doc "Mutable arrays."} (#.Primitive "#Array" (#.Cons a #.Nil))) (def: target (Meta Text) (function (_ compiler) (#Right [compiler (get@ [#info #target] compiler)]))) (def: (pick-for-target target options) (-> Text (List [Code Code]) (Maybe Code)) (case options #Nil #None (#Cons [key value] options') (case key (^multi [_ (#Text platform)] (text/= target platform)) (#Some value) _ (pick-for-target target options')) )) (macro: #export (for tokens) (do Monad [target target] (case tokens (^ (list [_ (#Record options)])) (case (pick-for-target target options) (#Some pick) (wrap (list pick)) #None (fail ($_ text/compose "No code for target platform: " target))) (^ (list [_ (#Record options)] default)) (wrap (list (..default default (pick-for-target target options)))) _ (fail "Wrong syntax for 'for'")))) (do-template [ ] [(def: ( xy) (All [a b] (-> [a b] )) (let [[x y] xy] ))] [left a x] [right b y]) (def: (label-code code) (-> Code (Meta [(List [Code Code]) Code])) (case code (^ [ann (#Form (list [_ (#Symbol ["" "~~"])] expansion))]) (do Monad [g!expansion (gensym "g!expansion")] (wrap [(list [g!expansion expansion]) g!expansion])) (^template [] [ann ( parts)] (do Monad [=parts (monad/map Monad label-code parts)] (wrap [(list/fold list/compose (list) (list/map left =parts)) [ann ( (list/map right =parts))]]))) ([#Form] [#Tuple]) [ann (#Record kvs)] (do Monad [=kvs (monad/map Monad (function (_ [key val]) (do Monad [=key (label-code key) =val (label-code val) #let [[key-labels key-labelled] =key [val-labels val-labelled] =val]] (wrap [(list/compose key-labels val-labels) [key-labelled val-labelled]]))) kvs)] (wrap [(list/fold list/compose (list) (list/map left =kvs)) [ann (#Record (list/map right =kvs))]])) _ (return [(list) code]))) (macro: #export (`` tokens) (case tokens (^ (list raw)) (do Monad [=raw (label-code raw) #let [[labels labelled] =raw]] (wrap (list (` (with-expansions [(~+ (|> labels (list/map (function (_ [label expansion]) (list label expansion))) list/join))] (~ labelled)))))) _ (fail "Wrong syntax for ``") )) (def: (ident$ [module name]) (-> Ident Code) (` [(~ (text$ module)) (~ (text$ name))])) (def: (untemplate-list& last inits) (-> Code (List Code) Code) (case inits #Nil last (#Cons [init inits']) (` (#.Cons (~ init) (~ (untemplate-list& last inits')))))) (def: (untemplate-pattern pattern) (-> Code (Meta Code)) (case pattern (^template [ ] [_ ( value)] (do Monad [g!meta (gensym "g!meta")] (wrap (` [(~ g!meta) ( (~ ( value)))])))) ([#Bool "Bool" bool$] [#Nat "Nat" nat$] [#Int "Int" int$] [#Deg "Deg" deg$] [#Frac "Frac" frac$] [#Text "Text" text$] [#Tag "Tag" ident$] [#Symbol "Symbol" ident$]) [_ (#Record fields)] (do Monad [=fields (monad/map Monad (function (_ [key value]) (do Monad [=key (untemplate-pattern key) =value (untemplate-pattern value)] (wrap (` [(~ =key) (~ =value)])))) fields) g!meta (gensym "g!meta")] (wrap (` [(~ g!meta) (#.Record (~ (untemplate-list =fields)))]))) [_ (#Form (#Cons [[_ (#Symbol ["" "~"])] (#Cons [unquoted #Nil])]))] (return unquoted) [_ (#Form (#Cons [[_ (#Symbol ["" "~+"])] (#Cons [spliced #Nil])]))] (fail "Cannot use (~+) inside of ^code unless it is the last element in a form or a tuple.") (^template [] [_ ( elems)] (case (list/reverse elems) (#Cons [_ (#Form (#Cons [[_ (#Symbol ["" "~+"])] (#Cons [spliced #Nil])]))] inits) (do Monad [=inits (monad/map Monad untemplate-pattern (list/reverse inits)) g!meta (gensym "g!meta")] (wrap (` [(~ g!meta) ( (~ (untemplate-list& spliced =inits)))]))) _ (do Monad [=elems (monad/map Monad untemplate-pattern elems) g!meta (gensym "g!meta")] (wrap (` [(~ g!meta) ( (~ (untemplate-list =elems)))]))))) ([#Tuple] [#Form]) )) (macro: #export (^code tokens) (case tokens (^ (list& [_meta (#Form (list template))] body branches)) (do Monad [pattern (untemplate-pattern template)] (wrap (list& pattern body branches))) (^ (list template)) (do Monad [pattern (untemplate-pattern template)] (wrap (list pattern))) _ (fail "Wrong syntax for ^code"))) (def: #export (n/mod param subject) (-> Nat Nat Nat) (let [exact (|> subject (n// param) (n/* param))] (|> subject (n/- exact)))) (def: #export (i/mod param subject) (All [m] (-> Int Int Int)) (let [raw (i/% param subject)] (if (i/< 0 raw) (let [shift (if (i/< 0 param) i/- i/+)] (|> raw (shift param))) raw))) (do-template [ <%>] [(def: #export ( param subject) (-> [ ]) [( param subject) (<%> param subject)])] [Int i//% i// i/%] [Deg d//% d// d/%] [Frac f//% f// f/%] ) (def: to-significand (-> (I64 Any) Frac) (|>> ("lux i64 logical-right-shift" +11) int-to-frac)) (def: deg-denominator Frac (to-significand -1)) (def: #export (frac-to-deg input) (-> Frac Deg) (let [abs (if (f/< 0.0 input) (f/* -1.0 input) input)] (|> abs (f/% 1.0) (f/* deg-denominator) frac-to-int ("lux i64 left-shift" +11)))) (def: #export deg-to-frac (-> Deg Frac) (|>> to-significand (f// deg-denominator))) (macro: #export (alias: tokens) (case tokens (^ (list [_meta (#Symbol ["" alias])] [_meta (#Symbol aliased)])) (let [alias (symbol$ ["" alias]) aliased (symbol$ aliased)] (return (list (` (def: #export (~ alias) {#.doc (doc "Alias for:" (~ aliased))} (~ aliased)))))) _ (fail "Wrong syntax for alias:")))