From 28399bbdb422393511551e3a8cc2497131aec364 Mon Sep 17 00:00:00 2001 From: bch29 Date: Tue, 15 Dec 2020 14:20:25 +0000 Subject: [PATCH 1/2] feat: Add basic lens functionality to standard library --- std/functor/const.glu | 27 ++++++++++++++++++++++++++ std/lens.glu | 44 +++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 71 insertions(+) create mode 100644 std/functor/const.glu create mode 100644 std/lens.glu diff --git a/std/functor/const.glu b/std/functor/const.glu new file mode 100644 index 0000000000..af568e9a32 --- /dev/null +++ b/std/functor/const.glu @@ -0,0 +1,27 @@ +let { Functor } = import! std.functor + +let { Applicative } = import! std.applicative + +let { Monoid, empty } = import! std.monoid + +let { (<>) } = import! std.semigroup + +type Const s a = { value : s } + +#[implicit] +let functor : forall s . Functor (Const s) = { + map = \f -> \c -> { value = c.value }, +} + +#[implicit] +let applicative : forall s . [Monoid s] -> Applicative (Const s) = { + functor, + apply = \f x -> { value = f.value <> x.value }, + wrap = \_ -> { value = empty } +} + +let app : s -> Const s a = \value -> { value } + +let run : Const s a -> s = \c -> c.value + +{ Const, functor, app, run } diff --git a/std/lens.glu b/std/lens.glu new file mode 100644 index 0000000000..3183cfd8c1 --- /dev/null +++ b/std/lens.glu @@ -0,0 +1,44 @@ +let { Functor, map } = import! std.functor +let const @ { Const, ? } = import! std.functor.const +let identity = import! std.identity + + +type Lens s t a b = { app : forall f . [Functor f] -> (a -> f b) -> s -> f t } + + +type Lens' s a = Lens s s a a + + +let view lens x : Lens s t a b -> s -> a = + let res = lens.app const.app x + res.value + + +let over lens f y : Lens s t a b -> (a -> b) -> s -> t = + lens.app ?identity.functor (\x -> (f x)) y + + +let set lens x : Lens s t a b -> b -> s -> t = over lens (\_ -> x) + + +let make view set : (s -> a) -> (b -> s -> t) -> Lens s t a b = + { + app = \k x -> map (\y -> set y x) (k (view x)), + } + + +#[infix(right, 8)] +let (^) g f : Lens j k s t -> Lens s t a b -> Lens j k a b = { + app = \k -> g.app (f.app k), +} + + +#[infix(left, 1)] +let (&) x g : a -> (a -> b) -> b = g x + + +#[infix(right, 9)] +let (^.) x lens : s -> Lens s t a b -> a = view lens x + + +{ Lens, Lens', view, set, over, make, (^), (&), (^.) } From fd0585f396efb73c4d101ac6ec3e510001bc5f25 Mon Sep 17 00:00:00 2001 From: bch29 Date: Tue, 15 Dec 2020 14:20:49 +0000 Subject: [PATCH 2/2] feat: Add macro for deriving lenses for record fields --- src/lens.rs | 182 ++++++++++++++++++++++++++++++++++++++++++++++++++++ src/lib.rs | 3 + 2 files changed, 185 insertions(+) create mode 100644 src/lens.rs diff --git a/src/lens.rs b/src/lens.rs new file mode 100644 index 0000000000..46046c9193 --- /dev/null +++ b/src/lens.rs @@ -0,0 +1,182 @@ +//! Implementation of the `lens!` macro. + +use gluon_codegen::Trace; + +use crate::{ + base::{ + ast::{self, AstClone, SpannedExpr}, + pos, + symbol::{Symbol, Symbols}, + types, + }, + vm::macros::{self, Macro, MacroExpander, MacroFuture}, +}; + +/// Macro for deriving field accessor lenses +/// +/// ```ignore +/// let lens = import! std.lens +/// +/// type MyRecord = { +/// x: Int, +/// y: String +/// } +/// +/// let _x = lens! lens MyRecord x +/// let _y = lens! lens MyRecord y +/// ``` +#[derive(Trace)] +#[gluon(crate_name = "vm")] +pub struct DeriveLens; + +impl Macro for DeriveLens { + fn expand<'r, 'a: 'r, 'b: 'r, 'c: 'r, 'ast: 'r>( + &self, + _env: &'b mut MacroExpander<'a>, + _symbols: &'c mut Symbols, + arena: &'b mut ast::OwnedArena<'ast, Symbol>, + args: &'b mut [SpannedExpr<'ast, Symbol>], + ) -> MacroFuture<'r, 'ast> { + Box::pin(async move { + let (module_arg, typ_arg, field_arg) = match args { + [module, typ, field] => (module, typ, field), + _ => return Err(macros::Error::message(format!("lens! expects 3 arguments"))), + }; + + let mut symbols = Symbols::new(); + + let typ = match &typ_arg.value { + ast::Expr::Ident(id) => id.clone(), + _ => { + return Err(macros::Error::message(format!( + "lens! expects an identifier as the second argument" + ))) + } + }; + + let field_ident = match &field_arg.value { + ast::Expr::Ident(id) => id.clone(), + _ => { + return Err(macros::Error::message(format!( + "lens! expects an identifier as the third argument" + ))) + } + }; + + let struct_var = ast::TypedIdent::new(symbols.simple_symbol("s")); + let get_var = ast::TypedIdent::new(symbols.simple_symbol("get")); + let set_var = ast::TypedIdent::new(symbols.simple_symbol("set")); + + let span = field_arg.span; + + let struct_ast_type = || { + ast::AstType::new_no_loc( + arena.borrow(), + types::Type::Ident(ast::TypedIdent { + name: typ.name.clone(), + typ: Default::default(), + }), + ) + }; + + let hole_type = || ast::AstType::new_no_loc(arena.borrow(), types::Type::Hole); + + let func_type = |a, b| { + ast::AstType::new_no_loc( + arena.borrow(), + types::Type::Function(types::ArgType::Explicit, a, b), + ) + }; + + let get_binding = arena.alloc(ast::ValueBinding { + metadata: Default::default(), + name: pos::spanned(span, ast::Pattern::Ident(get_var.clone())), + typ: Some(func_type(struct_ast_type(), hole_type())), + resolved_type: Default::default(), + args: arena.alloc_extend(vec![ast::Argument { + arg_type: types::ArgType::Explicit, + name: pos::spanned(span, struct_var.clone()), + }]), + expr: pos::spanned( + span, + ast::Expr::Projection( + arena.alloc(pos::spanned(span, ast::Expr::Ident(struct_var.clone()))), + field_ident.name.clone(), + field_ident.typ.clone(), + ), + ), + }); + + let set_binding = arena.alloc(ast::ValueBinding { + metadata: Default::default(), + name: pos::spanned(span, ast::Pattern::Ident(set_var.clone())), + typ: Some(func_type( + hole_type(), + func_type(struct_ast_type(), struct_ast_type()), + )), + resolved_type: Default::default(), + args: arena.alloc_extend(vec![ + ast::Argument { + arg_type: types::ArgType::Explicit, + name: pos::spanned(span, field_ident.clone()), + }, + ast::Argument { + arg_type: types::ArgType::Explicit, + name: pos::spanned(span, struct_var.clone()), + }, + ]), + expr: pos::spanned( + span, + ast::Expr::Record { + typ: Default::default(), + types: &mut [], + exprs: arena.alloc_extend(vec![ast::ExprField { + metadata: Default::default(), + name: pos::spanned(span, field_ident.name.clone()), + value: None, + }]), + base: Some( + arena.alloc(pos::spanned(span, ast::Expr::Ident(struct_var.clone()))), + ), + }, + ), + }); + + let lens_module = arena.alloc((*module_arg).ast_clone(arena.borrow())); + + let make_func = arena.alloc(pos::spanned( + span, + ast::Expr::Projection( + lens_module, + symbols.simple_symbol("make"), + Default::default(), + ), + )); + + let make_expr = arena.alloc(pos::spanned( + span, + ast::Expr::App { + func: make_func, + implicit_args: &mut [], + args: arena.alloc_extend(vec![ + pos::spanned(span, ast::Expr::Ident(get_var)), + pos::spanned(span, ast::Expr::Ident(set_var)), + ]), + }, + )); + + let result = pos::spanned( + span, + ast::Expr::LetBindings( + ast::ValueBindings::Plain(set_binding), + arena.alloc(pos::spanned( + span, + ast::Expr::LetBindings(ast::ValueBindings::Plain(get_binding), make_expr), + )), + ), + ); + + Ok(result.into()) + }) + } +} diff --git a/src/lib.rs b/src/lib.rs index a244db7726..5742ef2f68 100644 --- a/src/lib.rs +++ b/src/lib.rs @@ -49,6 +49,7 @@ pub mod compiler_pipeline; #[macro_use] pub mod import; pub mod lift_io; +pub mod lens; #[doc(hidden)] pub mod query; pub mod std_lib; @@ -958,6 +959,8 @@ impl VmBuilder { } macros.insert(String::from("lift_io"), lift_io::LiftIo); + + macros.insert(String::from("lens"), lens::DeriveLens); } add_extern_module_with_deps(