("lux def" dummy-cursor ["" 0 0] [["" 0 0] (9 #1 (0 #0))] #1) ("lux def" double-quote ("lux i64 char" +34) [dummy-cursor (9 #1 (0 #0))] #0) ("lux def" new-line ("lux i64 char" +10) [dummy-cursor (9 #1 (0 #0))] #0) ("lux def" __paragraph ("lux text concat" new-line new-line) [dummy-cursor (9 #1 (0 #0))] #0) ## (type: Any ## (Ex [a] a)) ("lux def" Any ("lux check type" (9 #1 ["lux" "Any"] (8 #0 (0 #0) (4 #0 1)))) [dummy-cursor (9 #1 (0 #1 [[dummy-cursor (7 #0 ["lux" "doc"])] [dummy-cursor (5 #0 ("lux text concat" ("lux text concat" "The type of things whose type is irrelevant." __paragraph) "It can be used to write functions or data-structures that can take, or return, anything."))]] (0 #0)))] #1) ## (type: Nothing ## (All [a] a)) ("lux def" Nothing ("lux check type" (9 #1 ["lux" "Nothing"] (7 #0 (0 #0) (4 #0 1)))) [dummy-cursor (9 #1 (0 #1 [[dummy-cursor (7 #0 ["lux" "doc"])] [dummy-cursor (5 #0 ("lux text concat" ("lux text concat" "The type of things whose type is undefined." __paragraph) "Useful for expressions that cause errors or other 'extraordinary' conditions."))]] (0 #0)))] #1) ## (type: (List a) ## #Nil ## (#Cons a (List a))) ("lux def type tagged" List (9 #1 ["lux" "List"] (7 #0 (0 #0) (1 #0 ## "lux.Nil" Any ## "lux.Cons" (2 #0 (4 #0 1) (9 #0 (4 #0 1) (4 #0 0)))))) [dummy-cursor (9 #1 (0 #1 [[dummy-cursor (7 #0 ["lux" "type-args"])] [dummy-cursor (9 #0 (0 #1 [dummy-cursor (5 #0 "a")] (0 #0)))]] (0 #1 [[dummy-cursor (7 #0 ["lux" "doc"])] [dummy-cursor (5 #0 "A potentially empty list of values.")]] (0 #0))))] ["Nil" "Cons"] #1) ("lux def" Bit ("lux check type" (9 #1 ["lux" "Bit"] (0 #0 "#Bit" #Nil))) [dummy-cursor (9 #1 (#Cons [[dummy-cursor (7 #0 ["lux" "doc"])] [dummy-cursor (5 #0 "Your standard, run-of-the-mill boolean values (as bits).")]] #Nil))] #1) ("lux def" I64 ("lux check type" (9 #1 ["lux" "I64"] (7 #0 (0 #0) (0 #0 "#I64" (#Cons (4 #0 1) #Nil))))) [dummy-cursor (9 #1 (#Cons [[dummy-cursor (7 #0 ["lux" "doc"])] [dummy-cursor (5 #0 "64-bit integers without any semantics.")]] #Nil))] #1) ("lux def" Nat ("lux check type" (9 #1 ["lux" "Nat"] (0 #0 "#I64" (#Cons (0 #0 "#Nat" #Nil) #Nil)))) [dummy-cursor (9 #1 (#Cons [[dummy-cursor (7 #0 ["lux" "doc"])] [dummy-cursor (5 #0 ("lux text concat" ("lux text concat" "Natural numbers (unsigned integers)." __paragraph) "They start at zero (0) and extend in the positive direction."))]] #Nil))] #1) ("lux def" Int ("lux check type" (9 #1 ["lux" "Int"] (0 #0 "#I64" (#Cons (0 #0 "#Int" #Nil) #Nil)))) [dummy-cursor (9 #1 (#Cons [[dummy-cursor (7 #0 ["lux" "doc"])] [dummy-cursor (5 #0 "Your standard, run-of-the-mill integer numbers.")]] #Nil))] #1) ("lux def" Rev ("lux check type" (9 #1 ["lux" "Rev"] (0 #0 "#I64" (#Cons (0 #0 "#Rev" #Nil) #Nil)))) [dummy-cursor (9 #1 (#Cons [[dummy-cursor (7 #0 ["lux" "doc"])] [dummy-cursor (5 #0 ("lux text concat" ("lux text concat" "Fractional numbers that live in the interval [0,1)." __paragraph) "Useful for probability, and other domains that work within that interval."))]] #Nil))] #1) ("lux def" Frac ("lux check type" (9 #1 ["lux" "Frac"] (0 #0 "#Frac" #Nil))) [dummy-cursor (9 #1 (#Cons [[dummy-cursor (7 #0 ["lux" "doc"])] [dummy-cursor (5 #0 "Your standard, run-of-the-mill floating-point (fractional) numbers.")]] #Nil))] #1) ("lux def" Text ("lux check type" (9 #1 ["lux" "Text"] (0 #0 "#Text" #Nil))) [dummy-cursor (9 #1 (#Cons [[dummy-cursor (7 #0 ["lux" "doc"])] [dummy-cursor (5 #0 "Your standard, run-of-the-mill string values.")]] #Nil))] #1) ("lux def" Name ("lux check type" (9 #1 ["lux" "Name"] (2 #0 Text Text))) [dummy-cursor (9 #1 (#Cons [[dummy-cursor (7 #0 ["lux" "doc"])] [dummy-cursor (5 #0 "A name. It is used as part of Lux syntax to represent identifiers and tags.")]] #Nil))] #1) ## (type: (Maybe a) ## #None ## (#Some a)) ("lux def type tagged" Maybe (9 #1 ["lux" "Maybe"] (7 #0 #Nil (1 #0 ## "lux.None" Any ## "lux.Some" (4 #0 1)))) [dummy-cursor (9 #1 (#Cons [[dummy-cursor (7 #0 ["lux" "type-args"])] [dummy-cursor (9 #0 (#Cons [dummy-cursor (5 #0 "a")] #Nil))]] (#Cons [[dummy-cursor (7 #0 ["lux" "doc"])] [dummy-cursor (5 #0 "A potentially missing value.")]] #Nil)))] ["None" "Some"] #1) ## (type: #rec Type ## (#Primitive Text (List Type)) ## (#Sum Type Type) ## (#Product Type Type) ## (#Function Type Type) ## (#Parameter Nat) ## (#Var Nat) ## (#Ex Nat) ## (#UnivQ (List Type) Type) ## (#ExQ (List Type) Type) ## (#Apply Type Type) ## (#Named Name Type) ## ) ("lux def type tagged" Type (9 #1 ["lux" "Type"] ({Type ({Type-List ({Type-Pair (9 #0 Nothing (7 #0 #Nil (1 #0 ## "lux.Primitive" (2 #0 Text Type-List) (1 #0 ## "lux.Sum" Type-Pair (1 #0 ## "lux.Product" Type-Pair (1 #0 ## "lux.Function" Type-Pair (1 #0 ## "lux.Parameter" Nat (1 #0 ## "lux.Var" Nat (1 #0 ## "lux.Ex" Nat (1 #0 ## "lux.UnivQ" (2 #0 Type-List Type) (1 #0 ## "lux.ExQ" (2 #0 Type-List Type) (1 #0 ## "lux.Apply" Type-Pair ## "lux.Named" (2 #0 Name Type)))))))))))))} ("lux check type" (2 #0 Type Type)))} ("lux check type" (9 #0 Type List)))} ("lux check type" (9 #0 (4 #0 1) (4 #0 0))))) [dummy-cursor (9 #1 (#Cons [[dummy-cursor (7 #0 ["lux" "doc"])] [dummy-cursor (5 #0 "This type represents the data-structures that are used to specify types themselves.")]] (#Cons [[dummy-cursor (7 #0 ["lux" "type-rec?"])] [dummy-cursor (0 #0 #1)]] #Nil)))] ["Primitive" "Sum" "Product" "Function" "Parameter" "Var" "Ex" "UnivQ" "ExQ" "Apply" "Named"] #1) ## (type: Cursor ## {#module Text ## #line Nat ## #column Nat}) ("lux def type tagged" Cursor (#Named ["lux" "Cursor"] (#Product Text (#Product Nat Nat))) [dummy-cursor (9 #1 (#Cons [[dummy-cursor (7 #0 ["lux" "doc"])] [dummy-cursor (5 #0 "Cursors are for specifying the location of Code nodes in Lux files during compilation.")]] #Nil))] ["module" "line" "column"] #1) ## (type: (Ann m v) ## {#meta m ## #datum v}) ("lux def type tagged" Ann (#Named ["lux" "Ann"] (#UnivQ #Nil (#UnivQ #Nil (#Product (#Parameter 3) (#Parameter 1))))) [dummy-cursor (9 #1 (#Cons [[dummy-cursor (7 #0 ["lux" "doc"])] [dummy-cursor (5 #0 "The type of things that can be annotated with meta-data of arbitrary types.")]] (#Cons [[dummy-cursor (7 #0 ["lux" "type-args"])] [dummy-cursor (9 #0 (#Cons [dummy-cursor (5 #0 "m")] (#Cons [dummy-cursor (5 #0 "v")] #Nil)))]] #Nil)))] ["meta" "datum"] #1) ## (type: (Code' w) ## (#Bit Bit) ## (#Nat Nat) ## (#Int Int) ## (#Rev Rev) ## (#Frac Frac) ## (#Text Text) ## (#Identifier Name) ## (#Tag Name) ## (#Form (List (w (Code' w)))) ## (#Tuple (List (w (Code' w)))) ## (#Record (List [(w (Code' w)) (w (Code' w))]))) ("lux def type tagged" Code' (#Named ["lux" "Code'"] ({Code ({Code-List (#UnivQ #Nil (#Sum ## "lux.Bit" Bit (#Sum ## "lux.Nat" Nat (#Sum ## "lux.Int" Int (#Sum ## "lux.Rev" Rev (#Sum ## "lux.Frac" Frac (#Sum ## "lux.Text" Text (#Sum ## "lux.Identifier" Name (#Sum ## "lux.Tag" Name (#Sum ## "lux.Form" Code-List (#Sum ## "lux.Tuple" Code-List ## "lux.Record" (#Apply (#Product Code Code) List) )))))))))) )} ("lux check type" (#Apply Code List)))} ("lux check type" (#Apply (#Apply (#Parameter 1) (#Parameter 0)) (#Parameter 1))))) [dummy-cursor (9 #1 (#Cons [[dummy-cursor (7 #0 ["lux" "type-args"])] [dummy-cursor (9 #0 (#Cons [dummy-cursor (5 #0 "w")] #Nil))]] #Nil))] ["Bit" "Nat" "Int" "Rev" "Frac" "Text" "Identifier" "Tag" "Form" "Tuple" "Record"] #1) ## (type: Code ## (Ann Cursor (Code' (Ann Cursor)))) ("lux def" Code (#Named ["lux" "Code"] ({w (#Apply (#Apply w Code') w)} ("lux check type" (#Apply Cursor Ann)))) [dummy-cursor (#Record (#Cons [[dummy-cursor (#Tag ["lux" "doc"])] [dummy-cursor (#Text "The type of Code nodes for Lux syntax.")]] #Nil))] #1) ("lux def" _ann ("lux check" (#Function (#Apply (#Apply Cursor Ann) Code') Code) ([_ data] [dummy-cursor data])) [dummy-cursor (#Record #Nil)] #0) ("lux def" bit$ ("lux check" (#Function Bit Code) ([_ value] (_ann (#Bit value)))) [dummy-cursor (#Record #Nil)] #0) ("lux def" nat$ ("lux check" (#Function Nat Code) ([_ value] (_ann (#Nat value)))) [dummy-cursor (#Record #Nil)] #0) ("lux def" int$ ("lux check" (#Function Int Code) ([_ value] (_ann (#Int value)))) [dummy-cursor (#Record #Nil)] #0) ("lux def" rev$ ("lux check" (#Function Rev Code) ([_ value] (_ann (#Rev value)))) [dummy-cursor (#Record #Nil)] #0) ("lux def" frac$ ("lux check" (#Function Frac Code) ([_ value] (_ann (#Frac value)))) [dummy-cursor (#Record #Nil)] #0) ("lux def" text$ ("lux check" (#Function Text Code) ([_ text] (_ann (#Text text)))) [dummy-cursor (#Record #Nil)] #0) ("lux def" identifier$ ("lux check" (#Function Name Code) ([_ name] (_ann (#Identifier name)))) [dummy-cursor (#Record #Nil)] #0) ("lux def" local-identifier$ ("lux check" (#Function Text Code) ([_ name] (_ann (#Identifier ["" name])))) [dummy-cursor (#Record #Nil)] #0) ("lux def" tag$ ("lux check" (#Function Name Code) ([_ name] (_ann (#Tag name)))) [dummy-cursor (#Record #Nil)] #0) ("lux def" local-tag$ ("lux check" (#Function Text Code) ([_ name] (_ann (#Tag ["" name])))) [dummy-cursor (#Record #Nil)] #0) ("lux def" form$ ("lux check" (#Function (#Apply Code List) Code) ([_ tokens] (_ann (#Form tokens)))) [dummy-cursor (#Record #Nil)] #0) ("lux def" tuple$ ("lux check" (#Function (#Apply Code List) Code) ([_ tokens] (_ann (#Tuple tokens)))) [dummy-cursor (#Record #Nil)] #0) ("lux def" record$ ("lux check" (#Function (#Apply (#Product Code Code) List) Code) ([_ tokens] (_ann (#Record tokens)))) [dummy-cursor (#Record #Nil)] #0) ## (type: Definition ## [Bit Type Code Any]) ("lux def" Definition ("lux check type" (#Named ["lux" "Definition"] (#Product Bit (#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.")] #Nil)) #1) ## (type: Alias ## [Text Text]) ("lux def" Alias ("lux check type" (#Named ["lux" "Alias"] (#Product Text Text))) (record$ #Nil) #1) ## (type: Global ## (#Alias Alias) ## (#Definition Definition)) ("lux def type tagged" Global (#Named ["lux" "Global"] (#Sum Alias Definition)) (record$ (#Cons [(tag$ ["lux" "doc"]) (text$ "Represents all the data associated with a global constant.")] #Nil)) ["Alias" "Definition"] #1) ## (type: (Bindings k v) ## {#counter Nat ## #mappings (List [k v])}) ("lux def type tagged" Bindings (#Named ["lux" "Bindings"] (#UnivQ #Nil (#UnivQ #Nil (#Product ## "lux.counter" Nat ## "lux.mappings" (#Apply (#Product (#Parameter 3) (#Parameter 1)) List))))) (record$ (#Cons [(tag$ ["lux" "type-args"]) (tuple$ (#Cons (text$ "k") (#Cons (text$ "v") #Nil)))] #Nil)) ["counter" "mappings"] #1) ## (type: #export Ref ## (#Local Nat) ## (#Captured Nat)) ("lux def type tagged" Ref (#Named ["lux" "Ref"] (#Sum ## Local Nat ## Captured Nat)) (record$ #Nil) ["Local" "Captured"] #1) ## (type: Scope ## {#name (List Text) ## #inner Nat ## #locals (Bindings Text [Type Nat]) ## #captured (Bindings Text [Type Ref])}) ("lux def type tagged" 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$ #Nil) ["name" "inner" "locals" "captured"] #1) ("lux def" Code-List ("lux check type" (#Apply Code List)) (record$ #Nil) #0) ## (type: (Either l r) ## (#Left l) ## (#Right r)) ("lux def type tagged" Either (#Named ["lux" "Either"] (#UnivQ #Nil (#UnivQ #Nil (#Sum ## "lux.Left" (#Parameter 3) ## "lux.Right" (#Parameter 1))))) (record$ (#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.")] #Nil))) ["Left" "Right"] #1) ## (type: Source ## [Cursor Nat Text]) ("lux def" Source ("lux check type" (#Named ["lux" "Source"] (#Product Cursor (#Product Nat Text)))) (record$ #Nil) #1) ## (type: Module-State ## #Active ## #Compiled ## #Cached) ("lux def type tagged" Module-State (#Named ["lux" "Module-State"] (#Sum ## #Active Any (#Sum ## #Compiled Any ## #Cached Any))) (record$ #Nil) ["Active" "Compiled" "Cached"] #1) ## (type: Module ## {#module-hash Nat ## #module-aliases (List [Text Text]) ## #definitions (List [Text Global]) ## #imports (List Text) ## #tags (List [Text [Nat (List Name) Bit Type]]) ## #types (List [Text [(List Name) Bit Type]]) ## #module-annotations (Maybe Code) ## #module-state Module-State}) ("lux def type tagged" Module (#Named ["lux" "Module"] (#Product ## "lux.module-hash" Nat (#Product ## "lux.module-aliases" (#Apply (#Product Text Text) List) (#Product ## "lux.definitions" (#Apply (#Product Text Global) List) (#Product ## "lux.imports" (#Apply Text List) (#Product ## "lux.tags" (#Apply (#Product Text (#Product Nat (#Product (#Apply Name List) (#Product Bit Type)))) List) (#Product ## "lux.types" (#Apply (#Product Text (#Product (#Apply Name List) (#Product Bit Type))) List) (#Product ## "lux.module-annotations" (#Apply Code Maybe) Module-State)) )))))) (record$ (#Cons [(tag$ ["lux" "doc"]) (text$ "All the information contained within a Lux module.")] #Nil)) ["module-hash" "module-aliases" "definitions" "imports" "tags" "types" "module-annotations" "module-state"] #1) ## (type: Type-Context ## {#ex-counter Nat ## #var-counter Nat ## #var-bindings (List [Nat (Maybe Type)])}) ("lux def type tagged" Type-Context (#Named ["lux" "Type-Context"] (#Product ## ex-counter Nat (#Product ## var-counter Nat ## var-bindings (#Apply (#Product Nat (#Apply Type Maybe)) List)))) (record$ #Nil) ["ex-counter" "var-counter" "var-bindings"] #1) ## (type: Mode ## #Build ## #Eval ## #Interpreter) ("lux def type tagged" Mode (#Named ["lux" "Mode"] (#Sum ## Build Any (#Sum ## Eval Any ## Interpreter Any))) (record$ (#Cons [(tag$ ["lux" "doc"]) (text$ "A sign that shows the conditions under which the compiler is running.")] #Nil)) ["Build" "Eval" "Interpreter"] #1) ## (type: Info ## {#target Text ## #version Text ## #mode Mode}) ("lux def type tagged" Info (#Named ["lux" "Info"] (#Product ## target Text (#Product ## version Text ## mode Mode))) (record$ (#Cons [(tag$ ["lux" "doc"]) (text$ "Information about the current version and type of compiler that is running.")] #Nil)) ["target" "version" "mode"] #1) ## (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 Any ## #host Any}) ("lux def type tagged" 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 Any ## "lux.host" Any)))))))))))) (record$ (#Cons [(tag$ ["lux" "doc"]) (text$ ("lux text concat" ("lux text concat" "Represents the state of the Lux compiler during a run." __paragraph) ("lux text concat" ("lux text concat" "It is provided to macros during their invocation, so they can access compiler data." __paragraph) "Caveat emptor: Avoid fiddling with it, unless you know what you're doing.")))] #Nil)) ["info" "source" "cursor" "current-module" "modules" "scopes" "type-context" "expected" "seed" "scope-type-vars" "extensions" "host"] #1) ## (type: (Meta a) ## (-> Lux (Either Text [Lux a]))) ("lux def" Meta ("lux check type" (#Named ["lux" "Meta"] (#UnivQ #Nil (#Function Lux (#Apply (#Product Lux (#Parameter 1)) (#Apply Text Either)))))) (record$ (#Cons [(tag$ ["lux" "doc"]) (text$ ("lux text concat" ("lux text concat" "Computations that can have access to the state of the compiler." __paragraph) "These computations may fail, or modify the state of the compiler."))] (#Cons [(tag$ ["lux" "type-args"]) (tuple$ (#Cons (text$ "a") #Nil))] #Nil))) #1) ## (type: Macro' ## (-> (List Code) (Meta (List Code)))) ("lux def" Macro' ("lux check type" (#Named ["lux" "Macro'"] (#Function Code-List (#Apply Code-List Meta)))) (record$ #Nil) #1) ## (type: Macro ## (primitive "#Macro")) ("lux def" Macro ("lux check type" (#Named ["lux" "Macro"] (#Primitive "#Macro" #Nil))) (record$ (#Cons [(tag$ ["lux" "doc"]) (text$ "Functions that run at compile-time and allow you to transform and extend the language in powerful ways.")] #Nil)) #1) ## Base functions & macros ("lux def" return ("lux check" (#UnivQ #Nil (#Function (#Parameter 1) (#Function Lux (#Apply (#Product Lux (#Parameter 1)) (#Apply Text Either))))) ([_ val] ([_ state] (#Right state val)))) (record$ #Nil) #0) ("lux def" fail ("lux check" (#UnivQ #Nil (#Function Text (#Function Lux (#Apply (#Product Lux (#Parameter 1)) (#Apply Text Either))))) ([_ msg] ([_ state] (#Left msg)))) (record$ #Nil) #0) ("lux def" let'' ("lux macro" ([_ tokens] ({(#Cons lhs (#Cons rhs (#Cons body #Nil))) (return (#Cons (form$ (#Cons (record$ (#Cons [lhs body] #Nil)) (#Cons rhs #Nil))) #Nil)) _ (fail "Wrong syntax for let''")} tokens))) (record$ #.Nil) #0) ("lux def" function'' ("lux macro" ([_ tokens] ({(#Cons [_ (#Tuple (#Cons arg args'))] (#Cons body #Nil)) (return (#Cons (_ann (#Form (#Cons (_ann (#Tuple (#Cons (_ann (#Identifier ["" ""])) (#Cons arg #Nil)))) (#Cons ({#Nil body _ (_ann (#Form (#Cons (_ann (#Identifier ["lux" "function''"])) (#Cons (_ann (#Tuple args')) (#Cons body #Nil)))))} args') #Nil)))) #Nil)) (#Cons [_ (#Identifier ["" self])] (#Cons [_ (#Tuple (#Cons arg args'))] (#Cons body #Nil))) (return (#Cons (_ann (#Form (#Cons (_ann (#Tuple (#Cons (_ann (#Identifier ["" self])) (#Cons arg #Nil)))) (#Cons ({#Nil body _ (_ann (#Form (#Cons (_ann (#Identifier ["lux" "function''"])) (#Cons (_ann (#Tuple args')) (#Cons body #Nil)))))} args') #Nil)))) #Nil)) _ (fail "Wrong syntax for function''")} tokens))) (record$ #.Nil) #0) ("lux def" cursor-code ("lux check" Code (tuple$ (#Cons (text$ "") (#Cons (nat$ 0) (#Cons (nat$ 0) #Nil))))) (record$ #Nil) #0) ("lux def" meta-code ("lux check" (#Function Name (#Function Code Code)) ([_ tag] ([_ value] (tuple$ (#Cons cursor-code (#Cons (form$ (#Cons (tag$ tag) (#Cons value #Nil))) #Nil)))))) (record$ #Nil) #0) ("lux def" flag-meta ("lux check" (#Function Text Code) ([_ tag] (tuple$ (#Cons [(meta-code ["lux" "Tag"] (tuple$ (#Cons (text$ "lux") (#Cons (text$ tag) #Nil)))) (#Cons [(meta-code ["lux" "Bit"] (bit$ #1)) #Nil])])))) (record$ #Nil) #0) ("lux def" doc-meta ("lux check" (#Function Text (#Product Code Code)) (function'' [doc] [(tag$ ["lux" "doc"]) (text$ doc)])) (record$ #Nil) #0) ("lux def" as-def ("lux check" (#Function Code (#Function Code (#Function Code (#Function Bit Code)))) (function'' [name value annotations exported?] (form$ (#Cons (text$ "lux def") (#Cons name (#Cons value (#Cons annotations (#Cons (bit$ exported?) #Nil)))))))) (record$ #Nil) #0) ("lux def" as-checked ("lux check" (#Function Code (#Function Code Code)) (function'' [type value] (form$ (#Cons (text$ "lux check") (#Cons type (#Cons value #Nil)))))) (record$ #Nil) #0) ("lux def" as-function ("lux check" (#Function Code (#Function (#Apply Code List) (#Function Code Code))) (function'' [self inputs output] (form$ (#Cons (identifier$ ["lux" "function''"]) (#Cons self (#Cons (tuple$ inputs) (#Cons output #Nil))))))) (record$ #Nil) #0) ("lux def" as-macro ("lux check" (#Function Code Code) (function'' [expression] (form$ (#Cons (text$ "lux macro") (#Cons expression #Nil))))) (record$ #Nil) #0) ("lux def" def:'' ("lux macro" (function'' [tokens] ({(#Cons [[_ (#Tag ["" "export"])] (#Cons [[_ (#Form (#Cons [name args]))] (#Cons [meta (#Cons [type (#Cons [body #Nil])])])])]) (return (#Cons [(as-def name (as-checked type (as-function name args body)) (form$ (#Cons (identifier$ ["lux" "record$"]) (#Cons meta #Nil))) #1) #Nil])) (#Cons [[_ (#Tag ["" "export"])] (#Cons [name (#Cons [meta (#Cons [type (#Cons [body #Nil])])])])]) (return (#Cons [(as-def name (as-checked type body) (form$ (#Cons (identifier$ ["lux" "record$"]) (#Cons meta #Nil))) #1) #Nil])) (#Cons [[_ (#Form (#Cons [name args]))] (#Cons [meta (#Cons [type (#Cons [body #Nil])])])]) (return (#Cons [(as-def name (as-checked type (as-function name args body)) (form$ (#Cons (identifier$ ["lux" "record$"]) (#Cons meta #Nil))) #0) #Nil])) (#Cons [name (#Cons [meta (#Cons [type (#Cons [body #Nil])])])]) (return (#Cons [(as-def name (as-checked type body) (form$ (#Cons (identifier$ ["lux" "record$"]) (#Cons meta #Nil))) #0) #Nil])) _ (fail "Wrong syntax for def''")} tokens))) (record$ #.Nil) #0) ("lux def" macro:' ("lux macro" (function'' [tokens] ({(#Cons [_ (#Form (#Cons name args))] (#Cons body #Nil)) (return (#Cons (as-def name (as-macro (as-function name args body)) (form$ (#Cons (identifier$ ["lux" "record$"]) (#Cons (tag$ ["lux" "Nil"]) #Nil))) #0) #Nil)) (#Cons [_ (#Tag ["" "export"])] (#Cons [_ (#Form (#Cons name args))] (#Cons body #Nil))) (return (#Cons (as-def name (as-macro (as-function name args body)) (form$ (#Cons (identifier$ ["lux" "record$"]) (#Cons (tag$ ["lux" "Nil"]) #Nil))) #1) #Nil)) (#Cons [_ (#Tag ["" "export"])] (#Cons [_ (#Form (#Cons name args))] (#Cons meta-data (#Cons body #Nil)))) (return (#Cons (as-def name (as-macro (as-function name args body)) (form$ (#Cons (identifier$ ["lux" "record$"]) (#Cons meta-data #Nil))) #1) #Nil)) _ (fail "Wrong syntax for macro:'")} tokens))) (record$ #.Nil) #0) (macro:' #export (comment tokens) (#Cons [(tag$ ["lux" "doc"]) (text$ ("lux text concat" ("lux text concat" "## Throws away any code given to it." __paragraph) ("lux text concat" ("lux text concat" "## Great for commenting-out code, while retaining syntax high-lighting and formatting in your text editor." __paragraph) "(comment +1 +2 +3 +4)")))] #Nil) (return #Nil)) (macro:' ($' tokens) ({(#Cons x #Nil) (return tokens) (#Cons x (#Cons y xs)) (return (#Cons (form$ (#Cons (identifier$ ["lux" "$'"]) (#Cons (form$ (#Cons (tag$ ["lux" "Apply"]) (#Cons y (#Cons x #Nil)))) xs))) #Nil)) _ (fail "Wrong syntax for $'")} tokens)) (def:'' (list@map f xs) #Nil (#UnivQ #Nil (#UnivQ #Nil (#Function (#Function (#Parameter 3) (#Parameter 1)) (#Function ($' List (#Parameter 3)) ($' List (#Parameter 1)))))) ({#Nil #Nil (#Cons x xs') (#Cons (f x) (list@map f xs'))} xs)) (def:'' RepEnv #Nil Type ($' List (#Product Text Code))) (def:'' (make-env xs ys) #Nil (#Function ($' List Text) (#Function ($' List Code) RepEnv)) ({[(#Cons x xs') (#Cons y ys')] (#Cons [x y] (make-env xs' ys')) _ #Nil} [xs ys])) (def:'' (text@= reference sample) #Nil (#Function Text (#Function Text Bit)) ("lux text =" reference sample)) (def:'' (get-rep key env) #Nil (#Function Text (#Function RepEnv ($' Maybe Code))) ({#Nil #None (#Cons [k v] env') ({#1 (#Some v) #0 (get-rep key env')} (text@= k key))} env)) (def:'' (replace-syntax reps syntax) #Nil (#Function RepEnv (#Function Code Code)) ({[_ (#Identifier "" name)] ({(#Some replacement) replacement #None syntax} (get-rep name reps)) [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] ({[k v] [(replace-syntax reps k) (replace-syntax reps v)]} slot))) slots))] _ syntax} syntax)) (def:'' (n/* param subject) (#.Cons (doc-meta "Nat(ural) multiplication.") #.Nil) (#Function Nat (#Function Nat Nat)) ("lux coerce" Nat ("lux i64 *" ("lux coerce" Int param) ("lux coerce" Int subject)))) (def:'' (update-parameters code) #Nil (#Function Code Code) ({[_ (#Tuple members)] (tuple$ (list@map update-parameters members)) [_ (#Record pairs)] (record$ (list@map ("lux check" (#Function (#Product Code Code) (#Product Code Code)) (function'' [pair] (let'' [name val] pair [name (update-parameters val)]))) pairs)) [_ (#Form (#Cons [_ (#Tag "lux" "Parameter")] (#Cons [_ (#Nat idx)] #Nil)))] (form$ (#Cons (tag$ ["lux" "Parameter"]) (#Cons (nat$ ("lux i64 +" 2 idx)) #Nil))) [_ (#Form members)] (form$ (list@map update-parameters members)) _ code} 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) )) ({#Nil (next #Nil) (#Cons [_ (#Identifier "" arg-name)] args') (parse-quantified-args args' (function'' [names] (next (#Cons arg-name names)))) _ (fail "Expected identifier.")} args)) (def:'' (make-parameter idx) #Nil (#Function Nat Code) (form$ (#Cons (tag$ ["lux" "Parameter"]) (#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 (#Parameter 1) (#Function (#Parameter 3) (#Parameter 3))) (#Function (#Parameter 3) (#Function ($' List (#Parameter 1)) (#Parameter 3)))))) ({#Nil init (#Cons x xs') (list@fold f (f x init) xs')} xs)) (def:'' (list@size list) #Nil (#UnivQ #Nil (#Function ($' List (#Parameter 1)) Nat)) (list@fold (function'' [_ acc] ("lux i64 +" 1 acc)) 0 list)) (macro:' #export (All tokens) (#Cons [(tag$ ["lux" "doc"]) (text$ ("lux text concat" ("lux text concat" "## Universal quantification." __paragraph) ("lux text concat" ("lux text concat" "(All [a] (-> a a))" __paragraph) ("lux text concat" ("lux text concat" "## A name can be provided, to specify a recursive type." __paragraph) "(All List [a] (| Any [a (List a)]))"))))] #Nil) (let'' [self-name tokens] ({(#Cons [_ (#Identifier "" self-name)] tokens) [self-name tokens] _ ["" tokens]} 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-parameter 1)] #Nil) (update-parameters body')) #Nil)))))) body names) (return (#Cons ({[#1 _] body' [_ #Nil] body' [#0 _] (replace-syntax (#Cons [self-name (make-parameter (n/* 2 ("lux i64 -" 1 (list@size names))))] #Nil) body')} [(text@= "" self-name) names]) #Nil))))) _ (fail "Wrong syntax for All")} tokens))) (macro:' #export (Ex tokens) (#Cons [(tag$ ["lux" "doc"]) (text$ ("lux text concat" ("lux text concat" "## Existential quantification." __paragraph) ("lux text concat" ("lux text concat" "(Ex [a] [(Codec Text a) a])" __paragraph) ("lux text concat" ("lux text concat" "## A name can be provided, to specify a recursive type." __paragraph) "(Ex Self [a] [(Codec Text a) a (List (Self a))])"))))] #Nil) (let'' [self-name tokens] ({(#Cons [_ (#Identifier "" self-name)] tokens) [self-name tokens] _ ["" tokens]} 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-parameter 1)] #Nil) (update-parameters body')) #Nil)))))) body names) (return (#Cons ({[#1 _] body' [_ #Nil] body' [#0 _] (replace-syntax (#Cons [self-name (make-parameter (n/* 2 ("lux i64 -" 1 (list@size names))))] #Nil) body')} [(text@= "" self-name) names]) #Nil))))) _ (fail "Wrong syntax for Ex")} tokens))) (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$ ("lux text concat" ("lux text concat" "## Function types:" __paragraph) ("lux text concat" ("lux text concat" "(-> Int Int Int)" __paragraph) "## This is the type of a function that takes 2 Ints and returns an Int.")))] #Nil) ({(#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 ->")} (list@reverse tokens))) (macro:' #export (list xs) (#Cons [(tag$ ["lux" "doc"]) (text$ ("lux text concat" ("lux text concat" "## List-construction macro." __paragraph) "(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$ ("lux text concat" ("lux text concat" "## List-construction macro, with the last element being a tail-list." __paragraph) ("lux text concat" ("lux text concat" "## In other words, this macro prepends elements to another list." __paragraph) "(list& +1 +2 +3 (list +4 +5 +6))")))] #Nil) ({(#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&")} (list@reverse xs))) (macro:' #export (& tokens) (#Cons [(tag$ ["lux" "doc"]) (text$ ("lux text concat" ("lux text concat" "## Tuple types:" __paragraph) ("lux text concat" ("lux text concat" "(& Text Int Bit)" __paragraph) ("lux text concat" ("lux text concat" "## Any." __paragraph) "(&)"))))] #Nil) ({#Nil (return (list (identifier$ ["lux" "Any"]))) (#Cons last prevs) (return (list (list@fold (function'' [left right] (form$ (list (tag$ ["lux" "Product"]) left right))) last prevs)))} (list@reverse tokens))) (macro:' #export (| tokens) (#Cons [(tag$ ["lux" "doc"]) (text$ ("lux text concat" ("lux text concat" "## Variant types:" __paragraph) ("lux text concat" ("lux text concat" "(| Text Int Bit)" __paragraph) ("lux text concat" ("lux text concat" "## Nothing." __paragraph) "(|)"))))] #Nil) ({#Nil (return (list (identifier$ ["lux" "Nothing"]))) (#Cons last prevs) (return (list (list@fold (function'' [left right] (form$ (list (tag$ ["lux" "Sum"]) left right))) last prevs)))} (list@reverse tokens))) (macro:' (function' tokens) (let'' [name tokens'] ({(#Cons [[_ (#Identifier ["" name])] tokens']) [name tokens'] _ ["" tokens]} tokens) ({(#Cons [[_ (#Tuple args)] (#Cons [body #Nil])]) ({#Nil (fail "function' requires a non-empty arguments tuple.") (#Cons [harg targs]) (return (list (form$ (list (tuple$ (list (local-identifier$ name) harg)) (list@fold (function'' [arg body'] (form$ (list (tuple$ (list (local-identifier$ "") arg)) body'))) body (list@reverse targs))))))} args) _ (fail "Wrong syntax for function'")} tokens'))) (macro:' (def:''' 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 (identifier$ ["lux" "function'"]) name (tuple$ args) body)))) (form$ (#Cons (identifier$ ["lux" "record$"]) (#Cons meta #Nil))) (bit$ #1))))) (#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 (identifier$ ["lux" "record$"]) (#Cons meta #Nil))) (bit$ #1))))) (#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 (identifier$ ["lux" "function'"]) name (tuple$ args) body)))) (form$ (#Cons (identifier$ ["lux" "record$"]) (#Cons meta #Nil))) (bit$ #0))))) (#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 (identifier$ ["lux" "record$"]) (#Cons meta #Nil))) (bit$ #0))))) _ (fail "Wrong syntax for def:'''")} tokens)) (def:''' (as-pairs xs) #Nil (All [a] (-> ($' List a) ($' List (& a a)))) ({(#Cons x (#Cons y xs')) (#Cons [x y] (as-pairs xs')) _ #Nil} xs)) (macro:' (let' tokens) ({(#Cons [[_ (#Tuple bindings)] (#Cons [body #Nil])]) (return (list (list@fold ("lux check" (-> (& Code Code) Code Code) (function' [binding body] ({[label value] (form$ (list (record$ (list [label body])) value))} binding))) body (list@reverse (as-pairs bindings))))) _ (fail "Wrong syntax for let'")} tokens)) (def:''' (any? p xs) #Nil (All [a] (-> (-> a Bit) ($' List a) Bit)) ({#Nil #0 (#Cons x xs') ({#1 #1 #0 (any? p xs')} (p x))} 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) ({#Nil (_ann (#Tag ["lux" "Nil"])) (#Cons [token tokens']) (_ann (#Form (list (_ann (#Tag ["lux" "Cons"])) token (untemplate-list tokens'))))} tokens)) (def:''' (list@compose xs ys) #Nil (All [a] (-> ($' List a) ($' List a) ($' List a))) ({(#Cons x xs') (#Cons x (list@compose xs' ys)) #Nil ys} xs)) (def:''' (_$_joiner op a1 a2) #Nil (-> Code Code Code Code) ({[_ (#Form parts)] (form$ (list@compose parts (list a1 a2))) _ (form$ (list op a1 a2))} op)) (def:''' (function/flip func) #Nil (All [a b c] (-> (-> a b c) (-> b a c))) (function' [right left] (func left right))) (macro:' #export (_$ tokens) (#Cons [(tag$ ["lux" "doc"]) (text$ ("lux text concat" ("lux text concat" "## Left-association for the application of binary functions over variadic arguments." ..new-line) ("lux text concat" ("lux text concat" "(_$ text@compose ''Hello, '' name ''. How are you?'')" ..new-line) ("lux text concat" ("lux text concat" "## =>" ..new-line) "(text@compose (text@compose ''Hello, '' name) ''. How are you?'')"))))] #Nil) ({(#Cons op tokens') ({(#Cons first nexts) (return (list (list@fold (function/flip (_$_joiner op)) first nexts))) _ (fail "Wrong syntax for _$")} tokens') _ (fail "Wrong syntax for _$")} tokens)) (macro:' #export ($_ tokens) (#Cons [(tag$ ["lux" "doc"]) (text$ ("lux text concat" ("lux text concat" "## Right-association for the application of binary functions over variadic arguments." ..new-line) ("lux text concat" ("lux text concat" "($_ text@compose ''Hello, '' name ''. How are you?'')" ..new-line) ("lux text concat" ("lux text concat" "## =>" ..new-line) "(text@compose ''Hello, '' (text@compose name ''. How are you?''))"))))] #Nil) ({(#Cons op tokens') ({(#Cons last prevs) (return (list (list@fold (_$_joiner op) last prevs))) _ (fail "Wrong syntax for $_")} (list@reverse tokens')) _ (fail "Wrong syntax for $_")} tokens)) ## (signature: (Monad m) ## (: (All [a] (-> a (m a))) ## wrap) ## (: (All [a b] (-> (-> a (m b)) (m a) (m b))) ## bind)) ("lux def type tagged" Monad (#Named ["lux" "Monad"] (All [m] (& (All [a] (-> a ($' m a))) (All [a b] (-> (-> a ($' m b)) ($' m a) ($' m b)))))) (record$ (list)) ["wrap" "bind"] #0) (def:''' maybe-monad #Nil ($' Monad Maybe) {#wrap (function' [x] (#Some x)) #bind (function' [f ma] ({#None #None (#Some a) (f a)} ma))}) (def:''' meta-monad #Nil ($' Monad Meta) {#wrap (function' [x] (function' [state] (#Right state x))) #bind (function' [f ma] (function' [state] ({(#Left msg) (#Left msg) (#Right state' a) (f a state')} (ma state))))}) (macro:' (do tokens) ({(#Cons monad (#Cons [_ (#Tuple bindings)] (#Cons body #Nil))) (let' [g!wrap (local-identifier$ "wrap") g!bind (local-identifier$ " bind ") body' (list@fold ("lux check" (-> (& Code Code) Code Code) (function' [binding body'] (let' [[var value] binding] ({[_ (#Tag "" "let")] (form$ (list (identifier$ ["lux" "let'"]) value body')) _ (form$ (list g!bind (form$ (list (tuple$ (list (local-identifier$ "") var)) body')) value))} var)))) body (list@reverse (as-pairs bindings)))] (return (list (form$ (list (record$ (list [(record$ (list [(tag$ ["lux" "wrap"]) g!wrap] [(tag$ ["lux" "bind"]) g!bind])) body'])) monad))))) _ (fail "Wrong syntax for do")} tokens)) (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] ({#Nil (wrap #Nil) (#Cons x xs') (do m [y (f x) ys (monad@map m f xs')] (wrap (#Cons y ys)))} xs))) (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] ({#Nil (wrap y) (#Cons x xs') (do m [y' (f x y)] (monad@fold m f y' xs'))} xs))) (macro:' #export (if tokens) (list [(tag$ ["lux" "doc"]) (text$ ($_ "lux text concat" "Picks which expression to evaluate based on a bit test value." __paragraph "(if #1 ''Oh, yeah!'' ''Aw hell naw!'')" __paragraph "=> ''Oh, yeah!''"))]) ({(#Cons test (#Cons then (#Cons else #Nil))) (return (list (form$ (list (record$ (list [(bit$ #1) then] [(bit$ #0) else])) test)))) _ (fail "Wrong syntax for if")} tokens)) (def:''' (get k plist) #Nil (All [a] (-> Text ($' List (& Text a)) ($' Maybe a))) ({(#Cons [[k' v] plist']) (if (text@= k k') (#Some v) (get k plist')) #Nil #None} plist)) (def:''' (put k v dict) #Nil (All [a] (-> Text a ($' List (& Text a)) ($' List (& Text a)))) ({#Nil (list [k v]) (#Cons [[k' v'] dict']) (if (text@= k k') (#Cons [[k' v] dict']) (#Cons [[k' v'] (put k v dict')]))} dict)) (def:''' #export (log! message) (list [(tag$ ["lux" "doc"]) (text$ ($_ "lux text concat" "Logs message to standard output." __paragraph "Useful for debugging."))]) (-> Text Any) ("lux io log" message)) (def:''' (text@compose x y) #Nil (-> Text Text Text) ("lux text concat" x y)) (def:''' (name@encode full-name) #Nil (-> Name Text) (let' [[module name] full-name] ({"" name _ ($_ text@compose module "." name)} module))) (def:''' (get-meta tag def-meta) #Nil (-> Name Code ($' Maybe Code)) (let' [[prefix name] tag] ({[_ (#Record def-meta)] ({(#Cons [key value] def-meta') ({[_ (#Tag [prefix' name'])] ({[#1 #1] (#Some value) _ (get-meta tag (record$ def-meta'))} [(text@= prefix prefix') (text@= name name')]) _ (get-meta tag (record$ def-meta'))} key) #Nil #None} def-meta) _ #None} def-meta))) (def:''' (resolve-global-identifier full-name state) #Nil (-> Name ($' Meta Name)) (let' [[module name] full-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] ({(#Some {#module-hash _ #module-aliases _ #definitions definitions #imports _ #tags tags #types types #module-annotations _ #module-state _}) ({(#Some constant) ({(#Left real-name) (#Right [state real-name]) (#Right [exported? def-type def-meta def-value]) (#Right [state full-name])} constant) #None (#Left ($_ text@compose "Unknown definition: " (name@encode full-name)))} (get name definitions)) #None (#Left ($_ text@compose "Unknown module: " module " @ " (name@encode full-name)))} (get module modules)))) (def:''' (as-code-list expression) #Nil (-> Code Code) (let' [type (form$ (list (tag$ ["lux" "Apply"]) (identifier$ ["lux" "Code"]) (identifier$ ["lux" "List"])))] (form$ (list (text$ "lux check") type expression)))) (def:''' (splice replace? untemplate elems) #Nil (-> Bit (-> Code ($' Meta Code)) ($' List Code) ($' Meta Code)) ({#1 ({#Nil (return (tag$ ["lux" "Nil"])) (#Cons lastI inits) (do meta-monad [lastO ({[_ (#Form (#Cons [[_ (#Identifier ["" "~+"])] (#Cons [spliced #Nil])]))] (wrap (as-code-list spliced)) _ (do meta-monad [lastO (untemplate lastI)] (wrap (as-code-list (form$ (list (tag$ ["lux" "Cons"]) (tuple$ (list lastO (tag$ ["lux" "Nil"]))))))))} lastI)] (monad@fold meta-monad (function' [leftI rightO] ({[_ (#Form (#Cons [[_ (#Identifier ["" "~+"])] (#Cons [spliced #Nil])]))] (let' [g!in-module (form$ (list (text$ "lux in-module") (text$ "lux") (identifier$ ["lux" "list@compose"])))] (wrap (form$ (list g!in-module (as-code-list spliced) rightO)))) _ (do meta-monad [leftO (untemplate leftI)] (wrap (form$ (list (tag$ ["lux" "Cons"]) (tuple$ (list leftO rightO))))))} leftI)) lastO inits))} (list@reverse elems)) #0 (do meta-monad [=elems (monad@map meta-monad untemplate elems)] (wrap (untemplate-list =elems)))} replace?)) (def:''' (untemplate-text value) #Nil (-> Text Code) (wrap-meta (form$ (list (tag$ ["lux" "Text"]) (text$ value))))) (def:''' (untemplate replace? subst token) #Nil (-> Bit Text Code ($' Meta Code)) ({[_ [_ (#Bit value)]] (return (wrap-meta (form$ (list (tag$ ["lux" "Bit"]) (bit$ 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))))) [_ [_ (#Rev value)]] (return (wrap-meta (form$ (list (tag$ ["lux" "Rev"]) (rev$ value))))) [_ [_ (#Frac value)]] (return (wrap-meta (form$ (list (tag$ ["lux" "Frac"]) (frac$ value))))) [_ [_ (#Text value)]] (return (untemplate-text value)) [#0 [_ (#Tag [module name])]] (return (wrap-meta (form$ (list (tag$ ["lux" "Tag"]) (tuple$ (list (text$ module) (text$ name))))))) [#1 [_ (#Tag [module name])]] (let' [module' ({"" subst _ module} module)] (return (wrap-meta (form$ (list (tag$ ["lux" "Tag"]) (tuple$ (list (text$ module') (text$ name)))))))) [#1 [_ (#Identifier [module name])]] (do meta-monad [real-name ({"" (if (text@= "" subst) (wrap [module name]) (resolve-global-identifier [subst name])) _ (wrap [module name])} module) #let [[module name] real-name]] (return (wrap-meta (form$ (list (tag$ ["lux" "Identifier"]) (tuple$ (list (text$ module) (text$ name)))))))) [#0 [_ (#Identifier [module name])]] (return (wrap-meta (form$ (list (tag$ ["lux" "Identifier"]) (tuple$ (list (text$ module) (text$ name))))))) [#1 [_ (#Form (#Cons [[_ (#Identifier ["" "~"])] (#Cons [unquoted #Nil])]))]] (return (form$ (list (text$ "lux check") (identifier$ ["lux" "Code"]) unquoted))) [#1 [_ (#Form (#Cons [[_ (#Identifier ["" "~!"])] (#Cons [dependent #Nil])]))]] (do meta-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))))))) [#1 [_ (#Form (#Cons [[_ (#Identifier ["" "~'"])] (#Cons [keep-quoted #Nil])]))]] (untemplate #0 subst keep-quoted) [_ [meta (#Form elems)]] (do meta-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 meta-monad [output (splice replace? (untemplate replace? subst) elems) #let [[_ output'] (wrap-meta (form$ (list (tag$ ["lux" "Tuple"]) output)))]] (wrap [meta output'])) [_ [_ (#Record fields)]] (do meta-monad [=fields (monad@map meta-monad ("lux check" (-> (& Code Code) ($' Meta Code)) (function' [kv] (let' [[k v] kv] (do meta-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))))))} [replace? token])) (macro:' #export (primitive tokens) (list [(tag$ ["lux" "doc"]) (text$ ($_ "lux text concat" "## Macro to treat define new primitive types." __paragraph "(primitive ''java.lang.Object'')" __paragraph "(primitive ''java.util.List'' [(primitive ''java.lang.Long'')])"))]) ({(#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")} tokens)) (def:'' (current-module-name state) #Nil ($' Meta Text) ({{#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} ({(#Some module-name) (#Right [state module-name]) _ (#Left "Cannot get the module name without a module!")} current-module)} state)) (macro:' #export (` tokens) (list [(tag$ ["lux" "doc"]) (text$ ($_ "lux text concat" "## Hygienic quasi-quotation as a macro. Unquote (~) and unquote-splice (~+) must also be used as forms." __paragraph "## 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." __paragraph "(` (def: (~ name) (function ((~' _) (~+ args)) (~ body))))"))]) ({(#Cons template #Nil) (do meta-monad [current-module current-module-name =template (untemplate #1 current-module template)] (wrap (list (form$ (list (text$ "lux check") (identifier$ ["lux" "Code"]) =template))))) _ (fail "Wrong syntax for `")} tokens)) (macro:' #export (`' tokens) (list [(tag$ ["lux" "doc"]) (text$ ($_ "lux text concat" "## Unhygienic quasi-quotation as a macro. Unquote (~) and unquote-splice (~+) must also be used as forms." __paragraph "(`' (def: (~ name) (function (_ (~+ args)) (~ body))))"))]) ({(#Cons template #Nil) (do meta-monad [=template (untemplate #1 "" template)] (wrap (list (form$ (list (text$ "lux check") (identifier$ ["lux" "Code"]) =template))))) _ (fail "Wrong syntax for `")} tokens)) (macro:' #export (' tokens) (list [(tag$ ["lux" "doc"]) (text$ ($_ "lux text concat" "## Quotation as a macro." __paragraph "(' YOLO)"))]) ({(#Cons template #Nil) (do meta-monad [=template (untemplate #0 "" template)] (wrap (list (form$ (list (text$ "lux check") (identifier$ ["lux" "Code"]) =template))))) _ (fail "Wrong syntax for '")} tokens)) (macro:' #export (|> tokens) (list [(tag$ ["lux" "doc"]) (text$ ($_ "lux text concat" "## Piping macro." __paragraph "(|> elems (list@map int@encode) (interpose '' '') (fold text@compose ''''))" __paragraph "## =>" __paragraph "(fold text@compose '''' (interpose '' '' (list@map int@encode elems)))"))]) ({(#Cons [init apps]) (return (list (list@fold ("lux check" (-> Code Code Code) (function' [app acc] ({[_ (#Tuple parts)] (tuple$ (list@compose parts (list acc))) [_ (#Form parts)] (form$ (list@compose parts (list acc))) _ (` ((~ app) (~ acc)))} app))) init apps))) _ (fail "Wrong syntax for |>")} tokens)) (macro:' #export (<| tokens) (list [(tag$ ["lux" "doc"]) (text$ ($_ "lux text concat" "## Reverse piping macro." __paragraph "(<| (fold text@compose '''') (interpose '' '') (list@map int@encode) elems)" __paragraph "## =>" __paragraph "(fold text@compose '''' (interpose '' '' (list@map int@encode elems)))"))]) ({(#Cons [init apps]) (return (list (list@fold ("lux check" (-> Code Code Code) (function' [app acc] ({[_ (#Tuple parts)] (tuple$ (list@compose parts (list acc))) [_ (#Form parts)] (form$ (list@compose parts (list acc))) _ (` ((~ app) (~ acc)))} app))) init apps))) _ (fail "Wrong syntax for <|")} (list@reverse tokens))) (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-name x) #Nil (-> Code ($' Maybe Name)) ({[_ (#Identifier sname)] (#Some sname) _ #None} x)) (def:''' (get-tag x) #Nil (-> Code ($' Maybe Name)) ({[_ (#Tag sname)] (#Some sname) _ #None} x)) (def:''' (get-short x) #Nil (-> Code ($' Maybe Text)) ({[_ (#Identifier "" sname)] (#Some sname) _ #None} x)) (def:''' (tuple->list tuple) #Nil (-> Code ($' Maybe ($' List Code))) ({[_ (#Tuple members)] (#Some members) _ #None} tuple)) (def:''' (apply-template env template) #Nil (-> RepEnv Code Code) ({[_ (#Identifier "" sname)] ({(#Some subst) subst _ template} (get-rep sname env)) [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} template)) (def:''' (join-map f xs) #Nil (All [a b] (-> (-> a ($' List b)) ($' List a) ($' List b))) ({#Nil #Nil (#Cons [x xs']) (list@compose (f x) (join-map f xs'))} xs)) (def:''' (every? p xs) #Nil (All [a] (-> (-> a Bit) ($' List a) Bit)) (list@fold (function' [_2 _1] (if _1 (p _2) #0)) #1 xs)) (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:''' (n/< reference sample) (list) (-> Nat Nat Bit) (let' [referenceH (high-bits reference) sampleH (high-bits sample)] (if ("lux i64 <" referenceH sampleH) #1 (if ("lux i64 =" referenceH sampleH) ("lux i64 <" (low-bits reference) (low-bits sample)) #0)))) (def:''' (n/<= reference sample) (list) (-> Nat Nat Bit) (if (n/< reference sample) #1 ("lux i64 =" reference sample))) (macro:' #export (template tokens) (list [(tag$ ["lux" "doc"]) (text$ ($_ "lux text concat" "## By specifying a pattern (with holes), and the input data to fill those holes, repeats the pattern as many times as necessary." __paragraph "(template [ ]" ..new-line " " "[(def: #export (-> Int Int) (+ ))]" __paragraph " " "[inc +1]" ..new-line " " "[dec -1]"))]) ({(#Cons [[_ (#Tuple bindings)] (#Cons [[_ (#Tuple templates)] 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? (function' [size] ("lux i64 =" num-bindings size)) (list@map list@size data')) (|> data' (join-map (compose apply (make-env bindings'))) return) (fail "Irregular arguments tuples for template."))) _ (fail "Wrong syntax for template")} [(monad@map maybe-monad get-short bindings) (monad@map maybe-monad tuple->list data)]) _ (fail "Wrong syntax for template")} tokens)) (def:''' (n// param subject) (list) (-> Nat Nat Nat) (if ("lux i64 <" +0 ("lux coerce" Int param)) (if (n/< param subject) 0 1) (let' [quotient (|> subject ("lux i64 logical-right-shift" 1) ("lux i64 /" ("lux coerce" Int param)) ("lux i64 left-shift" 1)) flat ("lux i64 *" ("lux coerce" Int param) ("lux coerce" Int quotient)) remainder ("lux i64 -" flat subject)] (if (n/< param remainder) quotient ("lux i64 +" 1 quotient))))) (def:''' (n/% param subject) (list) (-> Nat Nat Nat) (let' [flat ("lux i64 *" ("lux coerce" Int param) ("lux coerce" Int (n// param subject)))] ("lux i64 -" flat subject))) (def:''' (n/min left right) (list) (-> Nat Nat Nat) (if (n/< right left) left right)) (def:''' (bit@encode x) #Nil (-> Bit Text) (if x "#1" "#0")) (def:''' (digit-to-text digit) #Nil (-> Nat Text) ({0 "0" 1 "1" 2 "2" 3 "3" 4 "4" 5 "5" 6 "6" 7 "7" 8 "8" 9 "9" _ ("lux io error" "undefined")} digit)) (def:''' (nat@encode value) #Nil (-> Nat Text) ({0 "0" _ (let' [loop ("lux check" (-> Nat Text Text) (function' recur [input output] (if ("lux i64 =" 0 input) output (recur (n// 10 input) (text@compose (|> input (n/% 10) digit-to-text) output)))))] (loop value ""))} value)) (def:''' (int@abs value) #Nil (-> Int Int) (if ("lux i64 <" +0 value) ("lux i64 *" -1 value) value)) (def:''' (int@encode value) #Nil (-> Int Text) (if ("lux i64 =" +0 value) "0" (let' [sign (if ("lux i64 <" value +0) "" "-")] (("lux check" (-> Int Text Text) (function' recur [input output] (if ("lux i64 =" +0 input) (text@compose sign output) (recur ("lux i64 /" +10 input) (text@compose (|> input ("lux i64 %" +10) ("lux coerce" Nat) digit-to-text) output))))) (|> value ("lux i64 /" +10) int@abs) (|> value ("lux i64 %" +10) int@abs ("lux coerce" Nat) digit-to-text))))) (def:''' (frac@encode x) #Nil (-> Frac Text) ("lux f64 encode" x)) (def:''' (multiple? div n) #Nil (-> Nat Nat Bit) (|> n (n/% div) ("lux i64 =" 0))) (def:''' #export (not x) (list [(tag$ ["lux" "doc"]) (text$ ($_ "lux text concat" "## Bit negation." __paragraph "(not #1) => #0" __paragraph "(not #0) => #1"))]) (-> Bit Bit) (if x #0 #1)) (def:''' (macro-type? type) (list) (-> Type Bit) ({(#Named ["lux" "Macro"] (#Primitive "#Macro" #Nil)) #1 _ #0} type)) (def:''' (find-macro' modules current-module module name) #Nil (-> ($' List (& Text Module)) Text Text Text ($' Maybe Macro)) (do maybe-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))] ({(#Left [r-module r-name]) (find-macro' modules current-module r-module r-name) (#Right [exported? def-type def-meta def-value]) (if (macro-type? def-type) (if exported? (#Some ("lux coerce" Macro def-value)) (if (text@= module current-module) (#Some ("lux coerce" Macro def-value)) #None)) #None)} ("lux check" Global gdef)))) (def:''' (normalize name) #Nil (-> Name ($' Meta Name)) ({["" name] (do meta-monad [module-name current-module-name] (wrap [module-name name])) _ (return name)} name)) (def:''' (find-macro full-name) #Nil (-> Name ($' Meta ($' Maybe Macro))) (do meta-monad [current-module current-module-name] (let' [[module name] full-name] (function' [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))} state))))) (def:''' (macro? name) #Nil (-> Name ($' Meta Bit)) (do meta-monad [name (normalize name) output (find-macro name)] (wrap ({(#Some _) #1 #None #0} output)))) (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))) ({#Nil xs (#Cons [x #Nil]) xs (#Cons [x xs']) (list& x sep (interpose sep xs'))} xs)) (def:''' (macro-expand-once token) #Nil (-> Code ($' Meta ($' List Code))) ({[_ (#Form (#Cons [_ (#Identifier macro-name)] args))] (do meta-monad [macro-name' (normalize macro-name) ?macro (find-macro macro-name')] ({(#Some macro) (("lux coerce" Macro' macro) args) #None (return (list token))} ?macro)) _ (return (list token))} token)) (def:''' (macro-expand token) #Nil (-> Code ($' Meta ($' List Code))) ({[_ (#Form (#Cons [_ (#Identifier macro-name)] args))] (do meta-monad [macro-name' (normalize macro-name) ?macro (find-macro macro-name')] ({(#Some macro) (do meta-monad [expansion (("lux coerce" Macro' macro) args) expansion' (monad@map meta-monad macro-expand expansion)] (wrap (list@join expansion'))) #None (return (list token))} ?macro)) _ (return (list token))} token)) (def:''' (macro-expand-all syntax) #Nil (-> Code ($' Meta ($' List Code))) ({[_ (#Form (#Cons [_ (#Identifier macro-name)] args))] (do meta-monad [macro-name' (normalize macro-name) ?macro (find-macro macro-name')] ({(#Some macro) (do meta-monad [expansion (("lux coerce" Macro' macro) args) expansion' (monad@map meta-monad macro-expand-all expansion)] (wrap (list@join expansion'))) #None (do meta-monad [args' (monad@map meta-monad macro-expand-all args)] (wrap (list (form$ (#Cons (identifier$ macro-name) (list@join args'))))))} ?macro)) [_ (#Form members)] (do meta-monad [members' (monad@map meta-monad macro-expand-all members)] (wrap (list (form$ (list@join members'))))) [_ (#Tuple members)] (do meta-monad [members' (monad@map meta-monad macro-expand-all members)] (wrap (list (tuple$ (list@join members'))))) [_ (#Record pairs)] (do meta-monad [pairs' (monad@map meta-monad (function' [kv] (let' [[key val] kv] (do meta-monad [val' (macro-expand-all 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.")} val')))) pairs)] (wrap (list (record$ pairs')))) _ (return (list syntax))} syntax)) (def:''' (walk-type type) #Nil (-> Code Code) ({[_ (#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 [_ (#Identifier ["" ":~"])] (#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} type)) (macro:' #export (type tokens) (list [(tag$ ["lux" "doc"]) (text$ ($_ "lux text concat" "## Takes a type expression and returns it's representation as data-structure." __paragraph "(type (All [a] (Maybe (List a))))"))]) ({(#Cons type #Nil) (do meta-monad [type+ (macro-expand-all type)] ({(#Cons type' #Nil) (wrap (list (walk-type type'))) _ (fail "The expansion of the type-syntax had to yield a single element.")} type+)) _ (fail "Wrong syntax for type")} tokens)) (macro:' #export (: tokens) (list [(tag$ ["lux" "doc"]) (text$ ($_ "lux text concat" "## The type-annotation macro." __paragraph "(: (List Int) (list +1 +2 +3))"))]) ({(#Cons type (#Cons value #Nil)) (return (list (` ("lux check" (type (~ type)) (~ value))))) _ (fail "Wrong syntax for :")} tokens)) (macro:' #export (:coerce tokens) (list [(tag$ ["lux" "doc"]) (text$ ($_ "lux text concat" "## The type-coercion macro." __paragraph "(:coerce Dinosaur (list +1 +2 +3))"))]) ({(#Cons type (#Cons value #Nil)) (return (list (` ("lux coerce" (type (~ type)) (~ value))))) _ (fail "Wrong syntax for :coerce")} tokens)) (def:''' (empty? xs) #Nil (All [a] (-> ($' List a) Bit)) ({#Nil #1 _ #0} xs)) (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))))) ({(#Cons [_ (#Record pairs)] #Nil) (do meta-monad [members (monad@map meta-monad (: (-> [Code Code] (Meta [Text Code])) (function' [pair] ({[[_ (#Tag "" member-name)] member-type] (return [member-name member-type]) _ (fail "Wrong syntax for variant case.")} pair))) pairs)] (return [(` (& (~+ (list@map second members)))) (#Some (list@map first members))])) (#Cons type #Nil) ({[_ (#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])} type) (#Cons case cases) (do meta-monad [members (monad@map meta-monad (: (-> Code (Meta [Text Code])) (function' [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.")} case))) (list& case cases))] (return [(` (| (~+ (list@map second members)))) (#Some (list@map first members))])) _ (fail "Improper type-definition syntax")} type-codes)) (def:''' (gensym prefix state) #Nil (-> Text ($' Meta Code)) ({{#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 ("lux i64 +" 1 seed) #expected expected #cursor cursor #extensions extensions #scope-type-vars scope-type-vars} (local-identifier$ ($_ text@compose "__gensym__" prefix (nat@encode seed))))} state)) (macro:' #export (Rec tokens) (list [(tag$ ["lux" "doc"]) (text$ ($_ "lux text concat" "## Parameter-less recursive types." __paragraph "## A name has to be given to the whole type, to use it within its body." __paragraph "(Rec Self [Int (List Self)])"))]) ({(#Cons [_ (#Identifier "" name)] (#Cons body #Nil)) (let' [body' (replace-syntax (list [name (` (#.Apply (~ (make-parameter 1)) (~ (make-parameter 0))))]) (update-parameters body))] (return (list (` (#.Apply .Nothing (#.UnivQ #.Nil (~ body'))))))) _ (fail "Wrong syntax for Rec")} tokens)) (macro:' #export (exec tokens) (list [(tag$ ["lux" "doc"]) (text$ ($_ "lux text concat" "## Sequential execution of expressions (great for side-effects)." __paragraph "(exec" ..new-line " " "(log! ''#1'')" ..new-line " " "(log! ''#2'')" ..new-line " " "(log! ''#3'')" ..new-line "''YOLO'')"))]) ({(#Cons value actions) (let' [dummy (local-identifier$ "")] (return (list (list@fold ("lux check" (-> Code Code Code) (function' [pre post] (` ({(~ dummy) (~ post)} (~ pre))))) value actions)))) _ (fail "Wrong syntax for exec")} (list@reverse tokens))) (macro:' (def:' tokens) (let' [[export? tokens'] ({(#Cons [_ (#Tag ["" "export"])] tokens') [#1 tokens'] _ [#0 tokens]} tokens) parts (: (Maybe [Code (List Code) (Maybe Code) Code]) ({(#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} tokens'))] ({(#Some name args ?type body) (let' [body' ({#Nil body _ (` (function' (~ name) [(~+ args)] (~ body)))} args) body'' ({(#Some type) (` (: (~ type) (~ body'))) #None body'} ?type)] (return (list (` ("lux def" (~ name) (~ body'') [(~ cursor-code) (#.Record #.Nil)] (~ (bit$ export?))))))) #None (fail "Wrong syntax for def'")} parts))) (def:' (rejoin-pair pair) (-> [Code Code] (List Code)) (let' [[left right] pair] (list left right))) (def:' (text@encode original) (-> Text Text) ($_ text@compose ..double-quote original ..double-quote)) (def:' (code@encode code) (-> Code Text) ({[_ (#Bit value)] (bit@encode value) [_ (#Nat value)] (nat@encode value) [_ (#Int value)] (int@encode value) [_ (#Rev value)] ("lux io error" "Undefined behavior.") [_ (#Frac value)] (frac@encode value) [_ (#Text value)] (text@encode value) [_ (#Identifier [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@encode) (interpose " ") list@reverse (list@fold text@compose "")) ")") [_ (#Tuple xs)] ($_ text@compose "[" (|> xs (list@map code@encode) (interpose " ") list@reverse (list@fold text@compose "")) "]") [_ (#Record kvs)] ($_ text@compose "{" (|> kvs (list@map (function' [kv] ({[k v] ($_ text@compose (code@encode k) " " (code@encode v))} kv))) (interpose " ") list@reverse (list@fold text@compose "")) "}")} code)) (def:' (expander branches) (-> (List Code) (Meta (List Code))) ({(#Cons [_ (#Form (#Cons [_ (#Identifier macro-name)] macro-args))] (#Cons body branches')) (do meta-monad [??? (macro? macro-name)] (if ??? (do meta-monad [init-expansion (macro-expand-once (form$ (list& (identifier$ macro-name) (form$ macro-args) body branches')))] (expander init-expansion)) (do meta-monad [sub-expansion (expander branches')] (wrap (list& (form$ (list& (identifier$ macro-name) macro-args)) body sub-expansion))))) (#Cons pattern (#Cons body branches')) (do meta-monad [sub-expansion (expander branches')] (wrap (list& pattern body sub-expansion))) #Nil (do meta-monad [] (wrap (list))) _ (fail ($_ text@compose "'lux.case' expects an even number of tokens: " (|> branches (list@map code@encode) (interpose " ") list@reverse (list@fold text@compose ""))))} branches)) (macro:' #export (case tokens) (list [(tag$ ["lux" "doc"]) (text$ ($_ "lux text concat" "## The pattern-matching macro." ..new-line "## Allows the usage of macros within the patterns to provide custom syntax." ..new-line "(case (: (List Int) (list +1 +2 +3))" ..new-line " " "(#Cons x (#Cons y (#Cons z #Nil)))" ..new-line " " "(#Some ($_ * x y z))" __paragraph " " "_" ..new-line " " "#None)"))]) ({(#Cons value branches) (do meta-monad [expansion (expander branches)] (wrap (list (` ((~ (record$ (as-pairs expansion))) (~ value)))))) _ (fail "Wrong syntax for case")} tokens)) (macro:' #export (^ tokens) (list [(tag$ ["lux" "doc"]) (text$ ($_ "lux text concat" "## Macro-expanding patterns." ..new-line "## It's a special macro meant to be used with 'case'." ..new-line "(case (: (List Int) (list +1 +2 +3))" ..new-line " (^ (list x y z))" ..new-line " (#Some ($_ * x y z))" __paragraph " _" ..new-line " #None)"))]) (case tokens (#Cons [_ (#Form (#Cons pattern #Nil))] (#Cons body branches)) (do meta-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$ ($_ "lux text concat" "## Or-patterns." ..new-line "## It's a special macro meant to be used with 'case'." ..new-line "(type: Weekday #Monday #Tuesday #Wednesday #Thursday #Friday #Saturday #Sunday)" __paragraph "(def: (weekend? day)" ..new-line " (-> Weekday Bit)" ..new-line " (case day" ..new-line " (^or #Saturday #Sunday)" ..new-line " #1" __paragraph " _" ..new-line " #0))"))]) (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:' (identifier? code) (-> Code Bit) (case code [_ (#Identifier _)] #1 _ #0)) (macro:' #export (let tokens) (list [(tag$ ["lux" "doc"]) (text$ ($_ "lux text concat" "## Creates local bindings." ..new-line "## Can (optionally) use pattern-matching macros when binding." ..new-line "(let [x (foo bar)" ..new-line " y (baz quux)]" ..new-line " (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 (identifier? l) (` ({(~ l) (~ body')} (~ r))) (` (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$ ($_ "lux text concat" "## Syntax for creating functions." ..new-line "## Allows for giving the function itself a name, for the sake of recursion." ..new-line "(: (All [a b] (-> a b a))" ..new-line " (function (_ x y) x))" __paragraph "(: (All [a b] (-> a b a))" ..new-line " (function (const x y) x))"))]) (case (: (Maybe [Text Code (List Code) Code]) (case tokens (^ (list [_ (#Form (list& [_ (#Identifier ["" name])] head tail))] body)) (#Some name head tail body) _ #None)) (#Some g!name head tail body) (let [g!blank (local-identifier$ "") g!name (local-identifier$ g!name) body+ (list@fold (: (-> Code Code Code) (function' [arg body'] (if (identifier? arg) (` ([(~ g!blank) (~ arg)] (~ body'))) (` ([(~ g!blank) (~ g!blank)] (case (~ g!blank) (~ arg) (~ body'))))))) body (list@reverse tail))] (return (list (if (identifier? head) (` ([(~ g!name) (~ head)] (~ body+))) (` ([(~ 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 [_ (#Bit value)] (meta-code ["lux" "Bit"] (bit$ value)) [_ (#Nat value)] (meta-code ["lux" "Nat"] (nat$ value)) [_ (#Int value)] (meta-code ["lux" "Int"] (int$ value)) [_ (#Rev value)] (meta-code ["lux" "Rev"] (rev$ 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 _)] [_ (#Identifier _)]) 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@encode arg))))])) args))))]] (~ meta))))) (def:' (with-type-args args) (-> (List Code) Code) (` {#.type-args [(~+ (list@map (function (_ arg) (text$ (code@encode arg))) args))]})) (def:' (export^ tokens) (-> (List Code) [Bit (List Code)]) (case tokens (#Cons [_ (#Tag [_ "export"])] tokens') [#1 tokens'] _ [#0 tokens])) (def:' (export ?) (-> Bit (List Code)) (if ? (list (' #export)) (list))) (macro:' #export (def: tokens) (list [(tag$ ["lux" "doc"]) (text$ ($_ "lux text concat" "## Defines global constants/functions." ..new-line "(def: (rejoin-pair pair)" ..new-line " (-> [Code Code] (List Code))" ..new-line " (let [[left right] pair]" ..new-line " (list left right)))" __paragraph "(def: branching-exponent" ..new-line " Int" ..new-line " +5)"))]) (let [[exported? 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 =meta)))] (~ (bit$ exported?))))))) #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$ ($_ "lux text concat" "## Macro-definition macro." ..new-line "(macro: #export (name-of tokens)" ..new-line " (case tokens" ..new-line " (^template []" ..new-line " (^ (list [_ ( [prefix name])]))" ..new-line " (return (list (` [(~ (text$ prefix)) (~ (text$ name))]))))" ..new-line " ([#Identifier] [#Tag])" __paragraph " _" ..new-line " (fail ''Wrong syntax for name-of'')))"))]) (let [[exported? tokens] (export^ tokens) name+args+meta+body?? (: (Maybe [Name (List Code) (List [Code Code]) Code]) (case tokens (^ (list [_ (#Form (list& [_ (#Identifier name)] args))] body)) (#Some [name args (list) body]) (^ (list [_ (#Identifier name)] body)) (#Some [name #Nil (list) body]) (^ (list [_ (#Form (list& [_ (#Identifier name)] args))] [_ (#Record meta-rec-parts)] body)) (#Some [name args meta-rec-parts body]) (^ (list [_ (#Identifier name)] [_ (#Record meta-rec-parts)] body)) (#Some [name #Nil meta-rec-parts body]) _ #None))] (case name+args+meta+body?? (#Some [name args meta body]) (let [name (identifier$ name) body (case args #Nil body _ (` ("lux macro" (function ((~ name) (~+ args)) (~ body))))) =meta (process-def-meta meta)] (return (list (` ("lux def" (~ name) (~ body) [(~ cursor-code) (#Record (~ =meta))] (~ (bit$ exported?))))))) #None (fail "Wrong syntax for macro:")))) (macro: #export (signature: tokens) {#.doc (text$ ($_ "lux text concat" "## Definition of signatures ala ML." ..new-line "(signature: #export (Ord a)" ..new-line " (: (Equivalence a)" ..new-line " eq)" ..new-line " (: (-> a a Bit)" ..new-line " <)" ..new-line " (: (-> a a Bit)" ..new-line " <=)" ..new-line " (: (-> a a Bit)" ..new-line " >)" ..new-line " (: (-> a a Bit)" ..new-line " >=))"))} (let [[exported? tokens'] (export^ tokens) ?parts (: (Maybe [Name (List Code) Code (List Code)]) (case tokens' (^ (list& [_ (#Form (list& [_ (#Identifier name)] args))] [meta-rec-cursor (#Record meta-rec-parts)] sigs)) (#Some name args [meta-rec-cursor (#Record meta-rec-parts)] sigs) (^ (list& [_ (#Identifier name)] [meta-rec-cursor (#Record meta-rec-parts)] sigs)) (#Some name #Nil [meta-rec-cursor (#Record meta-rec-parts)] sigs) (^ (list& [_ (#Form (list& [_ (#Identifier name)] args))] sigs)) (#Some name args (` {}) sigs) (^ (list& [_ (#Identifier name)] sigs)) (#Some name #Nil (` {}) sigs) _ #None))] (case ?parts (#Some name args meta sigs) (do meta-monad [name+ (normalize name) sigs' (monad@map meta-monad macro-expand sigs) members (: (Meta (List [Text Code])) (monad@map meta-monad (: (-> Code (Meta [Text Code])) (function (_ token) (case token (^ [_ (#Form (list [_ (#Text "lux check")] type [_ (#Identifier ["" name])]))]) (wrap [name type]) _ (fail "Signatures require typed members!")))) (list@join sigs'))) #let [[_module _name] name+ def-name (identifier$ name) sig-type (record$ (list@map (: (-> [Text Code] [Code Code]) (function (_ [m-name m-type]) [(local-tag$ m-name) m-type])) members)) sig-meta (meta-code-merge (` {#.sig? #1}) 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 signature:")))) (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)))) (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) #0) "'and' requires >=1 clauses." "Short-circuiting 'and': (and #1 #0 #1) ## => #0"] [or (if (~ pre) #1 (~ post)) "'or' requires >=1 clauses." "Short-circuiting 'or': (or #1 #0 #1) ## => #1"]) (def: (index-of part text) (-> Text Text (Maybe Nat)) ("lux text index" 0 part text)) (def: (last-index-of' part part-size since text) (-> Text Nat Nat Text (Maybe Nat)) (case ("lux text index" ("lux i64 +" part-size since) part text) #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" 0 part text) (#Some since) (last-index-of' part ("lux text size" part) since text) #None #None)) (def: (clip/1 from text) (-> Nat Text (Maybe Text)) (let [size ("lux text size" text)] (if (n/<= size from) (#.Some ("lux text clip" from size text)) #.None))) (def: (clip/2 from to text) (-> Nat Nat Text (Maybe Text)) (if (and (n/<= to from) (n/<= ("lux text size" text) to)) (#.Some ("lux text clip" from to text)) #.None)) (def: #export (error! message) {#.doc (text$ ($_ "lux text concat" "## Causes an error, with the given error message." ..new-line "(error! ''OH NO!'')"))} (-> Text Nothing) ("lux io error" message)) (macro: (default tokens state) {#.doc (text$ ($_ "lux text concat" "## Allows you to provide a default value that will be used" ..new-line "## if a (Maybe x) value turns out to be #.None." __paragraph "(default +20 (#.Some +10)) ## => +10" __paragraph "(default +20 #.None) ## => +20"))} (case tokens (^ (list else maybe)) (let [g!temp (: Code [dummy-cursor (#Identifier ["" ""])]) code (` (case (~ maybe) (#.Some (~ g!temp)) (~ g!temp) #.None (~ else)))] (#Right [state (list code)])) _ (#Left "Wrong syntax for default"))) (def: (text@split-all-with splitter input) (-> Text Text (List Text)) (case (index-of splitter input) #None (list input) (#Some idx) (list& ("lux text clip" 0 idx input) (text@split-all-with splitter ("lux text clip" ("lux i64 +" 1 idx) ("lux text size" input) input))))) (def: (nth idx xs) (All [a] (-> Nat (List a) (Maybe a))) (case xs #Nil #None (#Cons x xs') (if ("lux i64 =" 0 idx) (#Some x) (nth ("lux i64 -" 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)) (#Parameter idx) (case (nth idx env) (#Some parameter) parameter _ 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 maybe-monad [type-fn* (apply-type F A)] (apply-type type-fn* param)) (#Named name type) (apply-type type param) _ #None)) (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 maybe-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 meta-monad [module-name current-module-name] (find-module module-name))) (def: (resolve-tag [module name]) (-> Name (Meta [Nat (List Name) Bit Type])) (do meta-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: " (name@encode [module name])))))) (def: (resolve-type-tags type) (-> Type (Meta (Maybe [(List Name) (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 meta-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 (structure tokens) {#.doc "Not meant to be used directly. Prefer 'structure:'."} (do meta-monad [tokens' (monad@map meta-monad macro-expand tokens) struct-type get-expected-type tags+type (resolve-type-tags struct-type) tags (: (Meta (List Name)) (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 meta-monad (: (-> Code (Meta [Code Code])) (function (_ token) (case token (^ [_ (#Form (list [_ (#Text "lux def")] [_ (#Identifier "" tag-name)] value meta [_ (#Bit #0)]))]) (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-with separator parts) (-> Text (List Text) Text) (case parts #Nil "" (#Cons head tail) (list@fold (function (_ right left) ($_ text@compose left separator right)) head tail))) (macro: #export (structure: tokens) {#.doc (text$ ($_ "lux text concat" "## Definition of structures ala ML." ..new-line "(structure: #export order (Order Int)" ..new-line " (def: &equivalence equivalence)" ..new-line " (def: (< test subject)" ..new-line " (< test subject))" ..new-line " (def: (<= test subject)" ..new-line " (or (< test subject)" ..new-line " (= test subject)))" ..new-line " (def: (> test subject)" ..new-line " (> test subject))" ..new-line " (def: (>= test subject)" ..new-line " (or (> test subject)" ..new-line " (= 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]) (let [usage (case args #Nil name _ (` ((~ name) (~+ args))))] (return (list (` (..def: (~+ (export exported?)) (~ usage) (~ (meta-code-merge (` {#.struct? #1}) meta)) (~ type) (structure (~+ definitions))))))) #None (fail "Wrong syntax for structure:")))) (def: (function@identity x) (All [a] (-> a a)) x) (macro: #export (type: tokens) {#.doc (text$ ($_ "lux text concat" "## The type-definition macro." ..new-line "(type: (List a) #Nil (#Cons a (List a)))"))} (let [[exported? tokens'] (export^ tokens) [rec? tokens'] (case tokens' (#Cons [_ (#Tag [_ "rec"])] tokens') [#1 tokens'] _ [#0 tokens']) parts (: (Maybe [Text (List Code) (List [Code Code]) (List Code)]) (case tokens' (^ (list [_ (#Identifier "" name)] [meta-cursor (#Record meta-parts)] [type-cursor (#Record type-parts)])) (#Some [name #Nil meta-parts (list [type-cursor (#Record type-parts)])]) (^ (list& [_ (#Identifier "" name)] [meta-cursor (#Record meta-parts)] type-code1 type-codes)) (#Some [name #Nil meta-parts (#Cons type-code1 type-codes)]) (^ (list& [_ (#Identifier "" name)] type-codes)) (#Some [name #Nil (list) type-codes]) (^ (list [_ (#Form (#Cons [_ (#Identifier "" name)] args))] [meta-cursor (#Record meta-parts)] [type-cursor (#Record type-parts)])) (#Some [name args meta-parts (list [type-cursor (#Record type-parts)])]) (^ (list& [_ (#Form (#Cons [_ (#Identifier "" name)] args))] [meta-cursor (#Record meta-parts)] type-code1 type-codes)) (#Some [name args meta-parts (#Cons type-code1 type-codes)]) (^ (list& [_ (#Form (#Cons [_ (#Identifier "" name)] args))] type-codes)) (#Some [name args (list) type-codes]) _ #None))] (case parts (#Some name args meta type-codes) (do meta-monad [type+tags?? (unfold-type-def type-codes) module-name current-module-name] (let [type-name (local-identifier$ name) [type tags??] type+tags?? type' (: (Maybe Code) (if rec? (if (empty? args) (let [g!param (local-identifier$ "") prime-name (local-identifier$ 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))))))) total-meta (let [meta (process-def-meta meta) meta (if rec? (` (#.Cons (~ (flag-meta "type-rec?")) (~ meta))) meta)] (` [(~ cursor-code) (#.Record (~ meta))]))] (case type' (#Some type'') (let [typeC (` (#.Named [(~ (text$ module-name)) (~ (text$ name))] (.type (~ type''))))] (return (list (case tags?? (#Some tags) (` ("lux def type tagged" (~ type-name) (~ typeC) (~ total-meta) [(~+ (list@map text$ tags))] (~ (bit$ exported?)))) _ (` ("lux def" (~ type-name) ("lux check type" (~ typeC)) (~ total-meta) (~ (bit$ exported?)))))))) #None (fail "Wrong syntax for type:")))) #None (fail "Wrong syntax for type:")) )) (template [ ] [(def: #export ( value) (-> (I64 Any) ) (:coerce value))] [i64 I64] [nat Nat] [int Int] [rev Rev] ) (type: Referrals #All (#Only (List Text)) (#Exclude (List Text)) #Ignore #Nothing) (type: Openings [Text (List Text)]) (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 meta-monad (: (-> Code (Meta Text)) (function (_ def) (case def [_ (#Identifier ["" name])] (return name) _ (fail "only/exclude requires identifiers.")))) defs)) (def: (parse-referrals tokens) (-> (List Code) (Meta [Referrals (List Code)])) (case tokens (^or (^ (list& [_ (#Form (list& [_ (#Tag ["" "+"])] defs))] tokens')) (^ (list& [_ (#Form (list& [_ (#Tag ["" "only"])] defs))] tokens'))) (do meta-monad [defs' (extract-defs defs)] (return [(#Only defs') tokens'])) (^or (^ (list& [_ (#Form (list& [_ (#Tag ["" "-"])] defs))] tokens')) (^ (list& [_ (#Form (list& [_ (#Tag ["" "exclude"])] defs))] tokens'))) (do meta-monad [defs' (extract-defs defs)] (return [(#Exclude defs') tokens'])) (^or (^ (list& [_ (#Tag ["" "*"])] tokens')) (^ (list& [_ (#Tag ["" "all"])] tokens'))) (return [#All tokens']) (^or (^ (list& [_ (#Tag ["" "_"])] tokens')) (^ (list& [_ (#Tag ["" "nothing"])] tokens'))) (return [#Ignore tokens']) _ (return [#Nothing tokens]))) (def: (parse-openings parts) (-> (List Code) (Meta [(List Openings) (List Code)])) (case parts #.Nil (return [#.Nil #.Nil]) (^ (list& [_ (#Form (list& [_ (#Text prefix)] structs))] parts')) (do meta-monad [structs' (monad@map meta-monad (function (_ struct) (case struct [_ (#Identifier ["" struct-name])] (return struct-name) _ (fail "Expected all structures of opening form to be identifiers."))) structs) next+remainder (parse-openings parts')] (let [[next remainder] next+remainder] (return [(#.Cons [prefix structs'] next) remainder]))) _ (return [#.Nil parts]))) (def: (split! at x) (-> Nat Text [Text Text]) [("lux text clip" 0 at x) ("lux text clip" at ("lux text size" x) x)]) (def: (split-with token sample) (-> Text Text (Maybe [Text Text])) (do ..maybe-monad [index (..index-of token sample) #let [[pre post'] (split! index sample) [_ post] (split! ("lux text size" token) post')]] (wrap [pre post]))) (def: (replace-all pattern value template) (-> Text Text Text Text) (case (..split-with pattern template) (#.Some [pre post]) ($_ "lux text concat" pre value (replace-all pattern value post)) #.None template)) (def: contextual-reference "#") (def: self-reference ".") (def: (de-alias context self aliased) (-> Text Text Text Text) (|> aliased (replace-all ..self-reference self) (replace-all ..contextual-reference context))) (def: #export module-separator "/") (def: (count-relatives relatives input) (-> Nat Text Nat) (case ("lux text index" relatives ..module-separator input) #None relatives (#Some found) (if ("lux i64 =" relatives found) (count-relatives ("lux i64 +" 1 relatives) input) relatives))) (def: (list@take amount list) (All [a] (-> Nat (List a) (List a))) (case [amount list] (^or [0 _] [_ #Nil]) #Nil [_ (#Cons head tail)] (#Cons head (list@take ("lux i64 -" 1 amount) tail)))) (def: (list@drop amount list) (All [a] (-> Nat (List a) (List a))) (case [amount list] (^or [0 _] [_ #Nil]) list [_ (#Cons _ tail)] (list@drop ("lux i64 -" 1 amount) tail))) (def: (clean-module nested? relative-root module) (-> Bit Text Text (Meta Text)) (case (count-relatives 0 module) 0 (return (if nested? ($_ "lux text concat" relative-root ..module-separator module) module)) relatives (let [parts (text@split-all-with ..module-separator relative-root) jumps ("lux i64 -" 1 relatives)] (if (n/< (list@size parts) jumps) (let [prefix (|> parts list@reverse (list@drop jumps) list@reverse (interpose ..module-separator) (text@join-with "")) clean ("lux text clip" relatives ("lux text size" module) module) output (case ("lux text size" clean) 0 prefix _ ($_ text@compose prefix ..module-separator clean))] (return output)) (fail ($_ "lux text concat" "Cannot climb the module hierarchy..." ..new-line "Importing module: " module ..new-line " Relative Root: " relative-root ..new-line)))))) (def: (alter-domain alteration domain import) (-> Nat Text Importation Importation) (let [[import-name import-alias import-refer] import original (text@split-all-with ..module-separator import-name) truncated (list@drop (.nat alteration) original) parallel (case domain "" truncated _ (list& domain truncated))] {#import-name (text@join-with ..module-separator parallel) #import-alias import-alias #import-refer import-refer})) (def: (parse-imports nested? relative-root context-alias imports) (-> Bit Text Text (List Code) (Meta (List Importation))) (do meta-monad [imports' (monad@map meta-monad (: (-> Code (Meta (List Importation))) (function (_ token) (case token ## Simple [_ (#Identifier ["" m-name])] (do meta-monad [m-name (clean-module nested? relative-root m-name)] (wrap (list {#import-name m-name #import-alias #None #import-refer {#refer-defs #All #refer-open (list)}}))) ## Nested (^ [_ (#Tuple (list& [_ (#Identifier ["" m-name])] extra))]) (do meta-monad [import-name (clean-module nested? relative-root m-name) referral+extra (parse-referrals extra) #let [[referral extra] referral+extra] openings+extra (parse-openings extra) #let [[openings extra] openings+extra] sub-imports (parse-imports #1 import-name context-alias extra)] (wrap (case [referral openings] [#Nothing #Nil] sub-imports _ (list& {#import-name import-name #import-alias #None #import-refer {#refer-defs referral #refer-open openings}} sub-imports)))) (^ [_ (#Tuple (list& [_ (#Text alias)] [_ (#Identifier ["" m-name])] extra))]) (do meta-monad [import-name (clean-module nested? relative-root m-name) referral+extra (parse-referrals extra) #let [[referral extra] referral+extra] openings+extra (parse-openings extra) #let [[openings extra] openings+extra de-aliased (de-alias context-alias m-name alias)] sub-imports (parse-imports #1 import-name de-aliased extra)] (wrap (case [referral openings] [#Ignore #Nil] sub-imports _ (list& {#import-name import-name #import-alias (#Some de-aliased) #import-refer {#refer-defs referral #refer-open openings}} sub-imports)))) ## Parallel (^ [_ (#Record (list [[_ (#Tuple (list [_ (#Nat alteration)] [_ (#Tag ["" domain])]))] parallel-tree]))]) (do meta-monad [parallel-imports (parse-imports nested? relative-root context-alias (list parallel-tree))] (wrap (list@map (alter-domain alteration domain) parallel-imports))) (^ [_ (#Record (list [[_ (#Nat alteration)] parallel-tree]))]) (do meta-monad [parallel-imports (parse-imports nested? relative-root context-alias (list parallel-tree))] (wrap (list@map (alter-domain alteration "") parallel-imports))) (^ [_ (#Record (list [[_ (#Tag ["" domain])] parallel-tree]))]) (do meta-monad [parallel-imports (parse-imports nested? relative-root context-alias (list parallel-tree)) #let [alteration (list@size (text@split-all-with ..module-separator domain))]] (wrap (list@map (alter-domain alteration domain) parallel-imports))) _ (do meta-monad [current-module current-module-name] (fail ($_ text@compose "Wrong syntax for import @ " current-module ..new-line (code@encode token))))))) imports)] (wrap (list@join imports')))) (def: (exported-definitions module state) (-> Text (Meta (List Text))) (let [[current-module modules] (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} [current-module modules])] (case (get module modules) (#Some =module) (let [to-alias (list@map (: (-> [Text Global] (List Text)) (function (_ [name definition]) (case definition (#Left _) (list) (#Right [exported? def-type def-meta def-value]) (if exported? (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: " (text@encode module) ..new-line "Current module: " (case current-module (#Some current-module) (text@encode current-module) #None "???") ..new-line "Known modules: " (|> modules (list@map (function (_ [name module]) (text$ name))) tuple$ code@encode)))) )) (def: (filter p xs) (All [a] (-> (-> a Bit) (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 Bit) (let [output (list@fold (function (_ case prev) (or prev (text@= case name))) #0 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) (-> Name 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 definition) (case definition (#Left de-aliased) (find-def-type de-aliased state) (#Right [exported? def-type def-meta def-value]) (#Some def-type)))))) (def: (find-def-value name state) (-> Name (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: " (name@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: " (name@encode name))) (#Some definition) (case definition (#Left de-aliased) (find-def-value de-aliased state) (#Right [exported? 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 ("lux i64 =" idx var) bound (find-type-var idx bindings')))) (def: (find-type full-name) (-> Name (Meta Type)) (do meta-monad [#let [[module name] full-name] 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: " (name@encode full-name))))) (case (find-def-type full-name compiler) (#Some struct-type) (#Right [compiler struct-type]) _ (#Left ($_ text@compose "Unknown var: " (name@encode full-name)))))] (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@encode type) (-> Type Text) (case type (#Primitive name params) (case params #Nil name _ ($_ text@compose "(" name " " (|> params (list@map type@encode) (interpose " ") list@reverse (list@fold text@compose "")) ")")) (#Sum _) ($_ text@compose "(| " (|> (flatten-variant type) (list@map type@encode) (interpose " ") list@reverse (list@fold text@compose "")) ")") (#Product _) ($_ text@compose "[" (|> (flatten-tuple type) (list@map type@encode) (interpose " ") list@reverse (list@fold text@compose "")) "]") (#Function _) ($_ text@compose "(-> " (|> (flatten-lambda type) (list@map type@encode) (interpose " ") list@reverse (list@fold text@compose "")) ")") (#Parameter 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@encode body) ")") (#ExQ env body) ($_ text@compose "(Ex " (type@encode body) ")") (#Apply _) (let [[func args] (flatten-app type)] ($_ text@compose "(" (type@encode func) " " (|> args (list@map type@encode) (interpose " ") list@reverse (list@fold text@compose "")) ")")) (#Named name _) (name@encode name) )) (macro: #export (^open tokens) {#.doc (text$ ($_ "lux text concat" "## Same as the 'open' macro, but meant to be used as a pattern-matching macro for generating local bindings." ..new-line "## Takes an 'alias' text for the generated local bindings." ..new-line "(def: #export (range (^open ''.'') from to)" ..new-line " (All [a] (-> (Enum a) a a (List a)))" ..new-line " (range' <= succ from to))"))} (case tokens (^ (list& [_ (#Form (list [_ (#Text alias)]))] body branches)) (do meta-monad [g!temp (gensym "temp")] (wrap (list& g!temp (` (..^open (~ g!temp) (~ (text$ alias)) (~ body))) branches))) (^ (list [_ (#Identifier name)] [_ (#Text alias)] body)) (do meta-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@encode init-type))) (#Some tags&members) (do meta-monad [full-body ((: (-> Name [(List Name) (List Type)] Code (Meta Code)) (function (recur source [tags members] target) (let [locals (list@map (function (_ [t-module t-name]) ["" (de-alias "" t-name alias)]) tags) pattern (tuple$ (list@map identifier$ locals))] (do meta-monad [enhanced-target (monad@fold meta-monad (function (_ [m-local m-type] enhanced-target) (do meta-monad [m-structure (resolve-type-tags m-type)] (case m-structure (#Some m-tags&members) (recur m-local m-tags&members enhanced-target) #None (wrap enhanced-target)))) target (zip2 locals members))] (wrap (` ({(~ pattern) (~ enhanced-target)} (~ (identifier$ source))))))))) name tags&members body)] (wrap (list full-body))))) _ (fail "Wrong syntax for ^open"))) (macro: #export (cond tokens) {#.doc (text$ ($_ "lux text concat" "## Branching structures with multiple test conditions." ..new-line "(cond (even? num) ''even''" ..new-line " (odd? num) ''odd''" __paragraph " ## else-branch" ..new-line " ''???'')"))} (if ("lux i64 =" 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' ("lux i64 +" 1 idx) xs')) #Nil #Nil)) (def: (enumerate xs) (All [a] (-> (List a) (List [Nat a]))) (enumerate' 0 xs)) (macro: #export (get@ tokens) {#.doc (text$ ($_ "lux text concat" "## Accesses the value of a record at a given tag." ..new-line "(get@ #field my-record)" __paragraph "## Can also work with multiple levels of nesting:" ..new-line "(get@ [#foo #bar #baz] my-record)" __paragraph "## And, if only the slot/path is given, generates an accessor function:" ..new-line "(let [getter (get@ [#foo #bar #baz])]" ..new-line " (getter my-record))"))} (case tokens (^ (list [_ (#Tag slot')] record)) (do meta-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 (: (-> [Name [Nat Type]] [Code Code]) (function (_ [[r-prefix r-name] [r-idx r-type]]) [(tag$ [r-prefix r-name]) (if ("lux i64 =" idx r-idx) g!output g!_)])) (zip2 tags (enumerate members))))] (return (list (` ({(~ pattern) (~ g!output)} (~ record)))))) _ (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 meta-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 alias tags my-tag-index [module short] source type) (-> Text (List Name) Nat Name Code Type (Meta (List Code))) (do meta-monad [output (resolve-type-tags type) g!_ (gensym "g!_") #let [g!output (local-identifier$ short) pattern (|> tags enumerate (list@map (function (_ [tag-idx tag]) (if ("lux i64 =" my-tag-index tag-idx) g!output g!_))) tuple$) source+ (` ({(~ pattern) (~ g!output)} (~ source)))]] (case output (#Some [tags' members']) (do meta-monad [decls' (monad@map meta-monad (: (-> [Nat Name Type] (Meta (List Code))) (function (_ [sub-tag-index sname stype]) (open-field alias tags' sub-tag-index sname source+ stype))) (enumerate (zip2 tags' members')))] (return (list@join decls'))) _ (return (list (` ("lux def" (~ (local-identifier$ (de-alias "" short alias))) (~ source+) [(~ cursor-code) (#.Record #Nil)] #0))))))) (macro: #export (open: tokens) {#.doc (text$ ($_ "lux text concat" "## Opens a structure and generates a definition for each of its members (including nested members)." __paragraph "## For example:" ..new-line "(open: ''i:.'' number)" __paragraph "## Will generate:" ..new-line "(def: i:+ (:: number +))" ..new-line "(def: i:- (:: number -))" ..new-line "(def: i:* (:: number *))" ..new-line "..."))} (case tokens (^ (list [_ (#Text alias)] struct)) (case struct [_ (#Identifier struct-name)] (do meta-monad [struct-type (find-type struct-name) output (resolve-type-tags struct-type) #let [source (identifier$ struct-name)]] (case output (#Some [tags members]) (do meta-monad [decls' (monad@map meta-monad (: (-> [Nat Name Type] (Meta (List Code))) (function (_ [tag-index sname stype]) (open-field alias tags tag-index sname source stype))) (enumerate (zip2 tags members)))] (return (list@join decls'))) _ (fail (text@compose "Can only 'open:' structs: " (type@encode struct-type))))) _ (do meta-monad [g!struct (gensym "struct")] (return (list (` ("lux def" (~ g!struct) (~ struct) [(~ cursor-code) (#.Record #Nil)] #0)) (` (..open: (~ (text$ alias)) (~ g!struct))))))) _ (fail "Wrong syntax for open:"))) (macro: #export (|>> tokens) {#.doc (text$ ($_ "lux text concat" "## Similar to the piping macro, but rather than taking an initial object to work on, creates a function for taking it." ..new-line "(|>> (list@map int@encode) (interpose '' '') (fold text@compose ''''))" ..new-line "## =>" ..new-line "(function (_ ) (fold text@compose '''' (interpose '' '' (list@map int@encode ))))"))} (do meta-monad [g!_ (gensym "_") g!arg (gensym "arg")] (return (list (` (function ((~ g!_) (~ g!arg)) (|> (~ g!arg) (~+ tokens)))))))) (macro: #export (<<| tokens) {#.doc (text$ ($_ "lux text concat" "## Similar to the piping macro, but rather than taking an initial object to work on, creates a function for taking it." ..new-line "(<<| (fold text@compose '''') (interpose '' '') (list@map int@encode))" ..new-line "## =>" ..new-line "(function (_ ) (fold text@compose '''' (interpose '' '' (list@map int@encode ))))"))} (do meta-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 Bit)) (do meta-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 meta-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] (case options #Nil (wrap {#refer-defs referral #refer-open openings}) _ (fail ($_ text@compose "Wrong syntax for refer @ " current-module ..new-line (|> options (list@map code@encode) (interpose " ") (list@fold text@compose ""))))))) (def: (write-refer module-name [r-defs r-opens]) (-> Text Refer (Meta (List Code))) (do meta-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 meta-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 meta-monad [*defs (exported-definitions module-name) _ (test-referrals module-name *defs +defs)] (wrap +defs)) (#Exclude -defs) (do meta-monad [*defs (exported-definitions module-name) _ (test-referrals module-name *defs -defs)] (wrap (filter (|>> (is-member? -defs) not) *defs))) #Ignore (wrap (list)) #Nothing (wrap (list))) #let [defs (list@map (: (-> Text Code) (function (_ def) (` ("lux def alias" (~ (local-identifier$ def)) (~ (identifier$ [module-name def])))))) defs') openings (join-map (: (-> Openings (List Code)) (function (_ [alias structs]) (list@map (function (_ name) (` (open: (~ (text$ alias)) (~ (identifier$ [module-name name]))))) structs))) r-opens)]] (wrap (list@compose defs openings)) )) (macro: #export (refer tokens) (case tokens (^ (list& [_ (#Text module-name)] options)) (do meta-monad [=refer (read-refer module-name options)] (write-refer module-name =refer)) _ (fail "Wrong syntax for refer"))) (def: (refer-to-code module-name module-alias' [r-defs r-opens]) (-> Text (Maybe Text) Refer Code) (let [module-alias (..default module-name module-alias') localizations (: (List Code) (case r-defs #All (list (' #*)) (#Only defs) (list (form$ (list& (' #+) (list@map local-identifier$ defs)))) (#Exclude defs) (list (form$ (list& (' #-) (list@map local-identifier$ defs)))) #Ignore (list) #Nothing (list))) openings (list@map (function (_ [alias structs]) (form$ (list& (text$ (..replace-all ..contextual-reference module-alias alias)) (list@map local-identifier$ structs)))) r-opens)] (` (..refer (~ (text$ module-name)) (~+ localizations) (~+ openings))))) (macro: #export (module: tokens) {#.doc (text$ ($_ "lux text concat" "## Module-definition macro." __paragraph "## Can take optional annotations and allows the specification of modules to import." __paragraph "## Example" ..new-line "(.module: {#.doc ''Some documentation...''}" ..new-line " [lux #*" ..new-line " [control" ..new-line " [''M'' monad #*]]" ..new-line " [data" ..new-line " maybe" ..new-line " [''.'' name (''#/.'' codec)]]" ..new-line " [macro" ..new-line " code]]" ..new-line " [//" ..new-line " [type (''.'' equivalence)]])"))} (do meta-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 #0 current-module "" _imports) #let [=imports (|> imports (list@map (: (-> Importation Code) (function (_ [m-name m-alias =refer]) (` [(~ (text$ m-name)) (~ (text$ (default "" m-alias)))])))) tuple$) =refers (list@map (: (-> Importation Code) (function (_ [m-name m-alias =refer]) (refer-to-code m-name m-alias =refer))) imports) =module (` ("lux def module" [(~ cursor-code) (#.Record (~ (process-def-meta _meta)))] (~ =imports)))]] (wrap (#Cons =module =refers)))) (macro: #export (:: tokens) {#.doc (text$ ($_ "lux text concat" "## Allows accessing the value of a structure's member." ..new-line "(:: codec encode)" __paragraph "## Also allows using that value as a function." ..new-line "(:: codec encode +123)"))} (case tokens (^ (list struct [_ (#Identifier member)])) (return (list (` (let [(^open ".") (~ struct)] (~ (identifier$ member)))))) (^ (list& struct [_ (#Identifier member)] args)) (return (list (` ((let [(^open ".") (~ struct)] (~ (identifier$ member))) (~+ args))))) _ (fail "Wrong syntax for ::"))) (macro: #export (set@ tokens) {#.doc (text$ ($_ "lux text concat" "## Sets the value of a record at a given tag." ..new-line "(set@ #name ''Lux'' lang)" __paragraph "## Can also work with multiple levels of nesting:" ..new-line "(set@ [#foo #bar #baz] value my-record)" __paragraph "## And, if only the slot/path and (optionally) the value are given, generates a mutator function:" ..new-line "(let [setter (set@ [#foo #bar #baz] value)] (setter my-record))" ..new-line "(let [setter (set@ [#foo #bar #baz])] (setter value my-record))"))} (case tokens (^ (list [_ (#Tag slot')] value record)) (do meta-monad [slot (normalize slot') output (resolve-tag slot) #let [[idx tags exported? type] output]] (case (resolve-struct-type type) (#Some members) (do meta-monad [pattern' (monad@map meta-monad (: (-> [Name [Nat Type]] (Meta [Name Nat Code])) (function (_ [r-slot-name [r-idx r-type]]) (do meta-monad [g!slot (gensym "")] (return [r-slot-name r-idx g!slot])))) (zip2 tags (enumerate members)))] (let [pattern (record$ (list@map (: (-> [Name Nat Code] [Code Code]) (function (_ [r-slot-name r-idx r-var]) [(tag$ r-slot-name) r-var])) pattern')) output (record$ (list@map (: (-> [Name Nat Code] [Code Code]) (function (_ [r-slot-name r-idx r-var]) [(tag$ r-slot-name) (if ("lux i64 =" idx r-idx) value r-var)])) pattern'))] (return (list (` ({(~ pattern) (~ output)} (~ record))))))) _ (fail "set@ can only use records."))) (^ (list [_ (#Tuple slots)] value record)) (case slots #Nil (fail "Wrong syntax for set@") _ (do meta-monad [bindings (monad@map meta-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 meta-monad [g!_ (gensym "_") g!record (gensym "record")] (wrap (list (` (function ((~ g!_) (~ g!record)) (..set@ (~ selector) (~ value) (~ g!record))))))) (^ (list selector)) (do meta-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 (text$ ($_ "lux text concat" "## Modifies the value of a record at a given tag, based on some function." ..new-line "(update@ #age inc person)" __paragraph "## Can also work with multiple levels of nesting:" ..new-line "(update@ [#foo #bar #baz] func my-record)" __paragraph "## And, if only the slot/path and (optionally) the value are given, generates a mutator function:" ..new-line "(let [updater (update@ [#foo #bar #baz] func)] (updater my-record))" ..new-line "(let [updater (update@ [#foo #bar #baz])] (updater func my-record))"))} (case tokens (^ (list [_ (#Tag slot')] fun record)) (do meta-monad [slot (normalize slot') output (resolve-tag slot) #let [[idx tags exported? type] output]] (case (resolve-struct-type type) (#Some members) (do meta-monad [pattern' (monad@map meta-monad (: (-> [Name [Nat Type]] (Meta [Name Nat Code])) (function (_ [r-slot-name [r-idx r-type]]) (do meta-monad [g!slot (gensym "")] (return [r-slot-name r-idx g!slot])))) (zip2 tags (enumerate members)))] (let [pattern (record$ (list@map (: (-> [Name Nat Code] [Code Code]) (function (_ [r-slot-name r-idx r-var]) [(tag$ r-slot-name) r-var])) pattern')) output (record$ (list@map (: (-> [Name Nat Code] [Code Code]) (function (_ [r-slot-name r-idx r-var]) [(tag$ r-slot-name) (if ("lux i64 =" idx r-idx) (` ((~ fun) (~ r-var))) r-var)])) pattern'))] (return (list (` ({(~ pattern) (~ output)} (~ record))))))) _ (fail "update@ can only use records."))) (^ (list [_ (#Tuple slots)] fun record)) (case slots #Nil (fail "Wrong syntax for update@") _ (do meta-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 meta-monad [g!_ (gensym "_") g!record (gensym "record")] (wrap (list (` (function ((~ g!_) (~ g!record)) (..update@ (~ selector) (~ fun) (~ g!record))))))) (^ (list selector)) (do meta-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 (text$ ($_ "lux text concat" "## It's similar to template, but meant to be used during pattern-matching." ..new-line "(def: (beta-reduce env type)" ..new-line " (-> (List Type) Type Type)" ..new-line " (case type" ..new-line " (#.Primitive name params)" ..new-line " (#.Primitive name (list@map (beta-reduce env) params))" __paragraph " (^template []" ..new-line " ( left right)" ..new-line " ( (beta-reduce env left) (beta-reduce env right)))" ..new-line " ([#.Sum] [#.Product])" __paragraph " (^template []" ..new-line " ( left right)" ..new-line " ( (beta-reduce env left) (beta-reduce env right)))" ..new-line " ([#.Function] [#.Apply])" __paragraph " (^template []" ..new-line " ( old-env def)" ..new-line " (case old-env" ..new-line " #.Nil" ..new-line " ( env def)" __paragraph " _" ..new-line " type))" ..new-line " ([#.UnivQ] [#.ExQ])" __paragraph " (#.Parameter idx)" ..new-line " (default type (list.nth idx env))" __paragraph " _" ..new-line " type" ..new-line " ))"))} (case tokens (^ (list& [_ (#Form (list& [_ (#Tuple bindings)] templates))] [_ (#Form data)] branches)) (case (: (Maybe (List Code)) (do maybe-monad [bindings' (monad@map maybe-monad get-short bindings) data' (monad@map maybe-monad tuple->list data)] (let [num-bindings (list@size bindings')] (if (every? (|>> ("lux i64 =" num-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"))) (def: (find-baseline-column code) (-> Code Nat) (case code (^template [] [[_ _ column] ( _)] column) ([#Bit] [#Nat] [#Int] [#Rev] [#Frac] [#Text] [#Identifier] [#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))) (template [ ] [(def: #export {#.doc } (All [s] (-> (I64 s) (I64 s))) (|>> ( 1)))] [inc "lux i64 +" "Increment function."] [dec "lux i64 -" "Decrement function."] ) (def: tag@encode (-> Name Text) (|>> name@encode (text@compose "#"))) (def: (repeat n x) (All [a] (-> Int a (List a))) (if ("lux i64 <" n +0) (#Cons x (repeat ("lux i64 +" -1 n) x)) #Nil)) (def: (cursor-padding baseline [_ old-line old-column] [_ new-line new-column]) (-> Nat Cursor Cursor Text) (if ("lux i64 =" old-line new-line) (text@join-with "" (repeat (.int ("lux i64 -" old-column new-column)) " ")) (let [extra-lines (text@join-with "" (repeat (.int ("lux i64 -" old-line new-line)) ..new-line)) space-padding (text@join-with "" (repeat (.int ("lux i64 -" 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 ("lux i64 +" 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)])) ([#Bit bit@encode] [#Nat nat@encode] [#Int int@encode] [#Frac frac@encode] [#Text text@encode] [#Identifier name@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 "(" ")" ..function@identity] [#Tuple "[" "]" ..function@identity] [#Record "{" "}" rejoin-all-pairs]) [new-cursor (#Rev 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-all-with ..new-line) (list@map (function (_ line) ($_ text@compose "## " line ..new-line))) (text@join-with "")) (#Doc-Example example) (let [baseline (find-baseline-column example) [cursor _] example [_ text] (doc-example->Text (with-baseline baseline cursor) baseline example)] (text@compose text __paragraph)))) (macro: #export (doc tokens) {#.doc (text$ ($_ "lux text concat" "## Creates code documentation, embedding text as comments and properly formatting the forms it's being given." __paragraph "## For Example:" ..new-line "(doc ''Allows arbitrary looping, using the 'recur' form to re-start the loop.''" ..new-line " ''Can be used in monadic code to create monadic loops.''" ..new-line " (loop [count +0" ..new-line " x init]" ..new-line " (if (< +10 count)" ..new-line " (recur (inc count) (f x))" ..new-line " x)))"))} (return (list (` [(~ cursor-code) (#.Text (~ (|> tokens (list@map (|>> identify-doc-fragment doc-fragment->Text)) (text@join-with "") 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] [#.Apply]) (^template [] ( id) (` ( (~ (nat$ id))))) ([#.Parameter] [#.Var] [#.Ex]) (^template [] ( env type) (let [env' (untemplate-list (list@map type-to-code env))] (` ( (~ env') (~ (type-to-code type)))))) ([#.UnivQ] [#.ExQ]) (#Named [module name] anonymous) ## TODO: Generate the explicit type definition instead of using ## the "identifier$" shortcut below. ## (` (#.Named [(~ (text$ module)) (~ (text$ name))] ## (~ (type-to-code anonymous)))) (identifier$ [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 [(local-identifier$ "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? identifier? inits) (do meta-monad [inits' (: (Meta (List Name)) (case (monad@map maybe-monad get-name inits) (#Some inits') (return inits') #None (fail "Wrong syntax for loop"))) init-types (monad@map meta-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 meta-monad [aliases (monad@map meta-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 meta-monad [slots (: (Meta [Name (List Name)]) (case (: (Maybe [Name (List Name)]) (do maybe-monad [hslot (get-tag hslot') tslots (monad@map maybe-monad get-tag tslots')] (wrap [hslot tslots]))) (#Some slots) (return slots) #None (fail "Wrong syntax for ^slots"))) #let [[hslot tslots] slots] hslot (normalize hslot) tslots (monad@map meta-monad normalize tslots) output (resolve-tag hslot) g!_ (gensym "_") #let [[idx tags exported? type] output slot-pairings (list@map (: (-> Name [Text Code]) (function (_ [module name]) [name (local-identifier$ name)])) (list& hslot tslots)) pattern (record$ (list@map (: (-> Name [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 [_ (#Bit _)] [_ (#Nat _)] [_ (#Int _)] [_ (#Rev _)] [_ (#Frac _)] [_ (#Text _)] [_ (#Tag _)]) (#Some (list target)) [_ (#Identifier [prefix name])] (if (and (text@= "" prefix) (text@= label name)) (#Some tokens) (#Some (list target))) (^template [] [cursor ( elems)] (do maybe-monad [placements (monad@map maybe-monad (place-tokens label tokens) elems)] (wrap (list [cursor ( (list@join placements))])))) ([#Tuple] [#Form]) [cursor (#Record pairs)] (do maybe-monad [=pairs (monad@map maybe-monad (: (-> [Code Code] (Maybe [Code Code])) (function (_ [slot value]) (do maybe-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 [cursor (#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 [ (template [ ] [(compare ) (compare (:: Code/encode encode )) (compare #1 (:: equivalence = ))] [(bit #1) "#1" [_ (#.Bit #1)]] [(bit #0) "#0" [_ (#.Bit #0)]] [(int +123) "+123" [_ (#.Int +123)]] [(frac +123.0) "+123.0" [_ (#.Frac +123.0)]] [(text "123") "'123'" [_ (#.Text "123")]] [(tag ["yolo" "lol"]) "#yolo.lol" [_ (#.Tag ["yolo" "lol"])]] [(identifier ["yolo" "lol"]) "yolo.lol" [_ (#.Identifier ["yolo" "lol"])]] [(form (list (bit #1) (int +123))) "(#1 +123)" (^ [_ (#.Form (list [_ (#.Bit #1)] [_ (#.Int +123)]))])] [(tuple (list (bit #1) (int +123))) "[#1 +123]" (^ [_ (#.Tuple (list [_ (#.Bit #1)] [_ (#.Int +123)]))])] [(record (list [(bit #1) (int +123)])) "{#1 +123}" (^ [_ (#.Record (list [[_ (#.Bit #1)] [_ (#.Int +123)]]))])] [(local-tag "lol") "#lol" [_ (#.Tag ["" "lol"])]] [(local-identifier "lol") "lol" [_ (#.Identifier ["" "lol"])]] )] (test-all ))))} (case tokens (^ (list& [_ (#Tuple bindings)] bodies)) (case bindings (^ (list& [_ (#Identifier ["" var-name])] macro-expr bindings')) (do meta-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) (["Bit"] ["Nat"] ["Int"] ["Rev"] ["Frac"] ["Text"]) (#Named _ type') (flatten-alias type') _ type)) (def: (anti-quote-def name) (-> Name (Meta Code)) (do meta-monad [type+value (find-def-value name) #let [[type value] type+value]] (case (flatten-alias type) (^template [ ] (#Named ["lux" ] _) (wrap ( (:coerce value)))) (["Bit" Bit bit$] ["Nat" Nat nat$] ["Int" Int int$] ["Rev" Rev rev$] ["Frac" Frac frac$] ["Text" Text text$]) _ (fail (text@compose "Cannot anti-quote type: " (name@encode name)))))) (def: (anti-quote token) (-> Code (Meta Code)) (case token [_ (#Identifier [def-prefix def-name])] (if (text@= "" def-prefix) (do meta-monad [current-module current-module-name] (anti-quote-def [current-module def-name])) (anti-quote-def [def-prefix def-name])) (^template [] [meta ( parts)] (do meta-monad [=parts (monad@map meta-monad anti-quote parts)] (wrap [meta ( =parts)]))) ([#Form] [#Tuple]) [meta (#Record pairs)] (do meta-monad [=pairs (monad@map meta-monad (: (-> [Code Code] (Meta [Code Code])) (function (_ [slot value]) (do meta-monad [=value (anti-quote value)] (wrap [slot =value])))) pairs)] (wrap [meta (#Record =pairs)])) _ (:: meta-monad return token) )) (macro: #export (static tokens) (case tokens (^ (list pattern)) (do meta-monad [pattern' (anti-quote pattern)] (wrap (list pattern'))) _ (fail "Wrong syntax for 'static'."))) (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 (` #1)]) )) (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 meta-monad [extras' (monad@map meta-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) (let [bind? (case pattern [_ (#.Identifier _)] #1 _ #0)] (` (case (~ calculation) (~ pattern) (~ success) (~+ (if bind? (list) (list 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) #1]) (match-uri endpoint? parts' uri') _ (#.Left (format "Static part " (%t static) " does not match URI: " uri))) "Short-cuts can be taken when using bit 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 meta-monad [mlc (multi-level-case^ levels) #let [initial-bind? (case mlc [[_ (#.Identifier _)] _] #1 _ #0)] expected get-expected-type g!temp (gensym "temp")] (let [output (list g!temp (` ({(#Some (~ g!temp)) (~ g!temp) #None (case (~ g!temp) (~+ next-branches))} ("lux check" (#.Apply (~ (type-to-code expected)) Maybe) (case (~ g!temp) (~+ (multi-level-case$ g!temp [mlc body])) (~+ (if initial-bind? (list) (list g!temp (` #.None)))))))))] (wrap output))) _ (fail "Wrong syntax for ^multi"))) ## TODO: Allow asking the compiler for the name of the definition ## currently being defined. That name can then be fed into ## 'wrong-syntax-error' for easier maintenance of the error-messages. (def: wrong-syntax-error (-> Name Text) (|>> name@encode (text@compose "Wrong syntax for "))) (macro: #export (name-of tokens) {#.doc (doc "Given an identifier or a tag, gives back a 2 tuple with the prefix and name parts, both as Text." (name-of #.doc) "=>" ["lux" "doc"])} (case tokens (^template [] (^ (list [_ ( [prefix name])])) (return (list (` [(~ (text$ prefix)) (~ (text$ name))])))) ([#Identifier] [#Tag]) _ (fail (..wrong-syntax-error ["lux" "name-of"])))) (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 ("lux i64 =" 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) (Row a))) (list@fold add (: (Row ($ 0)) empty) list)))} (case tokens (^ (list [_ (#Nat idx)])) (do meta-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-error (name-of ..$))))) (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 (+ +2 +3)))} (All [a] (-> a a Bit)) ("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) (+ (:: Hash hash elem) acc)) 0 (to-list set))))} (case tokens (^ (list& [_meta (#Form (list [_ (#Identifier ["" name])] pattern))] body branches)) (let [g!whole (local-identifier$ name)] (return (list& g!whole (` (case (~ g!whole) (~ pattern) (~ body))) branches))) _ (fail (..wrong-syntax-error (name-of ..^@))))) (macro: #export (^|> tokens) {#.doc (doc "Pipes the value being pattern-matched against prior to binding it to a variable." (case input (^|> value [inc (% 10) (max 1)]) (foo value)))} (case tokens (^ (list& [_meta (#Form (list [_ (#Identifier ["" name])] [_ (#Tuple steps)]))] body branches)) (let [g!name (local-identifier$ name)] (return (list& g!name (` (let [(~ g!name) (|> (~ g!name) (~+ steps))] (~ body))) branches))) _ (fail (..wrong-syntax-error (name-of ..^|>))))) (macro: #export (:assume tokens) {#.doc (doc "Coerces the given expression to the type of whatever is expected." (: Dinosaur (:assume (list +1 +2 +3))))} (case tokens (^ (list expr)) (do meta-monad [type get-expected-type] (wrap (list (` ("lux coerce" (~ (type-to-code type)) (~ expr)))))) _ (fail (..wrong-syntax-error (name-of ..:assume))))) (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-error (name-of ..undefined))))) (macro: #export (:of tokens) {#.doc (doc "Generates the type corresponding to a given expression." "Example #1:" (let [my-num +123] (:of my-num)) "==" Int "-------------------" "Example #2:" (:of +123) "==" Int)} (case tokens (^ (list [_ (#Identifier var-name)])) (do meta-monad [var-type (find-type var-name)] (wrap (list (type-to-code var-type)))) (^ (list expression)) (do meta-monad [g!temp (gensym "g!temp")] (wrap (list (` (let [(~ g!temp) (~ expression)] (..:of (~ g!temp))))))) _ (fail (..wrong-syntax-error (name-of ..:of))))) (def: (parse-complex-declaration tokens) (-> (List Code) (Meta [[Text (List Text)] (List Code)])) (case tokens (^ (list& [_ (#Form (list& [_ (#Identifier ["" name])] args'))] tokens')) (do meta-monad [args (monad@map meta-monad (function (_ arg') (case arg' [_ (#Identifier ["" 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 template and ^template." "For simple macros that do not need any fancy features." (template: (square x) (* x x)))} (do meta-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 (` ((~' ~) (~ (local-identifier$ arg))))]) args)] this-module current-module-name] (wrap (list (` (macro: (~+ (export export?)) ((~ (local-identifier$ name)) (~ g!tokens) (~ g!compiler)) (~ anns) (case (~ g!tokens) (^ (list (~+ (list@map local-identifier$ args)))) (#.Right [(~ g!compiler) (list (~+ (list@map (function (_ template) (` (`' (~ (replace-syntax rep-env template))))) input-templates)))]) (~ g!_) (#.Left (~ (text$ (..wrong-syntax-error [this-module name])))) ))))) )) (macro: #export (as-is tokens compiler) (#Right [compiler tokens])) (macro: #export (char tokens compiler) (case tokens (^multi (^ (list [_ (#Text input)])) (|> input "lux text size" ("lux i64 =" 1))) (|> input ("lux text char" 0) nat$ list [compiler] #Right) _ (#Left (..wrong-syntax-error (name-of ..char))))) (def: target (Meta Text) (function (_ compiler) (#Right [compiler (get@ [#info #target] compiler)]))) (def: (target-pick target options default) (-> Text (List [Code Code]) (Maybe Code) (Meta (List Code))) (case options #Nil (case default #.None (fail ($_ text@compose "No code for target platform: " target)) (#.Some default) (return (list default))) (#Cons [key pick] options') (with-expansions [ (target-pick target options' default)] (case key [_ (#Text platform)] (if (text@= target platform) (return (list pick)) ) [_ (#Identifier identifier)] (do meta-monad [identifier (..resolve-global-identifier identifier) type+value (..find-def-value identifier) #let [[type value] type+value]] (case (..flatten-alias type) (#Named ["lux" "Text"] (#Primitive "#Text" #Nil)) (if (text@= target (:coerce ..Text value)) (wrap (list pick)) ) _ (fail ($_ text@compose "Invalid target platform (must be a value of type Text): " (name@encode identifier) " : " (..code@encode (..type-to-code type)))))) _ )) )) (macro: #export (for tokens) (do meta-monad [target ..target] (case tokens (^ (list [_ (#Record options)])) (target-pick target options #.None) (^ (list [_ (#Record options)] default)) (target-pick target options (#.Some default)) _ (fail (..wrong-syntax-error (name-of ..for)))))) (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 [_ (#Identifier ["" "~~"])] expansion))]) (do meta-monad [g!expansion (gensym "g!expansion")] (wrap [(list [g!expansion expansion]) g!expansion])) (^template [] [ann ( parts)] (do meta-monad [=parts (monad@map meta-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 meta-monad [=kvs (monad@map meta-monad (function (_ [key val]) (do meta-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 meta-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-error (name-of ..``))) )) (def: (name$ [module name]) (-> Name 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 meta-monad [g!meta (gensym "g!meta")] (wrap (` [(~ g!meta) ( (~ ( value)))])))) ([#Bit "Bit" bit$] [#Nat "Nat" nat$] [#Int "Int" int$] [#Rev "Rev" rev$] [#Frac "Frac" frac$] [#Text "Text" text$] [#Tag "Tag" name$] [#Identifier "Identifier" name$]) [_ (#Record fields)] (do meta-monad [=fields (monad@map meta-monad (function (_ [key value]) (do meta-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 [[_ (#Identifier ["" "~"])] (#Cons [unquoted #Nil])]))] (return unquoted) [_ (#Form (#Cons [[_ (#Identifier ["" "~+"])] (#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 [[_ (#Identifier ["" "~+"])] (#Cons [spliced #Nil])]))] inits) (do meta-monad [=inits (monad@map meta-monad untemplate-pattern (list@reverse inits)) g!meta (gensym "g!meta")] (wrap (` [(~ g!meta) ( (~ (untemplate-list& spliced =inits)))]))) _ (do meta-monad [=elems (monad@map meta-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 meta-monad [pattern (untemplate-pattern template)] (wrap (list& pattern body branches))) (^ (list template)) (do meta-monad [pattern (untemplate-pattern template)] (wrap (list pattern))) _ (fail (..wrong-syntax-error (name-of ..^code))))) (def: #export (cursor-description [file line column]) (-> Cursor Text) (let [separator ", " fields ($_ "lux text concat" (text@encode file) separator (nat@encode line) separator (nat@encode column))] ($_ "lux text concat" "[" fields "]"))) (template [ ] [(def: #export #0) (def: #export #1)] [false true] [no yes] [off on] ) (macro: #export (:let tokens) (case tokens (^ (list [_ (#Tuple bindings)] bodyT)) (if (multiple? 2 (list@size bindings)) (return (list (` (..with-expansions [(~+ (|> bindings ..as-pairs (list@map (function (_ [localT valueT]) (list localT (` (..as-is (~ valueT)))))) (list@fold list@compose (list))))] (~ bodyT))))) (..fail ":let requires an even number of parts")) _ (..fail "Wrong syntax for :let")))