add Effect.always and Effect.map

This commit is contained in:
Folkert 2020-11-09 19:14:26 +01:00
parent 14d6de626e
commit 492f0dcc84
3 changed files with 842 additions and 403 deletions

View file

@ -8,7 +8,7 @@ use roc_builtins::std::{Mode, StdLib};
use roc_can::constraint::Constraint;
use roc_can::def::Declaration;
use roc_can::module::{canonicalize_module_defs, Module};
use roc_collections::all::{default_hasher, MutMap, MutSet, SendMap};
use roc_collections::all::{default_hasher, MutMap, MutSet};
use roc_constrain::module::{
constrain_imports, pre_constrain_imports, ConstrainableImports, Import,
};
@ -2253,399 +2253,6 @@ fn run_solve<'a>(
}
}
fn fabricate_effect_after(
env: &mut roc_can::env::Env,
scope: &mut roc_can::scope::Scope,
effect_symbol: Symbol,
effect_tag_name: TagName,
var_store: &mut VarStore,
) -> (Symbol, roc_can::def::Def) {
use roc_can::expr::Expr;
use roc_can::expr::Recursive;
use roc_module::operator::CalledVia;
let thunk_symbol = {
scope
.introduce(
"thunk".into(),
&env.exposed_ident_ids,
&mut env.ident_ids,
Region::zero(),
)
.unwrap()
};
let to_effect_symbol = {
scope
.introduce(
"toEffect".into(),
&env.exposed_ident_ids,
&mut env.ident_ids,
Region::zero(),
)
.unwrap()
};
let after_symbol = {
scope
.introduce(
"after".into(),
&env.exposed_ident_ids,
&mut env.ident_ids,
Region::zero(),
)
.unwrap()
};
// `thunk {}`
let force_thunk_call = {
let boxed = (
var_store.fresh(),
Located::at_zero(Expr::Var(thunk_symbol)),
var_store.fresh(),
var_store.fresh(),
);
let arguments = vec![(var_store.fresh(), Located::at_zero(Expr::EmptyRecord))];
Expr::Call(Box::new(boxed), arguments, CalledVia::Space)
};
// `toEffect (thunk {})`
let to_effect_call = {
let boxed = (
var_store.fresh(),
Located::at_zero(Expr::Var(to_effect_symbol)),
var_store.fresh(),
var_store.fresh(),
);
let arguments = vec![(var_store.fresh(), Located::at_zero(force_thunk_call))];
Expr::Call(Box::new(boxed), arguments, CalledVia::Space)
};
use roc_can::pattern::Pattern;
let arguments = vec![
(
var_store.fresh(),
Located::at_zero(Pattern::AppliedTag {
whole_var: var_store.fresh(),
ext_var: var_store.fresh(),
tag_name: effect_tag_name.clone(),
arguments: vec![(
var_store.fresh(),
Located::at_zero(Pattern::Identifier(thunk_symbol)),
)],
}),
),
(
var_store.fresh(),
Located::at_zero(Pattern::Identifier(to_effect_symbol)),
),
];
let function_var = var_store.fresh();
let after_closure = Expr::Closure {
function_type: function_var,
closure_type: var_store.fresh(),
closure_ext_var: var_store.fresh(),
return_type: var_store.fresh(),
name: after_symbol,
captured_symbols: Vec::new(),
recursive: Recursive::NotRecursive,
arguments,
loc_body: Box::new(Located::at_zero(to_effect_call)),
};
use roc_can::annotation::IntroducedVariables;
let mut introduced_variables = IntroducedVariables::default();
let signature = {
let var_a = var_store.fresh();
let var_b = var_store.fresh();
introduced_variables.insert_named("a".into(), var_a);
introduced_variables.insert_named("b".into(), var_b);
let effect_a = {
let actual =
build_effect_actual(effect_tag_name.clone(), Type::Variable(var_a), var_store);
Type::Alias(
effect_symbol,
vec![("a".into(), Type::Variable(var_a))],
Box::new(actual),
)
};
let effect_b = {
let actual = build_effect_actual(effect_tag_name, Type::Variable(var_b), var_store);
Type::Alias(
effect_symbol,
vec![("b".into(), Type::Variable(var_b))],
Box::new(actual),
)
};
let closure_var = var_store.fresh();
introduced_variables.insert_wildcard(closure_var);
let a_to_effect_b = Type::Function(
vec![Type::Variable(var_a)],
Box::new(Type::Variable(closure_var)),
Box::new(effect_b.clone()),
);
let closure_var = var_store.fresh();
introduced_variables.insert_wildcard(closure_var);
Type::Function(
vec![effect_a, a_to_effect_b],
Box::new(Type::Variable(closure_var)),
Box::new(effect_b),
)
};
let def_annotation = roc_can::def::Annotation {
signature,
introduced_variables,
aliases: SendMap::default(),
region: Region::zero(),
};
let pattern = Pattern::Identifier(after_symbol);
let mut pattern_vars = SendMap::default();
pattern_vars.insert(after_symbol, function_var);
let def = roc_can::def::Def {
loc_pattern: Located::at_zero(pattern),
loc_expr: Located::at_zero(after_closure),
expr_var: function_var,
pattern_vars,
annotation: Some(def_annotation),
};
(after_symbol, def)
}
fn fabricate_host_exposed_def(
env: &mut roc_can::env::Env,
scope: &mut roc_can::scope::Scope,
symbol: Symbol,
ident: &str,
effect_tag_name: TagName,
var_store: &mut VarStore,
annotation: roc_can::annotation::Annotation,
) -> roc_can::def::Def {
use roc_can::pattern::Pattern;
let expr_var = var_store.fresh();
let pattern = Pattern::Identifier(symbol);
let mut pattern_vars = SendMap::default();
pattern_vars.insert(symbol, expr_var);
use roc_can::expr::Expr;
use roc_can::expr::Recursive;
let mut arguments: Vec<(Variable, Located<Pattern>)> = Vec::new();
let mut linked_symbol_arguments: Vec<(Variable, Expr)> = Vec::new();
let mut captured_symbols: Vec<(Symbol, Variable)> = Vec::new();
let def_body = {
match annotation.typ.shallow_dealias() {
Type::Function(args, _, _) => {
for i in 0..args.len() {
let name = format!("closure_arg_{}_{}", ident, i);
let arg_symbol = {
let ident = name.clone().into();
scope
.introduce(
ident,
&env.exposed_ident_ids,
&mut env.ident_ids,
Region::zero(),
)
.unwrap()
};
let arg_var = var_store.fresh();
arguments.push((arg_var, Located::at_zero(Pattern::Identifier(arg_symbol))));
captured_symbols.push((arg_symbol, arg_var));
linked_symbol_arguments.push((arg_var, Expr::Var(arg_symbol)));
}
let foreign_symbol_name = format!("roc_fx_{}", ident);
let low_level_call = Expr::ForeignCall {
foreign_symbol: foreign_symbol_name.into(),
args: linked_symbol_arguments,
ret_var: var_store.fresh(),
};
let effect_closure_symbol = {
let name = format!("effect_closure_{}", ident);
let ident = name.into();
scope
.introduce(
ident,
&env.exposed_ident_ids,
&mut env.ident_ids,
Region::zero(),
)
.unwrap()
};
let empty_record_pattern = Pattern::RecordDestructure {
whole_var: var_store.fresh(),
ext_var: var_store.fresh(),
destructs: vec![],
};
let effect_closure = Expr::Closure {
function_type: var_store.fresh(),
closure_type: var_store.fresh(),
closure_ext_var: var_store.fresh(),
return_type: var_store.fresh(),
name: effect_closure_symbol,
captured_symbols,
recursive: Recursive::NotRecursive,
arguments: vec![(var_store.fresh(), Located::at_zero(empty_record_pattern))],
loc_body: Box::new(Located::at_zero(low_level_call)),
};
let body = Expr::Tag {
variant_var: var_store.fresh(),
ext_var: var_store.fresh(),
name: effect_tag_name,
arguments: vec![(var_store.fresh(), Located::at_zero(effect_closure))],
};
Expr::Closure {
function_type: var_store.fresh(),
closure_type: var_store.fresh(),
closure_ext_var: var_store.fresh(),
return_type: var_store.fresh(),
name: symbol,
captured_symbols: std::vec::Vec::new(),
recursive: Recursive::NotRecursive,
arguments,
loc_body: Box::new(Located::at_zero(body)),
}
}
_ => {
// not a function
let foreign_symbol_name = format!("roc_fx_{}", ident);
let low_level_call = Expr::ForeignCall {
foreign_symbol: foreign_symbol_name.into(),
args: linked_symbol_arguments,
ret_var: var_store.fresh(),
};
let effect_closure_symbol = {
let name = format!("effect_closure_{}", ident);
let ident = name.into();
scope
.introduce(
ident,
&env.exposed_ident_ids,
&mut env.ident_ids,
Region::zero(),
)
.unwrap()
};
let empty_record_pattern = Pattern::RecordDestructure {
whole_var: var_store.fresh(),
ext_var: var_store.fresh(),
destructs: vec![],
};
let effect_closure = Expr::Closure {
function_type: var_store.fresh(),
closure_type: var_store.fresh(),
closure_ext_var: var_store.fresh(),
return_type: var_store.fresh(),
name: effect_closure_symbol,
captured_symbols,
recursive: Recursive::NotRecursive,
arguments: vec![(var_store.fresh(), Located::at_zero(empty_record_pattern))],
loc_body: Box::new(Located::at_zero(low_level_call)),
};
Expr::Tag {
variant_var: var_store.fresh(),
ext_var: var_store.fresh(),
name: effect_tag_name,
arguments: vec![(var_store.fresh(), Located::at_zero(effect_closure))],
}
}
}
};
let def_annotation = roc_can::def::Annotation {
signature: annotation.typ,
introduced_variables: annotation.introduced_variables,
aliases: annotation.aliases,
region: Region::zero(),
};
roc_can::def::Def {
loc_pattern: Located::at_zero(pattern),
loc_expr: Located::at_zero(def_body),
expr_var,
pattern_vars,
annotation: Some(def_annotation),
}
}
fn build_effect_actual(effect_tag_name: TagName, a_type: Type, var_store: &mut VarStore) -> Type {
let closure_var = var_store.fresh();
Type::TagUnion(
vec![(
effect_tag_name,
vec![Type::Function(
vec![Type::EmptyRec],
Box::new(Type::Variable(closure_var)),
Box::new(a_type),
)],
)],
Box::new(Type::EmptyTagUnion),
)
}
fn unpack_exposes_entries<'a>(
arena: &'a Bump,
entries: &'a [Located<TypedIdent<'a>>],
) -> bumpalo::collections::Vec<'a, (&'a Located<&'a str>, &'a Located<TypeAnnotation<'a>>)> {
use bumpalo::collections::Vec;
let mut stack: Vec<&TypedIdent> = Vec::with_capacity_in(entries.len(), arena);
let mut output = Vec::with_capacity_in(entries.len(), arena);
for entry in entries.iter() {
stack.push(&entry.value);
}
while let Some(effects_entry) = stack.pop() {
match effects_entry {
TypedIdent::Entry {
ident,
spaces_before_colon: _,
ann,
} => {
output.push((ident, ann));
}
TypedIdent::SpaceAfter(nested, _) | TypedIdent::SpaceBefore(nested, _) => {
stack.push(nested);
}
}
}
output
}
fn fabricate_effects_module<'a>(
arena: &'a Bump,
module_ids: Arc<Mutex<ModuleIds>>,
@ -2664,7 +2271,7 @@ fn fabricate_effects_module<'a>(
let name = effects.type_name;
let declared_name: ModuleName = name.into();
let hardcoded_exposed_functions = vec![name, "after"];
let hardcoded_exposed_functions = vec![name, "after", "map", "always"];
let exposed_ident_ids = {
// Lock just long enough to perform the minimal operations necessary.
@ -2746,7 +2353,7 @@ fn fabricate_effects_module<'a>(
let alias = {
let a_var = var_store.fresh();
let actual = build_effect_actual(
let actual = crate::effect_module::build_effect_actual(
effect_tag_name.clone(),
Type::Variable(a_var),
&mut var_store,
@ -2790,7 +2397,7 @@ fn fabricate_effects_module<'a>(
&mut var_store,
);
let def = fabricate_host_exposed_def(
let def = crate::effect_module::build_host_exposed_def(
&mut can_env,
&mut scope,
symbol,
@ -2806,15 +2413,15 @@ fn fabricate_effects_module<'a>(
}
}
let (effect_after_symbol, def) = fabricate_effect_after(
// define Effect.after, Effect.map etc.
crate::effect_module::build_effect_builtins(
&mut can_env,
&mut scope,
effect_symbol,
effect_tag_name,
&mut var_store,
&mut exposed_vars_by_symbol,
&mut declarations,
);
exposed_vars_by_symbol.push((effect_after_symbol, def.expr_var));
declarations.push(Declaration::Declare(def));
exposed_vars_by_symbol
};
@ -2872,6 +2479,37 @@ fn fabricate_effects_module<'a>(
))
}
fn unpack_exposes_entries<'a>(
arena: &'a Bump,
entries: &'a [Located<TypedIdent<'a>>],
) -> bumpalo::collections::Vec<'a, (&'a Located<&'a str>, &'a Located<TypeAnnotation<'a>>)> {
use bumpalo::collections::Vec;
let mut stack: Vec<&TypedIdent> = Vec::with_capacity_in(entries.len(), arena);
let mut output = Vec::with_capacity_in(entries.len(), arena);
for entry in entries.iter() {
stack.push(&entry.value);
}
while let Some(effects_entry) = stack.pop() {
match effects_entry {
TypedIdent::Entry {
ident,
spaces_before_colon: _,
ann,
} => {
output.push((ident, ann));
}
TypedIdent::SpaceAfter(nested, _) | TypedIdent::SpaceBefore(nested, _) => {
stack.push(nested);
}
}
}
output
}
fn canonicalize_and_constrain<'a>(
arena: &'a Bump,
module_ids: &ModuleIds,