Basic lenses and a macro for deriving them.

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())
+        })
+    }
+}

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(

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 }

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, (^), (&), (^.) }