retoor/orchid
1
0
Fork 0
forked from Orchid/orchid
Code Pull Requests 1 Activity

October commit

Browse Source 
- custom parser support and infra
- type-tagging and traits (untested)
- match expressions
This commit is contained in:
Lawrence Bethlenfalvy
2023-10-24 22:17:37 +01:00
parent c961506a3a
commit f77e4fd90a
73 changed files with 1904 additions and 558 deletions
Download Patch File Download Diff File Expand all files Collapse all files

5
src/systems/asynch/system.rs
View File

@@ -55,6 +55,7 @@ impl InertAtomic for Yield {
/// Error indicating a yield command when all event producers and timers had
/// exited
#[derive(Clone)]
pub struct InfiniteBlock;
impl ExternError for InfiniteBlock {}
impl Display for InfiniteBlock {
@@ -187,8 +188,8 @@ impl<'a> IntoSystem<'a> for AsynchSystem<'a> {
});
System {
name: vec!["system".to_string(), "asynch".to_string()],
lexer_plugin: None,
line_parser: None,
lexer_plugins: vec![],
line_parsers: vec![],
constants: ConstTree::namespace(
[i.i("system"), i.i("async")],
ConstTree::tree([

4
src/systems/directfs/commands.rs
View File

@@ -183,8 +183,8 @@ impl IntoSystem<'static> for DirectFS {
name: ["system", "directfs"].into_iter().map_into().collect(),
code: HashMap::new(),
prelude: Vec::new(),
lexer_plugin: None,
line_parser: None,
lexer_plugins: vec![],
line_parsers: vec![],
constants: ConstTree::namespace(
[i.i("system"), i.i("fs")],
ConstTree::tree([

4
src/systems/io/service.rs
View File

@@ -113,8 +113,8 @@ impl<'a, ST: IntoIterator<Item = (&'a str, Stream)>> IntoSystem<'static>
name: None,
}]),
}],
lexer_plugin: None,
line_parser: None,
lexer_plugins: vec![],
line_parsers: vec![],
}
}
}

2
src/systems/mod.rs
View File

@@ -5,3 +5,5 @@ pub mod directfs;
pub mod io;
pub mod scheduler;
pub mod stl;
pub mod parse_custom_line;

40
src/systems/parse_custom_line.rs Normal file
View File

@@ -0,0 +1,40 @@
//! A helper for defining custom lines. See [custom_line]
use crate::error::{ProjectError, ProjectResult};
use crate::parse::errors::{Expected, ExpectedName};
use crate::parse::{Entry, Lexeme, Stream};
use crate::{Location, Tok};
/// An exported line with a name for which the line parser denies exports
pub struct Unexportable(Entry);
impl ProjectError for Unexportable {
fn description(&self) -> &str { "this line type cannot be exported" }
fn message(&self) -> String { format!("{} cannot be exported", &self.0) }
fn one_position(&self) -> Location { self.0.location() }
}
/// Parse a line identified by the specified leading keyword. Although not
/// required, plugins are encouraged to prefix their lines with a globally
/// unique keyword which makes or breaks their parsing, to avoid accidental
/// failure to recognize
pub fn custom_line(
tail: Stream<'_>,
keyword: Tok<String>,
exportable: bool,
) -> Option<ProjectResult<(bool, Stream<'_>, Location)>> {
let line_loc = tail.location();
let (fst, tail) = tail.pop().ok()?;
let fst_name = ExpectedName::expect(fst).ok()?;
let (exported, n_ent, tail) = if fst_name == keyword {
(false, fst, tail.trim())
} else if fst_name.as_str() == "export" {
let (snd, tail) = tail.pop().ok()?;
Expected::expect(Lexeme::Name(keyword), snd).ok()?;
(true, snd, tail.trim())
} else {
return None;
};
Some(match exported && !exportable {
true => Err(Unexportable(n_ent.clone()).rc()),
false => Ok((exported, tail, line_loc)),
})
}

4
src/systems/scheduler/system.rs
View File

@@ -332,8 +332,8 @@ impl IntoSystem<'static> for SeqScheduler {
prelude: Vec::new(),
code: HashMap::new(),
handlers,
lexer_plugin: None,
line_parser: None,
lexer_plugins: vec![],
line_parsers: vec![],
constants: ConstTree::namespace(
[i.i("system"), i.i("scheduler")],
ConstTree::tree([

1
src/systems/stl/arithmetic_error.rs
View File

@@ -3,6 +3,7 @@ use std::fmt::Display;
use crate::foreign::ExternError;
/// Various errors produced by arithmetic operations
#[derive(Clone)]
pub enum ArithmeticError {
/// Integer overflow
Overflow,

36
src/systems/stl/bool.orc
View File

@@ -1,3 +1,5 @@
import std::match
export ::(!=, ==)
export const not := \bool. if bool then false else true
@@ -8,3 +10,37 @@ export macro ...$a or ...$b =0x4p36=> (ifthenelse (...$a) true (...$b))
export macro if ...$cond then ...$true else ...$false:1 =0x1p84=> (
ifthenelse (...$cond) (...$true) (...$false)
)
(
macro match::request (== ...$other)
=0x1p230=> match::response (
if match::value == (...$other)
then match::pass
else match::fail
)
( match::no_binds )
)
(
macro match::request (!= ...$other)
=0x1p230=> match::response (
if match::value != (...$other)
then match::pass
else match::fail
)
( match::no_binds )
)
(
macro match::request (true)
=0x1p230=> match::response
(if match::value then match::pass else match::fail)
( match::no_binds )
)
(
macro match::request (false)
=0x1p230=> match::response
(if match::value then match::fail else match::pass)
( match::no_binds )
)

112
src/systems/stl/cross_pipeline.rs Normal file
View File

@@ -0,0 +1,112 @@
use std::collections::VecDeque;
use std::fmt::Debug;
use std::iter;
use std::ops::Deref;
use std::rc::Rc;
use std::sync::{Arc, Mutex};
use crate::ast::{self, PType};
use crate::ddispatch::Responder;
use crate::foreign::{
xfn_1ary, Atomic, AtomicReturn, ExFn, StrictEq, ToClause, XfnResult,
};
use crate::interpreted::{self, TryFromExprInst};
use crate::utils::pure_seq::pushed;
use crate::{interpreter, VName};
pub trait DeferredRuntimeCallback<T, U, R: ToClause>:
Fn(Vec<(T, U)>) -> XfnResult<R> + Clone + Send + 'static
{
}
impl<
T,
U,
R: ToClause,
F: Fn(Vec<(T, U)>) -> XfnResult<R> + Clone + Send + 'static,
> DeferredRuntimeCallback<T, U, R> for F
{
}
fn table_receiver_rec<
T: Clone + Send + 'static,
U: TryFromExprInst + Clone + Send + 'static,
R: ToClause + 'static,
>(
results: Vec<(T, U)>,
mut remaining_keys: VecDeque<T>,
callback: impl DeferredRuntimeCallback<T, U, R>,
) -> XfnResult<interpreted::Clause> {
match remaining_keys.pop_front() {
None => callback(results).map(|v| v.to_clause()),
Some(t) => Ok(interpreted::Clause::ExternFn(ExFn(Box::new(xfn_1ary(
move |u: U| {
table_receiver_rec(pushed(results, (t, u)), remaining_keys, callback)
},
))))),
}
}
#[derive(Clone)]
pub struct EphemeralAtom(
Arc<dyn Fn() -> XfnResult<interpreted::Clause> + Sync + Send>,
);
impl Debug for EphemeralAtom {
fn fmt(&self, f: &mut std::fmt::Formatter<'_>) -> std::fmt::Result {
f.write_str("EphemeralAtom")
}
}
impl Responder for EphemeralAtom {
fn respond(&self, _request: crate::ddispatch::Request) {}
}
impl StrictEq for EphemeralAtom {
fn strict_eq(&self, _: &dyn std::any::Any) -> bool { false }
}
impl Atomic for EphemeralAtom {
fn as_any(self: Box<Self>) -> Box<dyn std::any::Any> { self }
fn as_any_ref(&self) -> &dyn std::any::Any { self }
fn run(
self: Box<Self>,
ctx: interpreter::Context,
) -> crate::foreign::AtomicResult {
Ok(AtomicReturn { clause: (self.0)()?, gas: ctx.gas, inert: false })
}
}
fn table_receiver<
T: Clone + Send + 'static,
U: TryFromExprInst + Clone + Send + 'static,
R: ToClause + 'static,
>(
keys: VecDeque<T>,
callback: impl DeferredRuntimeCallback<T, U, R>,
) -> ast::Clause<VName> {
if keys.is_empty() {
let result =
Arc::new(Mutex::new(callback(Vec::new()).map(|v| v.to_clause())));
EphemeralAtom(Arc::new(move || result.lock().unwrap().deref().clone()))
.ast_cls()
} else {
match table_receiver_rec(Vec::new(), keys, callback) {
Ok(interpreted::Clause::ExternFn(xfn)) => ast::Clause::ExternFn(xfn),
_ => unreachable!("details"),
}
}
}
pub fn defer_to_runtime<
T: Clone + Send + 'static,
U: TryFromExprInst + Clone + Send + 'static,
R: ToClause + 'static,
>(
pairs: impl IntoIterator<Item = (T, Vec<ast::Expr<VName>>)>,
callback: impl DeferredRuntimeCallback<T, U, R>,
) -> ast::Clause<VName> {
let (keys, ast_values) =
pairs.into_iter().unzip::<_, _, VecDeque<_>, Vec<_>>();
ast::Clause::s(
'(',
iter::once(table_receiver(keys, callback)).chain(
ast_values.into_iter().map(|v| ast::Clause::S(PType::Par, Rc::new(v))),
),
)
}

22
src/systems/stl/functional.orc
View File

@@ -1,4 +1,7 @@
import super::known::*
import super::match::*
import super::macro
import super::match::(match, =>)
--[ Do nothing. Especially useful as a passive cps operation ]--
export const identity := \x.x
@@ -21,6 +24,19 @@ export const return := \a. \b.a
export macro ...$prefix $ ...$suffix:1 =0x1p38=> ...$prefix (...$suffix)
export macro ...$prefix |> $fn ..$suffix:1 =0x2p32=> $fn (...$prefix) ..$suffix
export macro ($name) => ...$body =0x2p127=> (\$name. ...$body)
export macro ($name, ...$argv) => ...$body =0x2p127=> (\$name. (...$argv) => ...$body)
export macro $name => ...$body =0x1p127=> (\$name. ...$body)
( macro (..$argv) => ...$body
=0x2p127=> lambda_walker macro::comma_list (..$argv) (...$body)
)
( macro $_arg => ...$body
=0x2p127=> \$_arg. ...$body)
( macro lambda_walker ( macro::list_item ($_argname) $tail ) $body
=0x2p254=> \$_argname. lambda_walker $tail $body
)
( macro lambda_walker ( macro::list_item (...$head) $tail ) $body
=0x1p254=> \arg. match arg {
...$head => lambda_walker $tail $body;
}
)
( macro lambda_walker macro::list_end $body
=0x1p254=> $body
)

2
src/systems/stl/known.orc
View File

@@ -1 +1 @@
export ::[,]
export ::[, _ ; . =]

64
src/systems/stl/list.orc
View File

@@ -1,18 +1,26 @@
import super::option
import super::(functional::*, procedural::*, loop::*, bool::*, known::*, number::*, tuple::*)
import super::(option, match, macro)
import super::(functional::*, procedural::*)
import super::(loop::*, bool::*, known::*, number::*, tuple::*)
const pair := \a. \b. \f. f a b
export type ty (
import super::super::(option, tuple, panic)
import super::super::(known::*, bool::*)
-- Constructors
export const cons := \hd. \tl. wrap (option::some tuple::t[hd, unwrap tl])
export const end := wrap option::none
export const pop := \list. \default. \f. (
option::handle (unwrap list)
default
\pair. tuple::apply pair
\len. if len == 2
then ( \hd. \tl. f hd (wrap tl) )
else panic "list element must be 2-ple"
)
)
export const cons := \hd. \tl. option::some t[hd, tl]
export const end := option::none
export const pop := \list. \default. \f. do{
cps tuple = list default;
cps head, tail = tuple;
f head tail
}
export const cons := ty::cons
export const end := ty::end
export const pop := ty::pop
-- Operators
@@ -124,8 +132,34 @@ export const chain := \list. \cont. loop_over (list) {
cps head;
}
macro new[...$item, ...$rest:1] =0x2p84=> (cons (...$item) new[...$rest])
macro new[...$end] =0x1p84=> (cons (...$end) end)
macro new[] =0x1p84=> end
macro new[..$items] =0x2p84=> mk_list macro::comma_list (..$items)
macro mk_list ( macro::list_item $item $tail ) =0x1p254=> (cons $item mk_list $tail)
macro mk_list macro::list_end =0x1p254=> end
export ::(new)
( macro match::request (cons $head $tail)
=0x1p230=> await_subpatterns
(match::request ($head))
(match::request ($tail))
)
( macro await_subpatterns
(match::response $h_expr ( $h_binds ))
(match::response $t_expr ( $t_binds ))
=0x1p230=> match::response (
pop
match::value
match::fail
\head. \tail. (
(\match::pass. (\match::value. $h_expr) head)
(match::take_binds $h_binds (
(\match::pass. (\match::value. $t_expr) tail)
(match::take_binds $t_binds (
match::give_binds match::chain_binds $h_binds $t_binds match::pass
))
))
)
)
(match::chain_binds $h_binds $t_binds)
)

3
src/systems/stl/loop.orc
View File

@@ -37,6 +37,7 @@ macro parse_binds (...$item) =0x1p250=> (
()
)
-- while loop
export macro statement (
while ..$condition (..$binds) {
@@ -64,7 +65,7 @@ macro init_binds ( ($name $value) $tail ) =0x1p250=> $value init_binds $tail
macro $fn init_binds () =0x1p250=> $fn
-- apply_binds passes the name for initializers
macro apply_binds ( ($name $_value) $tail ) =0x1p250=> $name apply_binds $tail
macro apply_binds ( ($name $value) $tail ) =0x1p250=> $name apply_binds $tail
macro $fn apply_binds () =0x1p250=> $fn
--[

68
src/systems/stl/macro.orc Normal file
View File

@@ -0,0 +1,68 @@
import std::number::add
import std::known::*
-- convert a comma-separated list into a linked list, with support for trailing commas
export ::comma_list
( macro comma_list ( ...$head, ...$tail:1 )
=0x2p254=> ( await_comma_list ( ...$head ) comma_list ( ...$tail ) )
)
( macro comma_list (...$only)
=0x1p254=> ( list_item (...$only) list_end )
)
( macro ( await_comma_list $head $tail )
=0x2p254=> ( list_item $head $tail )
)
( macro comma_list ()
=0x1p254=> list_end
)
( macro comma_list (...$data,)
=0x3p254=> comma_list (...$data)
)
-- convert a comma-separated list into a linked list, with support for trailing commas
export ::semi_list
( macro semi_list ( ...$head; ...$tail:1 )
=0x2p254=> ( await_semi_list ( ...$head ) semi_list ( ...$tail ) )
)
( macro semi_list (...$only)
=0x1p254=> ( list_item (...$only) list_end )
)
( macro ( await_semi_list $head $tail )
=0x2p254=> ( list_item $head $tail )
)
( macro semi_list ()
=0x1p254=> list_end
)
( macro semi_list (...$data;)
=0x3p254=> semi_list (...$data)
)
-- calculate the length of a linked list
export ::length
( macro length ( list_item $discard $tail )
=0x1p254=> await_length ( length $tail )
)
( macro await_length ( $len )
=0x1p254=> (add 1 $len)
)
macro length list_end =0x1p254=> (0)
export ::error
( macro ( ..$prefix error $details ..$suffix )
=0x2p255=> error $details
)
( macro [ ..$prefix error $details ..$suffix ]
=0x2p255=> error $details
)
( macro { ..$prefix error $details ..$suffix }
=0x2p255=> error $details
)
( macro error $details
=0x1p255=>
)
export ::leftover_error
( macro leftover_error $details
=0x1p255=> error ( "Token fails to parse" $details )
)

149
src/systems/stl/map.orc
View File

@@ -1,73 +1,96 @@
import super::(bool::*, functional::*, known::*, list, option, loop::*, procedural::*)
import std::panic
import super::(bool::*, functional::*, known::*, loop::*, procedural::*)
import super::(panic, match, macro, option, list)
-- utilities for using lists as pairs
export type ty (
import super::super::(panic, macro, list, tuple, option)
import super::super::(bool::*, functional::*, known::*, loop::*, procedural::*)
const fst := \l. (
list::get l 0
(panic "nonempty expected")
\x.x
)
const snd := \l. (
list::get l 1
(panic "2 elements expected")
\x.x
--[ Constructors ]--
const empty := wrap list::end
const add := \m. \k. \v. wrap (
list::cons
tuple::t[k, v]
(unwrap m)
)
--[ List constructor ]--
export ::new
macro new[..$items] =0x2p84=> mk_map macro::comma_list (..$items)
macro mk_map macro::list_end =0x1p254=> empty
( macro mk_map ( macro::list_item ( ...$key = ...$value:1 ) $tail )
=0x1p254=> ( set mk_map $tail (...$key) (...$value) )
)
--[ Queries ]--
-- return the last occurrence of a key if exists
export const get := \m. \key. (
loop_over (m=unwrap m) {
cps record, m = list::pop m option::none;
cps if tuple::pick record 0 == key
then return $ option::some $ tuple::pick record 1
else identity;
}
)
--[ Commands ]--
-- remove one occurrence of a key
export const del := \m. \k. wrap (
recursive r (m=unwrap m)
list::pop m list::end \head. \tail.
if tuple::pick head 0 == k then tail
else list::cons head $ r tail
)
-- replace at most one occurrence of a key
export const set := \m. \k. \v. m |> del k |> add k v
)
-- constructors
macro new =0x1p200=> ty::new
export const empty := list::end
export const add := \m. \k. \v. (
list::cons
list::new[k, v]
m
export const empty := ty::empty
export const add := ty::add
export const get := ty::get
export const set := ty::set
export const del := ty::del
export ::having
( macro match::request (having [..$items])
=0x1p230=> having_pattern (
pattern_walker
macro::comma_list ( ..$items )
)
)
-- queries
-- return the last occurrence of a key if exists
export const get := \m. \key. (
loop_over (m) {
cps record, m = list::pop m option::none;
cps if fst record == key
then return $ option::some $ snd record
else identity;
}
( macro having_pattern ( tail_result $expr ( $binds ) )
=0x1p254=> match::response $expr ( $binds )
)
-- commands
-- remove one occurrence of a key
export const del := \m. \k. (
recursive r (m)
list::pop m list::end \head. \tail.
if fst head == k then tail
else list::cons head $ r tail
( macro pattern_walker macro::list_end
=0x1p254=> tail_result match::pass ( match::no_binds )
)
-- remove all occurrences of a key
export const delall := \m. \k. (
list::filter m \record. fst record != k
( macro pattern_walker ( macro::list_item ( ...$key = ...$value:1 ) $tail )
=0x1p254=> await_pattern ( ...$key )
( match::request (...$value) )
( pattern_walker $tail )
)
-- replace at most one occurrence of a key
export const set := \m. \k. \v. (
m
|> del k
|> add k v
( macro await_pattern $key
( match::response $expr ( $binds ) )
( tail_result $t_expr ( $t_binds ) )
=0x1p254=> tail_result (
option::handle (get match::value $key)
match::fail
\value. (\match::pass. (\match::value. $expr) value) (
match::take_binds $binds (
(\match::pass. $t_expr) (
match::take_binds $t_binds (
match::give_binds match::chain_binds $binds $t_binds match::pass
)
)
)
)
)
( match::chain_binds $binds $t_binds )
)
-- ensure that there's only one instance of each key in the map
export const normalize := \m. (
recursive r (m, normal=empty)
list::pop m normal \head. \tail.
r tail $ set normal (fst head) (snd head)
)
macro new[...$tail:2, ...$key = ...$value:1] =0x2p84=> (
set new[...$tail] (...$key) (...$value)
)
macro new[...$key = ...$value:1] =0x1p84=> (add empty (...$key) (...$value))
macro new[] =0x1p84=> empty
export ::(new)

104
src/systems/stl/match.orc Normal file
View File

@@ -0,0 +1,104 @@
import std::known::(_, ;)
import std::procedural
import std::bool
import std::macro
import std::panic
--[
The protocol:
Request contains the pattern
Response contains an expression and the list of names
]--
(
macro ..$prefix:1 match ...$argument:0 { ..$body } ..$suffix:1
=0x1p130=> ..$prefix (
(\value. match_walker macro::semi_list ( ..$body ) )
( ...$argument )
) ..$suffix
)
macro match_walker macro::list_end =0x1p254=> panic "no arms match"
( macro match_walker ( macro::list_item (...$pattern => ...$handler:1) $tail )
=0x1p254=> match_await ( request (...$pattern) ) (...$handler) ( match_walker $tail )
)
( macro match_await ( response $expr ( $binds ) ) $handler $tail
=0x1p254=> (\fail. (\pass. $expr) (take_binds $binds $handler)) $tail
)
macro request (( ..$pattern )) =0x1p254=> request ( ..$pattern )
-- bindings list
export ::(no_binds, add_bind, chain_binds, give_binds, take_binds)
macro add_bind $_new no_binds =0x1p254=> ( binds_list $_new no_binds )
( macro add_bind $_new ( binds_list ...$tail )
=0x1p254=> ( binds_list $_new ( binds_list ...$tail ) )
)
macro give_binds no_binds $cont =0x1p254=> $cont
( macro give_binds ( binds_list $_name $tail ) $cont
=0x1p254=> (give_binds $tail $cont $_name)
)
macro take_binds no_binds $cont =0x1p254=> $cont
( macro take_binds ( binds_list $_name $tail ) $cont
=0x1p254=> \$_name. take_binds $tail $cont
)
macro chain_binds no_binds $second =0x1p254=> $second
( macro chain_binds ( binds_list $_head $tail ) $second
=0x1p254=> add_bind $_head chain_binds $tail $second
)
--[ primitive pattern ( _ ) ]--
(
macro request ( _ )
=0x1p230=> response pass ( no_binds )
)
--[ primitive name pattern ]--
(
macro request ( $_name )
=0x1p226=> response ( pass value ) ( add_bind $_name no_binds )
)
--[ primitive pattern ( and ) ]--
( macro request ( ...$lhs bool::and ...$rhs )
=0x3p230=> await_and_subpatterns ( request (...$lhs ) ) ( request ( ...$rhs ) )
)
( macro await_and_subpatterns ( response $lh_expr ( $lh_binds ) ) ( response $rh_expr ( $rh_binds ) )
=0x1p254=> response (
(\pass. $lh_expr) (take_binds $lh_binds (
(\pass. $rh_expr) (take_binds $rh_binds (
give_binds chain_binds $lh_binds $rh_binds pass
))
))
)
( chain_binds $lh_binds $rh_binds )
)
--[ primitive pattern ( or ) ]--
(
macro request ( ...$lhs bool::or ...$rhs )
=0x3p230=> await_or_subpatterns
( request ( ...$lhs ) )
( request ( ...$rhs ) )
)
( -- for this to work, lh and rh must produce the same bindings
macro await_or_subpatterns ( response $lh_expr ( $lh_binds) ) ( response $rh_expr ( $rh_binds ) )
=0x1p254=> response (
(\cancel. $lh_expr) -- lh works with pass directly because its bindings are reported up
($rh_expr (take_binds $rh_binds -- rh runs if lh cancels
(give_binds $lh_binds pass) -- translate rh binds to lh binds
))
)
( $lh_binds ) -- report lh bindings
)
export ::(match, cancel, argument, request, response, =>)

3
src/systems/stl/mod.rs
View File

@@ -4,10 +4,13 @@ mod arithmetic_error;
mod binary;
mod bool;
mod conv;
mod cross_pipeline;
mod exit_status;
mod inspect;
mod number;
mod panic;
mod protocol;
mod reflect;
mod state;
mod stl_system;
mod string;

6
src/systems/stl/number.rs
View File

@@ -1,5 +1,3 @@
use std::rc::Rc;
use ordered_float::NotNan;
use super::ArithmeticError;
@@ -39,7 +37,7 @@ impl Numeric {
}
/// Wrap a f64 in a Numeric
pub fn new(value: f64) -> Result<Self, Rc<dyn ExternError>> {
pub fn new(value: f64) -> XfnResult<Self> {
if value.is_finite() {
NotNan::new(value)
.map(Self::Float)
@@ -50,7 +48,7 @@ impl Numeric {
}
}
impl TryFromExprInst for Numeric {
fn from_exi(exi: ExprInst) -> Result<Self, Rc<dyn ExternError>> {
fn from_exi(exi: ExprInst) -> XfnResult<Self> {
(exi.request())
.ok_or_else(|| AssertionError::ext(Location::Unknown, "a numeric value"))
}

45
src/systems/stl/option.orc
View File

@@ -1,9 +1,40 @@
import std::panic
import std::(panic, match)
export const some := \v. \d. \f. f v
export const none := \d. \f. d
export type ty (
export const some := \v. wrap \d. \f. f v
export const none := wrap \d. \f. d
export const map := \option. \f. option none f
export const flatten := \option. option none \opt. opt
export const flatmap := \option. \f. option none \opt. map opt f
export const unwrap := \option. option (panic "value expected") \x.x
export const handle := \t. \d. \f. (unwrap t) d f
)
export const some := ty::some
export const none := ty::none
export const handle := ty::handle
export const map := \option. \f. handle option none f
export const flatten := \option. handle option none \opt. opt
export const flatmap := \option. \f. handle option none \opt. map opt f
export const unwrap := \option. handle option (panic "value expected") \x.x
(
macro match::request ( none )
=0x1p230=> match::response (
handle match::value
match::pass
\_. match::fail
) ( match::no_binds )
)
(
macro match::request ( some ...$value )
=0x1p230=> await_some_subpattern ( match::request (...$value) )
)
(
macro await_some_subpattern ( match::response $expr ( $binds ) )
=0x1p254=> match::response (
handle match::value
match::fail
\match::value. $expr
) ( $binds )
)

7
src/systems/stl/panic.rs
View File

@@ -1,5 +1,5 @@
use std::fmt::Display;
use std::rc::Rc;
use std::sync::Arc;
use crate::foreign::{xfn_1ary, ExternError, XfnResult};
use crate::interpreted::Clause;
@@ -7,7 +7,8 @@ use crate::{ConstTree, Interner, OrcString};
/// An unrecoverable error in Orchid land. Because Orchid is lazy, this only
/// invalidates expressions that reference the one that generated it.
pub struct OrchidPanic(Rc<String>);
#[derive(Clone)]
pub struct OrchidPanic(Arc<String>);
impl Display for OrchidPanic {
fn fmt(&self, f: &mut std::fmt::Formatter<'_>) -> std::fmt::Result {
@@ -20,7 +21,7 @@ impl ExternError for OrchidPanic {}
/// Takes a message, returns an [ExternError] unconditionally.
pub fn orc_panic(msg: OrcString) -> XfnResult<Clause> {
// any return value would work, but Clause is the simplest
Err(OrchidPanic(Rc::new(msg.get_string())).into_extern())
Err(OrchidPanic(Arc::new(msg.get_string())).into_extern())
}
pub fn panic(i: &Interner) -> ConstTree {

10
src/systems/stl/prelude.orc
View File

@@ -5,11 +5,13 @@ export ::[++]
import std::bool::*
export ::([== !=], if, then, else, true, false, and, or, not)
import std::functional::*
export ::([$ |> =>], identity, pass, pass2, return)
export ::([$ |>], identity, pass, pass2, return)
import std::procedural::*
export ::(do, let, cps, [; =])
import std::tuple::*
export ::(do, let, cps, [;])
import std::tuple::t
export ::(t)
import std::match::(match, [=>])
export ::(match, [=>])
import std::tuple
import std::list
import std::map
@@ -19,4 +21,4 @@ import std::loop::*
export ::(loop_over, recursive, while)
import std::known::*
export ::[,]
export ::[, _ ; . =]

10
src/systems/stl/procedural.orc
View File

@@ -1,4 +1,5 @@
import super::functional::=>
import super::match::=>
import super::known::*
-- remove duplicate ;-s
export macro do {
@@ -14,8 +15,11 @@ export macro do { ...$return } =0x1p130=> (...$return)
-- modular operation block that returns a CPS function
export macro do cps { ...$body } =0x1p130=> \cont. do { ...$body ; cont }
export macro statement (let $name = ...$value) (...$next) =0x1p230=> (
( \$name. ...$next) (...$value)
export macro statement (let $_name = ...$value) (...$next) =0x2p230=> (
( \$_name. ...$next) (...$value)
)
export macro statement (let ...$pattern = ...$value:1) (...$next) =0x1p230=> (
( (...$pattern) => (...$next) ) (...$value)
)
export macro statement (cps ...$names = ...$operation:1) (...$next) =0x2p230=> (
(...$operation) ( (...$names) => ...$next )

283
src/systems/stl/protocol.rs Normal file
View File

@@ -0,0 +1,283 @@
use std::fmt::Debug;
use std::sync::Arc;
use hashbrown::HashMap;
use itertools::Itertools;
use super::cross_pipeline::defer_to_runtime;
use super::reflect::RefEqual;
use crate::ast::{self, Constant, Expr, PType};
use crate::error::{ProjectResult, RuntimeError};
use crate::foreign::{xfn_2ary, Atomic, InertAtomic, XfnResult};
use crate::interpreted::ExprInst;
use crate::parse::errors::{Expected, ExpectedBlock, ExpectedName};
use crate::parse::{
parse_entries, parse_exprv, parse_line, parse_nsname, split_lines,
vec_to_single, Context, Lexeme, LineParser, LineParserOut, Stream,
};
use crate::sourcefile::{
FileEntry, FileEntryKind, Member, MemberKind, ModuleBlock,
};
use crate::systems::parse_custom_line::custom_line;
use crate::utils::pure_seq::pushed;
use crate::{ConstTree, Interner, Location, Tok, VName};
pub struct TypeData {
pub id: RefEqual,
pub display_name: Tok<String>,
pub impls: HashMap<RefEqual, ExprInst>,
}
#[derive(Clone)]
pub struct Protocol(pub Arc<TypeData>);
impl Debug for Protocol {
fn fmt(&self, f: &mut std::fmt::Formatter<'_>) -> std::fmt::Result {
f.debug_tuple(&self.0.display_name).field(&self.0.id.id()).finish()
}
}
impl InertAtomic for Protocol {
fn type_str() -> &'static str { "Protocol" }
}
#[derive(Clone)]
pub struct Tag(pub Arc<TypeData>);
impl Debug for Tag {
fn fmt(&self, f: &mut std::fmt::Formatter<'_>) -> std::fmt::Result {
f.debug_tuple(&self.0.display_name).field(&self.0.id.id()).finish()
}
}
impl InertAtomic for Tag {
fn type_str() -> &'static str { "Tag" }
fn strict_eq(&self, other: &Self) -> bool { self.0.id == other.0.id }
}
#[derive(Clone)]
pub struct Tagged {
pub tag: Tag,
pub value: ExprInst,
}
impl Debug for Tagged {
fn fmt(&self, f: &mut std::fmt::Formatter<'_>) -> std::fmt::Result {
f.debug_tuple("Tagged").field(&self.tag).field(&self.value).finish()
}
}
impl InertAtomic for Tagged {
fn type_str() -> &'static str { "Tagged" }
}
fn parse_impl(
tail: Stream,
ctx: &(impl Context + ?Sized),
) -> Option<ProjectResult<(VName, Expr<VName>)>> {
custom_line(tail, ctx.interner().i("impl"), false).map(|res| {
let (_, tail, _) = res?;
let (name, tail) = parse_nsname(tail, ctx)?;
let (walrus, tail) = tail.trim().pop()?;
Expected::expect(Lexeme::Walrus, walrus)?;
let (body, empty) = parse_exprv(tail, None, ctx)?;
empty.expect_empty()?;
let value = vec_to_single(tail.fallback, body)?;
Ok((name, value))
})
}
struct Impl {
target: VName,
value: Expr<VName>,
}
fn extract_impls(
tail: Stream,
ctx: &(impl Context + ?Sized),
location: Location,
typeid_name: Tok<String>,
) -> ProjectResult<(Vec<FileEntry>, Vec<Impl>)> {
let mut lines = Vec::new();
let mut impls = Vec::new(); // name1, value1, name2, value2, etc...
for line in split_lines(tail) {
match parse_impl(line, ctx) {
Some(result) => {
let (name, value) = result?;
impls.push(Impl { target: pushed(name, typeid_name.clone()), value });
},
None => lines.extend(
parse_line(line, ctx)?.into_iter().map(|k| k.wrap(location.clone())),
),
}
}
Ok((lines, impls))
}
pub fn protocol_parser<'a>(
tail: Stream<'_>,
ctx: &'a (impl Context + ?Sized + 'a),
) -> LineParserOut {
let i = ctx.interner();
custom_line(tail, i.i("protocol"), true).map(|res| {
let (exported, tail, line_loc) = res?;
let (name, tail) = tail.pop()?;
let name = ExpectedName::expect(name)?;
let tail = ExpectedBlock::expect(tail, PType::Par)?;
let protoid = RefEqual::new();
let (lines, impls) =
extract_impls(tail, ctx, line_loc.clone(), i.i("__type_id__"))?;
let prelude = "
import std::protocol
const resolve := protocol::resolve __protocol__
const get_impl := protocol::get_impl __protocol__
";
let body = parse_entries(ctx, prelude, line_loc.clone())?
.into_iter()
.chain(
[
("__protocol_id__", protoid.clone().ast_cls()),
(
"__protocol__",
defer_to_runtime(
impls.into_iter().flat_map(|Impl { target, value }| {
[ast::Clause::Name(target).into_expr(), value]
.map(|e| ((), vec![e]))
}),
{
let name = name.clone();
move |pairs: Vec<((), ExprInst)>| {
let mut impls = HashMap::new();
debug_assert!(
pairs.len() % 2 == 0,
"names and values pair up"
);
let mut nvnvnv = pairs.into_iter().map(|t| t.1);
while let Some((name, value)) = nvnvnv.next_tuple() {
let key = name.downcast::<RefEqual>()?;
impls.insert(key, value);
}
let id = protoid.clone();
let display_name = name.clone();
Ok(Protocol(Arc::new(TypeData { id, display_name, impls })))
}
},
),
),
]
.map(|(n, value)| {
let value = Expr { value, location: line_loc.clone() };
MemberKind::Constant(Constant { name: i.i(n), value })
.to_entry(true, line_loc.clone())
}),
)
.chain(lines)
.collect();
let kind = MemberKind::Module(ModuleBlock { name, body });
Ok(vec![FileEntryKind::Member(Member { exported, kind })])
})
}
pub fn type_parser(
tail: Stream,
ctx: &(impl Context + ?Sized),
) -> LineParserOut {
let i = ctx.interner();
custom_line(tail, ctx.interner().i("type"), true).map(|res| {
let (exported, tail, line_loc) = res?;
let (name, tail) = tail.pop()?;
let name = ExpectedName::expect(name)?;
let tail = ExpectedBlock::expect(tail, PType::Par)?;
let typeid = RefEqual::new();
let (lines, impls) =
extract_impls(tail, ctx, line_loc.clone(), i.i("__protocol_id__"))?;
let prelude = "
import std::protocol
const unwrap := protocol::unwrap __type_tag__
const wrap := protocol::wrap __type_tag__
";
let body = parse_entries(ctx, prelude, line_loc.clone())?
.into_iter()
.chain(
[
("__type_id__", typeid.clone().ast_cls()),
(
"__type_tag__",
defer_to_runtime(
impls.into_iter().flat_map(|Impl { target, value }| {
[ast::Clause::Name(target).into_expr(), value]
.map(|e| ((), vec![e]))
}),
{
let name = name.clone();
move |pairs: Vec<((), ExprInst)>| {
let mut impls = HashMap::new();
debug_assert!(
pairs.len() % 2 == 0,
"names and values pair up"
);
let mut nvnvnv = pairs.into_iter().map(|t| t.1);
while let Some((name, value)) = nvnvnv.next_tuple() {
let key = name.downcast::<RefEqual>()?;
impls.insert(key, value);
}
let id = typeid.clone();
let display_name = name.clone();
Ok(Tag(Arc::new(TypeData { id, display_name, impls })))
}
},
),
),
]
.map(|(n, value)| {
let value = Expr { value, location: line_loc.clone() };
MemberKind::Constant(Constant { name: i.i(n), value })
.to_entry(true, line_loc.clone())
}),
)
.chain(lines)
.collect();
let kind = MemberKind::Module(ModuleBlock { name, body });
Ok(vec![FileEntryKind::Member(Member { exported, kind })])
})
}
pub fn parsers() -> Vec<Box<dyn LineParser>> {
vec![
Box::new(|tail, ctx| protocol_parser(tail, ctx)),
Box::new(|tail, ctx| type_parser(tail, ctx)),
]
}
pub fn unwrap(tag: Tag, tagged: Tagged) -> XfnResult<ExprInst> {
if tagged.tag.strict_eq(&tag) {
return Ok(tagged.value);
}
let msg = format!("{:?} is not {:?}", tagged.tag, tag);
RuntimeError::fail(msg, "unwrapping type-tagged value")
}
pub fn wrap(tag: Tag, value: ExprInst) -> XfnResult<Tagged> {
Ok(Tagged { tag, value })
}
pub fn resolve(protocol: Protocol, tagged: Tagged) -> XfnResult<ExprInst> {
get_impl(protocol, tagged.tag)
}
pub fn get_impl(proto: Protocol, tag: Tag) -> XfnResult<ExprInst> {
if let Some(implem) = proto.0.impls.get(&tag.0.id) {
return Ok(implem.clone());
}
if let Some(implem) = tag.0.impls.get(&proto.0.id) {
return Ok(implem.clone());
}
let message = format!("{:?} doesn't implement {:?}", tag, proto);
RuntimeError::fail(message, "dispatching protocol")
}
pub fn protocol_lib(i: &Interner) -> ConstTree {
ConstTree::namespace(
[i.i("protocol")],
ConstTree::tree([
(i.i("unwrap"), ConstTree::xfn(xfn_2ary(unwrap))),
(i.i("wrap"), ConstTree::xfn(xfn_2ary(wrap))),
(i.i("get_impl"), ConstTree::xfn(xfn_2ary(get_impl))),
(i.i("resolve"), ConstTree::xfn(xfn_2ary(resolve))),
]),
)
}

69
src/systems/stl/reflect.rs Normal file
View File

@@ -0,0 +1,69 @@
use std::cmp::Ordering;
use std::fmt::Debug;
use std::hash::Hash;
use std::sync::Arc;
use crate::foreign::{xfn_2ary, InertAtomic};
use crate::{ConstTree, Interner, Sym};
#[derive(Debug, Clone)]
pub struct SymbolName(pub Sym);
impl InertAtomic for SymbolName {
fn type_str() -> &'static str { "SymbolName" }
}
// #[derive(Debug, Clone)]
// pub struct GetSymName;
// impl ExternFn for GetSymName {
// fn name(&self) -> &str { "GetSymName" }
// fn apply(
// self: Box<Self>,
// arg: ExprInst,
// _: Context,
// ) -> XfnResult<Clause> { arg.inspect(|c| match c { Clause::Constant(name)
// => Ok(SymbolName(name.clone()).atom_cls()), _ =>
// AssertionError::fail(arg.location(), "is not a constant name"), })
// }
// }
#[derive(Clone)]
pub struct RefEqual(Arc<u8>);
impl RefEqual {
pub fn new() -> Self { Self(Arc::new(0u8)) }
pub fn id(&self) -> usize { &*self.0 as *const u8 as usize }
}
impl Debug for RefEqual {
fn fmt(&self, f: &mut std::fmt::Formatter<'_>) -> std::fmt::Result {
f.debug_tuple("RefEqual").field(&self.id()).finish()
}
}
impl InertAtomic for RefEqual {
fn type_str() -> &'static str { "RefEqual" }
fn strict_eq(&self, other: &Self) -> bool { self == other }
}
impl Eq for RefEqual {}
impl PartialEq for RefEqual {
fn eq(&self, other: &Self) -> bool { self.id() == other.id() }
}
impl Ord for RefEqual {
fn cmp(&self, other: &Self) -> Ordering { self.id().cmp(&other.id()) }
}
impl PartialOrd for RefEqual {
fn partial_cmp(&self, other: &Self) -> Option<Ordering> {
Some(self.cmp(other))
}
}
impl Hash for RefEqual {
fn hash<H: std::hash::Hasher>(&self, state: &mut H) { self.id().hash(state) }
}
pub fn reflect(i: &Interner) -> ConstTree {
// ConstTree::tree([])
ConstTree::namespace(
[i.i("reflect")],
ConstTree::tree([(
i.i("ref_equal"),
ConstTree::xfn(xfn_2ary(|l: RefEqual, r: RefEqual| Ok(l.id() == r.id()))),
)]),
)
}

10
src/systems/stl/stl_system.rs
View File

@@ -10,6 +10,8 @@ use super::exit_status::exit_status;
use super::inspect::inspect;
use super::number::num;
use super::panic::panic;
use super::protocol::{parsers, protocol_lib};
use super::reflect::reflect;
use super::state::{state_handlers, state_lib};
use super::string::str;
use crate::facade::{IntoSystem, System};
@@ -40,8 +42,10 @@ impl IntoSystem<'static> for StlConfig {
+ exit_status(i)
+ num(i)
+ panic(i)
+ reflect(i)
+ state_lib(i)
+ str(i);
+ str(i)
+ protocol_lib(i);
let mk_impure_fns = || inspect(i);
let fns = if self.impure { pure_tree + mk_impure_fns() } else { pure_tree };
System {
@@ -57,8 +61,8 @@ impl IntoSystem<'static> for StlConfig {
}]),
}],
handlers: state_handlers(),
lexer_plugin: None,
line_parser: None,
lexer_plugins: vec![],
line_parsers: parsers(),
}
}
}

92
src/systems/stl/tuple.orc
View File

@@ -1,16 +1,84 @@
import super::(known::*, bool::*, number::*)
import super::(known::*, bool::*, number::*, match, macro)
const discard_args := \n. \value. (
if n == 0 then value
else \_. discard_args (n - 1) value
export type ty (
import super::super::(number::*, bool::*, macro, panic)
const discard_args := \n. \value. (
if n == 0 then value
else \_. discard_args (n - 1) value
)
macro gen_call macro::list_end =0x1p254=> \f.f
macro gen_call ( macro::list_item $item $tail ) =0x1p254=> \f. (gen_call $tail) (f $item)
export macro new ( $list ) =0x1p84=> wrap \f. (gen_call $list) (f (macro::length $list))
export const pick := \tuple. \i. (unwrap tuple) ( \size.
if size <= i then panic "Tuple index out of bounds"
else discard_args i \val. discard_args (size - 1 - i) val
)
export const length := \tuple. (unwrap tuple) \size. discard_args size size
export const apply := \tuple. \f. (unwrap tuple) f
)
export const pick := \tuple. \i. \n. tuple (
discard_args i \val. discard_args (n - 1 - i) val
const pick := ty::pick
const length := ty::length
const apply := ty::apply
macro t[..$items] =0x2p84=> ( ty::new ( macro::comma_list (..$items) ) )
export ::(t, size)
macro size ( t[..$items] ) =0x1p230=> macro::length macro::comma_list (..$items)
--[
request l -> pattern_walker l
pattern_walker end -> pattern_result
pattern_walker h ++ t -> await_pattern
await_pattern -> pattern_result
]--
( macro match::request ( t[ ..$items ] )
=0x1p230=> tuple_pattern
( macro::length macro::comma_list ( ..$items ) )
(
pattern_walker
(0) -- index of next item
macro::comma_list ( ..$items ) -- leftover items
)
)
( macro tuple_pattern $length ( pattern_result $expr ( $binds ) )
=0x1p254=> match::response (
if length match::value == $length
then $expr
else match::fail
) ( $binds )
)
( macro pattern_walker $length macro::list_end
=0x1p254=> pattern_result match::pass ( match::no_binds )
)
( macro pattern_walker (...$length) ( macro::list_item $next $tail )
=0x1p254=> pattern_await
(...$length)
( match::request $next )
( pattern_walker (...$length + 1) $tail )
)
( macro pattern_await $length
( match::response $expr ( $binds ) )
( pattern_result $tail_expr ( $tail_binds ) )
=0x1p254=>
pattern_result
(
(\match::pass. (\match::value. $expr) (pick match::value $length)) (
match::take_binds $binds (
(\match::pass. $tail_expr) ( match::take_binds $tail_binds (
match::give_binds
match::chain_binds $binds $tail_binds
match::pass
))
)
)
)
( match::chain_binds $binds $tail_binds )
)
macro t[...$item, ...$rest:1] =0x2p84=> (\f. t[...$rest] (f (...$item)))
macro t[...$end] =0x1p84=> (\f. f (...$end))
macro t[] =0x1p84=> \f.f
export ::(t)