From 7e472abde06c169fc0ff10be6928e2e73b69b347 Mon Sep 17 00:00:00 2001 From: Markus Westerlind Date: Thu, 1 Nov 2018 21:17:45 +0100 Subject: [PATCH] fix: Handle forall before variant constructors --- check/src/typecheck.rs | 64 ++++++++++++++++++++++++++++++++---------- check/tests/forall.rs | 18 ++++++++++++ test.glu | 49 +++++++++++++++++++------------- 3 files changed, 96 insertions(+), 35 deletions(-) diff --git a/check/src/typecheck.rs b/check/src/typecheck.rs index dbe84357e5..90bdb08ad3 100644 --- a/check/src/typecheck.rs +++ b/check/src/typecheck.rs @@ -478,23 +478,49 @@ impl<'a> Typecheck<'a> { // Some "" // ``` let aliased_type = alias.typ(); - let canonical_alias = resolve::canonical_alias(&self.environment, &aliased_type, |alias| { - match **alias.unresolved_type().remove_forall() { - Type::Variant(_) => true, - _ => false, + let canonical_alias_type = + resolve::canonical_alias(&self.environment, &aliased_type, |alias| { + match **alias.unresolved_type().remove_forall() { + Type::Variant(_) => true, + _ => false, + } + }); + + fn unpack_canonical_alias<'a>( + alias: &'a Alias, + canonical_alias_type: &'a ArcType, + ) -> ( + Cow<'a, [Generic]>, + &'a AliasRef, + Cow<'a, ArcType>, + ) { + match **canonical_alias_type { + Type::App(ref func, _) => match **func { + Type::Alias(ref alias) => (Cow::Borrowed(&[]), alias, alias.typ()), + _ => (Cow::Borrowed(&[]), &**alias, Cow::Borrowed(func)), + }, + Type::Alias(ref alias) => (Cow::Borrowed(&[]), alias, alias.typ()), + Type::Forall(ref params, ref typ, None) => { + let mut params = Cow::Borrowed(¶ms[..]); + let (more_params, canonical_alias, inner_type) = + unpack_canonical_alias(alias, typ); + if !more_params.is_empty() { + params.to_mut().extend(more_params.iter().cloned()); + } + (params, canonical_alias, inner_type) + } + _ => ( + Cow::Borrowed(&[]), + &**alias, + Cow::Borrowed(canonical_alias_type), + ), } - }); + } - let canonical_alias = match **canonical_alias.remove_forall() { - Type::App(ref func, _) => match **func { - Type::Alias(ref alias) => alias.typ(), - _ => Cow::Borrowed(func), - }, - Type::Alias(ref alias) => alias.typ(), - _ => Cow::Borrowed(canonical_alias.remove_forall()), - }; + let (outer_params, canonical_alias, inner_type) = + unpack_canonical_alias(alias, &canonical_alias_type); - if let Type::Variant(ref variants) = **canonical_alias { + if let Type::Variant(ref variants) = **inner_type { for field in variants.row_iter().cloned() { let ctor_type = self.type_cache.function( field @@ -513,7 +539,15 @@ impl<'a> Typecheck<'a> { ); self.stack_var( field.name, - Type::forall(alias.params().to_owned(), ctor_type), + Type::forall( + canonical_alias + .params() + .iter() + .chain(outer_params.iter()) + .cloned() + .collect(), + ctor_type, + ), ); } } diff --git a/check/tests/forall.rs b/check/tests/forall.rs index a3d57d1aca..f963bd673e 100644 --- a/check/tests/forall.rs +++ b/check/tests/forall.rs @@ -1115,3 +1115,21 @@ let foo : (forall i . Proxy i -> ()) -> Proxy i -> () = assert!(result.is_ok(), "{}", result.unwrap_err()); } + +#[test] +fn forall_in_alias() { + let _ = ::env_logger::try_init(); + + let text = r#" +type IO a = | IO a + +type Lift m v = forall a . (| Lift (m a)) + +let z io : IO a -> Lift IO _ = Lift io + +() +"#; + let result = support::typecheck(text); + + assert!(result.is_ok(), "{}", result.unwrap_err()); +} diff --git a/test.glu b/test.glu index 113b2311b2..5cc25056f3 100644 --- a/test.glu +++ b/test.glu @@ -10,42 +10,39 @@ type VE w r = | Value w | Effect (r (VE w r)) type Eff r a = { run_effect : forall w . (a -> VE w r) -> VE w r } -let functor_eff : Functor (Eff r) = { +let functor : Functor (Eff r) = { map = error "" } -let applicative_eff : Applicative (Eff r) = { - functor = functor_eff, +let applicative : Applicative (Eff r) = { + functor, apply = error "", wrap = \x -> { run_effect = \k -> k x }, } -let monad_eff : Monad (Eff r) = { - applicative = applicative_eff, +let monad : Monad (Eff r) = { + applicative, flat_map = \f m -> { run_effect = \k -> m.run_effect (\v -> (f v).run_effect k) } } -type Opt a r = [ option : Option | a ] r +type Opt r a = [ option : Option | r ] a let send f : forall a . (forall w . (a -> VE w r) -> r (VE w r)) -> Eff r a = { run_effect = \k -> Effect (f k) } // let send2 t : r a -> Eff r a = { run_effect = \k -> Effect (r t) } let admin eff : Eff r a -> VE a r = eff.run_effect Value -let inject : f a -> [f : f | r] (VE a [f : f | r]) = any () -let option_eff : Option a -> [option : Option | r] (VE a [option : Option | r]) = any () +let inject : f a -> [f : f | r] a = any () +let option_eff : Option a -> Opt r (VE a [option : Option | r]) = any () let io_eff : IO a -> [io : IO | r] (VE a [io : IO | r]) = any () -// let row : { option : Monad Option, io : Monad IO } = { option = option.monad, io = io.monad } -// let applicative_eff : Applicative (Eff _) = applicative_eff row -// let monad = monad_eff row type Found f a r = | Found (f a) | NotFound ([| r] a) let proj : forall f . [f : f | r] a -> (Found f a r) = any () let option_empty : Eff [option : Option | r] Int = send (\x -> option_eff None) -type Lift m v = forall a . { monad : (m a), cont : (a -> v) } -let lift_io io : IO a -> Eff [f : Lift IO | r] a = send (\x -> inject (let z : Lift IO a = { monad = io, cont = x } in z)) +type Lift m v = forall a . (| Lift (m a) (a -> v)) +let lift_io io : IO a -> Eff [f : Lift IO | r] a = send (\x -> inject (Lift io x)) let io_effect : Eff [f : Lift IO | r] Int = lift_io (wrap 123) @@ -73,12 +70,24 @@ let run_option eff : [Functor [| r]] -> Eff [f : Option | r] a -> Eff [| r] (Opt flat_map loop (send (\k -> map k rest)) loop (admin eff) +let run_lift eff : [Monad m] -> Eff [f : Lift m] a -> m a = + let loop ve : VE a [f : Lift m] -> m a = + match ve with + | Value v -> wrap v + | Effect e -> + match proj e with + | Found x -> + match x with + | Lift m f -> + do a = m + loop (f a) + | NotFound _ -> error "unreachable" + loop (admin eff) -// let run_io eff : Eff [io : IO | r] a -> IO a = -// match admin eff with -// | IO x -> x -// | _ -> any () +let effect = + do x = option_empty + do y = io_effect + wrap (x #Int+ y) -do x = option_empty -do y = io_effect -wrap (x #Int+ y) +let final : IO (Option Int) = run_lift (run_option effect) +final