aboutsummaryrefslogtreecommitdiff
path: root/stdlib/source/parser
diff options
context:
space:
mode:
Diffstat (limited to 'stdlib/source/parser')
-rw-r--r--stdlib/source/parser/lux/macro/code.lux226
-rw-r--r--stdlib/source/parser/lux/type.lux350
2 files changed, 576 insertions, 0 deletions
diff --git a/stdlib/source/parser/lux/macro/code.lux b/stdlib/source/parser/lux/macro/code.lux
new file mode 100644
index 000000000..85490e2d0
--- /dev/null
+++ b/stdlib/source/parser/lux/macro/code.lux
@@ -0,0 +1,226 @@
+(.require
+ [library
+ [lux (.except nat int rev local not symbol local global)
+ [abstract
+ ["[0]" monad (.only do)]]
+ [control
+ ["//" parser]
+ ["[0]" try (.only Try)]]
+ [data
+ ["[0]" bit]
+ ["[0]" text (.use "[1]#[0]" monoid)]
+ [collection
+ ["[0]" list (.use "[1]#[0]" functor)]]]
+ [macro
+ ["[0]" code (.use "[1]#[0]" equivalence)]]
+ [math
+ [number
+ ["[0]" nat]
+ ["[0]" int]
+ ["[0]" rev]
+ ["[0]" frac]]]
+ [meta
+ ["[0]" symbol]]]])
+
+(def (un_paired pairs)
+ (All (_ a) (-> (List [a a]) (List a)))
+ (case pairs
+ {.#End}
+ {.#End}
+
+ {.#Item [[x y] pairs']}
+ (list.partial x y (un_paired pairs'))))
+
+(type .public Parser
+ (//.Parser (List Code)))
+
+(def remaining_inputs
+ (-> (List Code) Text)
+ (|>> (list#each code.format)
+ (text.interposed " ")
+ (all text#composite text.new_line "Remaining input: ")))
+
+(def .public any
+ (Parser Code)
+ (function (_ tokens)
+ (case tokens
+ {.#End}
+ {try.#Failure "There are no tokens to parse!"}
+
+ {.#Item [t tokens']}
+ {try.#Success [tokens' t]})))
+
+(def .public next
+ (Parser Code)
+ (function (_ tokens)
+ (case tokens
+ {.#End}
+ {try.#Failure "There are no tokens to parse!"}
+
+ {.#Item next _}
+ {try.#Success [tokens next]})))
+
+(with_template [<query> <check> <type> <tag> <eq> <desc>]
+ [(with_expansions [<failure> (these {try.#Failure (all text#composite "Cannot parse " <desc> (remaining_inputs tokens))})]
+ (def .public <query>
+ (Parser <type>)
+ (function (_ tokens)
+ (case tokens
+ {.#Item [[_ {<tag> x}] tokens']}
+ {try.#Success [tokens' x]}
+
+ _
+ <failure>)))
+
+ (def .public (<check> expected)
+ (-> <type> (Parser Any))
+ (function (_ tokens)
+ (case tokens
+ {.#Item [[_ {<tag> actual}] tokens']}
+ (if (at <eq> = expected actual)
+ {try.#Success [tokens' []]}
+ <failure>)
+
+ _
+ <failure>))))]
+
+ [bit this_bit Bit .#Bit bit.equivalence "bit"]
+ [nat this_nat Nat .#Nat nat.equivalence "nat"]
+ [int this_int Int .#Int int.equivalence "int"]
+ [rev this_rev Rev .#Rev rev.equivalence "rev"]
+ [frac this_frac Frac .#Frac frac.equivalence "frac"]
+ [text this_text Text .#Text text.equivalence "text"]
+ [symbol this_symbol Symbol .#Symbol symbol.equivalence "symbol"]
+ )
+
+(def .public (this code)
+ (-> Code (Parser Any))
+ (function (_ tokens)
+ (case tokens
+ {.#Item [token tokens']}
+ (if (code#= code token)
+ {try.#Success [tokens' []]}
+ {try.#Failure (all text#composite "Expected a " (code.format code) " but instead got " (code.format token)
+ (remaining_inputs tokens))})
+
+ _
+ {try.#Failure "There are no tokens to parse!"})))
+
+(with_expansions [<failure> (these {try.#Failure (all text#composite "Cannot parse local symbol" (remaining_inputs tokens))})]
+ (def .public local
+ (Parser Text)
+ (function (_ tokens)
+ (case tokens
+ {.#Item [[_ {.#Symbol ["" x]}] tokens']}
+ {try.#Success [tokens' x]}
+
+ _
+ <failure>)))
+
+ (def .public (this_local expected)
+ (-> Text (Parser Any))
+ (function (_ tokens)
+ (case tokens
+ {.#Item [[_ {.#Symbol ["" actual]}] tokens']}
+ (if (at text.equivalence = expected actual)
+ {try.#Success [tokens' []]}
+ <failure>)
+
+ _
+ <failure>))))
+
+(with_expansions [<failure> (these {try.#Failure (all text#composite "Cannot parse local symbol" (remaining_inputs tokens))})]
+ (def .public global
+ (Parser Symbol)
+ (function (_ tokens)
+ (case tokens
+ {.#Item [[_ {.#Symbol ["" short]}] tokens']}
+ <failure>
+
+ {.#Item [[_ {.#Symbol it}] tokens']}
+ {try.#Success [tokens' it]}
+
+ _
+ <failure>)))
+
+ (def .public (this_global expected)
+ (-> Symbol (Parser Any))
+ (function (_ tokens)
+ (case tokens
+ {.#Item [[_ {.#Symbol ["" actual]}] tokens']}
+ <failure>
+
+ {.#Item [[_ {.#Symbol it}] tokens']}
+ (if (at symbol.equivalence = expected it)
+ {try.#Success [tokens' []]}
+ <failure>)
+
+ _
+ <failure>))))
+
+(with_template [<name> <tag> <desc>]
+ [(def .public (<name> p)
+ (All (_ a)
+ (-> (Parser a) (Parser a)))
+ (function (_ tokens)
+ (case tokens
+ {.#Item [[_ {<tag> members}] tokens']}
+ (case (p members)
+ {try.#Success [{.#End} x]} {try.#Success [tokens' x]}
+ _ {try.#Failure (all text#composite "Parser was expected to fully consume " <desc> (remaining_inputs tokens))})
+
+ _
+ {try.#Failure (all text#composite "Cannot parse " <desc> (remaining_inputs tokens))})))]
+
+ [form .#Form "form"]
+ [variant .#Variant "variant"]
+ [tuple .#Tuple "tuple"]
+ )
+
+(def .public end
+ (Parser Any)
+ (function (_ tokens)
+ (case tokens
+ {.#End} {try.#Success [tokens []]}
+ _ {try.#Failure (all text#composite "Expected list of tokens to be empty!" (remaining_inputs tokens))})))
+
+(def .public end?
+ (Parser Bit)
+ (function (_ tokens)
+ {try.#Success [tokens (case tokens
+ {.#End} true
+ _ false)]}))
+
+(def .public (result parser inputs)
+ (All (_ a) (-> (Parser a) (List Code) (Try a)))
+ (case (parser inputs)
+ {try.#Failure error}
+ {try.#Failure error}
+
+ {try.#Success [unconsumed value]}
+ (case unconsumed
+ {.#End}
+ {try.#Success value}
+
+ _
+ {try.#Failure (|> unconsumed
+ (list#each code.format)
+ (text.interposed ", ")
+ (text#composite "Unconsumed inputs: "))})))
+
+(def .public (locally inputs parser)
+ (All (_ a) (-> (List Code) (Parser a) (Parser a)))
+ (function (_ real)
+ (do try.monad
+ [value (..result parser inputs)]
+ (in [real value]))))
+
+(def .public (not parser)
+ (All (_ a) (-> (Parser a) (Parser Code)))
+ (do //.monad
+ [sample ..next
+ result (//.or parser
+ ..any)]
+ (case result
+ {.#Left _} (//.failure (text#composite "Did NOT expect to parse code: " (code.format sample)))
+ {.#Right output} (in output))))
diff --git a/stdlib/source/parser/lux/type.lux b/stdlib/source/parser/lux/type.lux
new file mode 100644
index 000000000..a107a1778
--- /dev/null
+++ b/stdlib/source/parser/lux/type.lux
@@ -0,0 +1,350 @@
+(.require
+ [library
+ [lux (.except function local parameter)
+ [abstract
+ ["[0]" monad (.only do)]]
+ [control
+ ["//" parser]
+ ["[0]" try (.only Try)]
+ ["[0]" exception (.only exception)]
+ ["[0]" function]]
+ [data
+ ["[0]" text (.use "[1]#[0]" monoid)
+ ["%" \\format (.only format)]]
+ [collection
+ ["[0]" list (.use "[1]#[0]" functor)]
+ ["[0]" dictionary (.only Dictionary)]]]
+ [macro
+ ["^" pattern]
+ ["[0]" code]]
+ [math
+ [number
+ ["n" nat (.use "[1]#[0]" decimal)]]]
+ ["[0]" type (.use "[1]#[0]" equivalence)
+ ["[0]" check]]]])
+
+(def |recursion_dummy|
+ (template (|recursion_dummy|)
+ [{.#Primitive "" {.#End}}]))
+
+(with_template [<name>]
+ [(exception .public (<name> [type Type])
+ (exception.report
+ "Type" (%.type type)))]
+
+ [not_existential]
+ [not_recursive]
+ [not_named]
+ [not_parameter]
+ [unknown_parameter]
+ [not_function]
+ [not_application]
+ [not_polymorphic]
+ [not_variant]
+ [not_tuple]
+ )
+
+(with_template [<name>]
+ [(exception .public (<name> [expected Type
+ actual Type])
+ (exception.report
+ "Expected" (%.type expected)
+ "Actual" (%.type actual)))]
+
+ [types_do_not_match]
+ [wrong_parameter]
+ )
+
+(exception .public empty_input)
+
+(exception .public (unconsumed_input [remaining (List Type)])
+ (exception.report
+ "Types" (|> remaining
+ (list#each (|>> %.type (format text.new_line "* ")))
+ (text.interposed ""))))
+
+(type .public Env
+ (Dictionary Nat [Type Code]))
+
+(type .public (Parser a)
+ (//.Parser [Env (List Type)] a))
+
+(def .public fresh
+ Env
+ (dictionary.empty n.hash))
+
+(def (result' env poly types)
+ (All (_ a) (-> Env (Parser a) (List Type) (Try a)))
+ (case (//.result poly [env types])
+ {try.#Failure error}
+ {try.#Failure error}
+
+ {try.#Success [[env' remaining] output]}
+ (case remaining
+ {.#End}
+ {try.#Success output}
+
+ _
+ (exception.except ..unconsumed_input remaining))))
+
+(def .public (result poly type)
+ (All (_ a) (-> (Parser a) Type (Try a)))
+ (result' ..fresh poly (list type)))
+
+(def .public env
+ (Parser Env)
+ (.function (_ [env inputs])
+ {try.#Success [[env inputs] env]}))
+
+(def (with_env temp poly)
+ (All (_ a) (-> Env (Parser a) (Parser a)))
+ (.function (_ [env inputs])
+ (case (//.result poly [temp inputs])
+ {try.#Failure error}
+ {try.#Failure error}
+
+ {try.#Success [[_ remaining] output]}
+ {try.#Success [[env remaining] output]})))
+
+(def .public next
+ (Parser Type)
+ (.function (_ [env inputs])
+ (case inputs
+ {.#End}
+ (exception.except ..empty_input [])
+
+ {.#Item headT tail}
+ {try.#Success [[env inputs] headT]})))
+
+(def .public any
+ (Parser Type)
+ (.function (_ [env inputs])
+ (case inputs
+ {.#End}
+ (exception.except ..empty_input [])
+
+ {.#Item headT tail}
+ {try.#Success [[env tail] headT]})))
+
+(def .public (local types poly)
+ (All (_ a) (-> (List Type) (Parser a) (Parser a)))
+ (.function (_ [env pass_through])
+ (case (result' env poly types)
+ {try.#Failure error}
+ {try.#Failure error}
+
+ {try.#Success output}
+ {try.#Success [[env pass_through] output]})))
+
+(def (label idx)
+ (-> Nat Code)
+ (code.local (all text#composite "label" text.tab (n#encoded idx))))
+
+(def .public (with_extension type poly)
+ (All (_ a) (-> Type (Parser a) (Parser [Code a])))
+ (.function (_ [env inputs])
+ (let [current_id (dictionary.size env)
+ g!var (label current_id)]
+ (case (//.result poly
+ [(dictionary.has current_id [type g!var] env)
+ inputs])
+ {try.#Failure error}
+ {try.#Failure error}
+
+ {try.#Success [[_ inputs'] output]}
+ {try.#Success [[env inputs'] [g!var output]]}))))
+
+(with_template [<name> <flattener> <exception>]
+ [(`` (def .public (<name> poly)
+ (All (_ a) (-> (Parser a) (Parser a)))
+ (do //.monad
+ [headT ..any]
+ (let [members (<flattener> (type.anonymous headT))]
+ (if (n.> 1 (list.size members))
+ (local members poly)
+ (//.failure (exception.error <exception> headT)))))))]
+
+ [variant type.flat_variant ..not_variant]
+ [tuple type.flat_tuple ..not_tuple]
+ )
+
+(def polymorphic'
+ (Parser [Nat Type])
+ (do //.monad
+ [headT any
+ .let [[num_arg bodyT] (type.flat_univ_q (type.anonymous headT))]]
+ (if (n.= 0 num_arg)
+ (//.failure (exception.error ..not_polymorphic headT))
+ (in [num_arg bodyT]))))
+
+(def .public (polymorphic poly)
+ (All (_ a) (-> (Parser a) (Parser [Code (List Code) a])))
+ (do [! //.monad]
+ [headT any
+ funcI (at ! each dictionary.size ..env)
+ [num_args non_poly] (local (list headT) ..polymorphic')
+ env ..env
+ .let [funcL (label funcI)
+ [all_varsL env'] (loop (again [current_arg 0
+ env' env
+ all_varsL (is (List Code) (list))])
+ (if (n.< num_args current_arg)
+ (if (n.= 0 current_arg)
+ (let [varL (label (++ funcI))]
+ (again (++ current_arg)
+ (|> env'
+ (dictionary.has funcI [headT funcL])
+ (dictionary.has (++ funcI) [{.#Parameter (++ funcI)} varL]))
+ {.#Item varL all_varsL}))
+ (let [partialI (|> current_arg (n.* 2) (n.+ funcI))
+ partial_varI (++ partialI)
+ partial_varL (label partial_varI)
+ partialC (` ((~ funcL) (~+ (|> (list.indices num_args)
+ (list#each (|>> (n.* 2) ++ (n.+ funcI) label))
+ list.reversed))))]
+ (again (++ current_arg)
+ (|> env'
+ (dictionary.has partialI [(|recursion_dummy|) partialC])
+ (dictionary.has partial_varI [{.#Parameter partial_varI} partial_varL]))
+ {.#Item partial_varL all_varsL})))
+ [all_varsL env']))]]
+ (<| (with_env env')
+ (local (list non_poly))
+ (do !
+ [output poly]
+ (in [funcL all_varsL output])))))
+
+(def .public (function in_poly out_poly)
+ (All (_ i o) (-> (Parser i) (Parser o) (Parser [i o])))
+ (do //.monad
+ [headT any
+ .let [[inputsT outputT] (type.flat_function (type.anonymous headT))]]
+ (if (n.> 0 (list.size inputsT))
+ (//.and (local inputsT in_poly)
+ (local (list outputT) out_poly))
+ (//.failure (exception.error ..not_function headT)))))
+
+(def .public (applied poly)
+ (All (_ a) (-> (Parser a) (Parser a)))
+ (do //.monad
+ [headT any
+ .let [[funcT paramsT] (type.flat_application (type.anonymous headT))]]
+ (if (n.= 0 (list.size paramsT))
+ (//.failure (exception.error ..not_application headT))
+ (..local {.#Item funcT paramsT} poly))))
+
+(with_template [<name> <test>]
+ [(def .public (<name> expected)
+ (-> Type (Parser Any))
+ (do //.monad
+ [actual any]
+ (if (<test> expected actual)
+ (in [])
+ (//.failure (exception.error ..types_do_not_match [expected actual])))))]
+
+ [exactly type#=]
+ [sub check.subsumes?]
+ [super (function.flipped check.subsumes?)]
+ )
+
+(def .public (argument env idx)
+ (-> Env Nat Nat)
+ (let [env_level (n./ 2 (dictionary.size env))
+ parameter_level (n./ 2 idx)
+ parameter_idx (n.% 2 idx)]
+ (|> env_level -- (n.- parameter_level) (n.* 2) (n.+ parameter_idx))))
+
+(def .public parameter
+ (Parser Code)
+ (do //.monad
+ [env ..env
+ headT any]
+ (case headT
+ {.#Parameter idx}
+ (case (dictionary.value (..argument env idx) env)
+ {.#Some [poly_type poly_code]}
+ (in poly_code)
+
+ {.#None}
+ (//.failure (exception.error ..unknown_parameter headT)))
+
+ _
+ (//.failure (exception.error ..not_parameter headT)))))
+
+(def .public (this_parameter id)
+ (-> Nat (Parser Any))
+ (do //.monad
+ [env ..env
+ headT any]
+ (case headT
+ {.#Parameter idx}
+ (if (n.= id (..argument env idx))
+ (in [])
+ (//.failure (exception.error ..wrong_parameter [{.#Parameter id} headT])))
+
+ _
+ (//.failure (exception.error ..not_parameter headT)))))
+
+(def .public existential
+ (Parser Nat)
+ (do //.monad
+ [headT any]
+ (case headT
+ {.#Ex ex_id}
+ (in ex_id)
+
+ _
+ (//.failure (exception.error ..not_existential headT)))))
+
+(def .public named
+ (Parser [Symbol Type])
+ (do //.monad
+ [inputT any]
+ (case inputT
+ {.#Named name anonymousT}
+ (in [name anonymousT])
+
+ _
+ (//.failure (exception.error ..not_named inputT)))))
+
+(def .public (recursive poly)
+ (All (_ a) (-> (Parser a) (Parser [Code a])))
+ (do [! //.monad]
+ [headT any]
+ (case (type.anonymous headT)
+ (pattern {.#Apply (|recursion_dummy|) {.#UnivQ _ headT'}})
+ (do !
+ [[recT _ output] (|> poly
+ (with_extension (|recursion_dummy|))
+ (with_extension headT)
+ (local (list headT')))]
+ (in [recT output]))
+
+ _
+ (//.failure (exception.error ..not_recursive headT)))))
+
+(def .public recursive_self
+ (Parser Code)
+ (do //.monad
+ [env ..env
+ headT any]
+ (case (type.anonymous headT)
+ (^.multi (pattern {.#Apply (|recursion_dummy|) {.#Parameter funcT_idx}})
+ (n.= 0 (..argument env funcT_idx))
+ [(dictionary.value 0 env) {.#Some [self_type self_call]}])
+ (in self_call)
+
+ _
+ (//.failure (exception.error ..not_recursive headT)))))
+
+(def .public recursive_call
+ (Parser Code)
+ (do [! //.monad]
+ [env ..env
+ [funcT argsT] (..applied (//.and any (//.many any)))
+ _ (local (list funcT) (..this_parameter 0))
+ allC (let [allT (list.partial funcT argsT)]
+ (|> allT
+ (monad.each ! (function.constant ..parameter))
+ (local allT)))]
+ (in (` ((~+ allC))))))
generated by cgit v1.2.3 (git 2.25.1) at 2024-12-22 23:08:39 +0000