diff --git a/src/computation/haskell/haskell.H b/src/computation/haskell/haskell.H index 748f3911b..845aede07 100644 --- a/src/computation/haskell/haskell.H +++ b/src/computation/haskell/haskell.H @@ -1200,7 +1200,7 @@ struct ModuleDecls { Decls type_decls; - std::optional default_decl; + std::vector> default_decls; std::vector fixity_decls; diff --git a/src/computation/haskell/haskell.cc b/src/computation/haskell/haskell.cc index c629d3521..7df803140 100644 --- a/src/computation/haskell/haskell.cc +++ b/src/computation/haskell/haskell.cc @@ -980,12 +980,7 @@ ModuleDecls::ModuleDecls(const Decls& topdecls) else if (decl.is_a()) type_decls.push_back(ldecl); else if (auto d = decl.to()) - { - if (default_decl) - throw myexception()<<"Found more than 1 default declaration in module!"; - else - default_decl = *d; - } + default_decls.push_back({loc,*d}); else throw myexception()<<"I don't recognize declaration '"<> rename_default_decls(std::vector>); + + Hs::DefaultDecl rename(Hs::DefaultDecl); + Hs::Exp rename(const Hs::Exp& E, const bound_var_info& bound, std::set& free_vars); Hs::LExp rename(Hs::LExp E, const bound_var_info& bound, std::set& free_vars); diff --git a/src/computation/rename/rename.cc b/src/computation/rename/rename.cc index c1bec8d6b..68850c9e7 100644 --- a/src/computation/rename/rename.cc +++ b/src/computation/rename/rename.cc @@ -92,6 +92,7 @@ Hs::ModuleDecls rename_infix(const Module& m, Hs::ModuleDecls M) // 1. Handle value decls M.value_decls = rename_infix(m, M.value_decls); + // default_decls aren't infix for(auto& [_,type_decl]: M.type_decls) { // 2. Handle default method decls @@ -220,6 +221,8 @@ Haskell::ModuleDecls rename(const simplifier_options&, const Module& m, Haskell: M.type_decls = Rn.rename_type_decls(M.type_decls); + M.default_decls = Rn.rename_default_decls(M.default_decls); + // Find all the names bound HERE, versus in individual decls. // The idea is that we only add unqualified names here, and they shadow diff --git a/src/computation/rename/types.cc b/src/computation/rename/types.cc index 73d1d8526..769226ac1 100644 --- a/src/computation/rename/types.cc +++ b/src/computation/rename/types.cc @@ -276,6 +276,25 @@ Haskell::KindSigDecl renamer_state::rename(Haskell::KindSigDecl KS) return KS; } +Hs::DefaultDecl renamer_state::rename(Hs::DefaultDecl DD) +{ + if (DD.maybe_class) + { + auto [loc, class_name] = *DD.maybe_class; + auto renamed_tycon = rename_type(Hs::LTypeCon({loc,class_name})); + DD.maybe_class = {{loc,unloc(renamed_tycon).name}}; + } + for(auto& type: DD.types) + type = rename_type(type); + return DD; +} + +vector> renamer_state::rename_default_decls(vector> default_decls) +{ + for(auto& [loc, decl]: default_decls) + decl = rename(decl); + return default_decls; +} Haskell::Decls renamer_state::rename_type_decls(Haskell::Decls decls) { diff --git a/src/computation/typecheck/default.cc b/src/computation/typecheck/default.cc index ab38f1d81..35f4bb326 100644 --- a/src/computation/typecheck/default.cc +++ b/src/computation/typecheck/default.cc @@ -15,9 +15,50 @@ using std::tuple; void TypeChecker::get_defaults(const Hs::ModuleDecls& M) { - if (M.default_decl) - defaults() = desugar( M.default_decl->types ); - else if (this_mod().language_extensions.has_extension(LangExt::ExtendedDefaultRules)) + auto Num = find_prelude_tycon("Num"); + + for(auto& [loc,default_decl]: M.default_decls) + { + push_source_span(*loc); + if (auto dclass = default_decl.maybe_class) + { + bool named_defaults = this_mod().language_extensions.has_extension(LangExt::NamedDefaults); + + { + push_source_span(*dclass->loc); + if (not named_defaults) + record_error( Note() <<"Class-specific defaults only allowed with extension NamedDefaults" ); + if (default_env().count(TypeCon(*dclass))) + { + record_error( Note() <<"Duplicate default declaration." ); + // Original declaration at location; default_env().find->first.loc + } + pop_source_span(); + } + // Check that the data types are all data types and instances of the class? + default_env().insert({TypeCon(*dclass), desugar(default_decl.types)}); + } + else + { + if (default_env().count(Num)) + { + record_error( Note() <<"Duplicate default declaration." ); + } + // Check that the data types are all data types and instances of the class? + default_env().insert({Num, desugar( default_decl.types )}); + } + pop_source_span(); + } + + if (not default_env().count(Num)) + { + auto Integer = find_prelude_tycon("Integer"); + auto Double = find_prelude_tycon("Double"); + default_env().insert({Num, {Integer, Double}}); + } + + /* + if (this_mod().language_extensions.has_extension(LangExt::ExtendedDefaultRules)) { defaults() = { TypeCon({noloc,"()"}), TypeCon({noloc,"[]"}), TypeCon({noloc,"Integer"}), TypeCon({noloc,"Double"}) }; @@ -31,6 +72,7 @@ void TypeChecker::get_defaults(const Hs::ModuleDecls& M) if (this_mod().language_extensions.has_extension(LangExt::OverloadedStrings)) defaults().push_back( list_type( TypeCon({noloc,"Char"}) ) ); } + */ } // Constraints for defaulting must be of the form K a (e.g. Num a) where a is a MetaTypeVar. @@ -105,7 +147,8 @@ TypeChecker::candidates(const MetaTypeVar& tv, const LIE& tv_wanteds) // Fail if none of the predicates is a numerical constraint if (not any_num or (extended and not any_interactive and not any_num)) return false; - for(auto& type: defaults() ) + auto Num = find_prelude_tycon("Num"); + for(auto& type: default_env().at(Num)) { tv.fill(type); auto wanteds = WantedConstraints(tv_wanteds); diff --git a/src/computation/typecheck/typecheck.H b/src/computation/typecheck/typecheck.H index 73d674708..6ce8e605d 100644 --- a/src/computation/typecheck/typecheck.H +++ b/src/computation/typecheck/typecheck.H @@ -40,13 +40,16 @@ global_value_env sig_env(const signature_env& signatures); typedef std::map KindSigEnv; +// Can the instances be something like (Log Double)? I suppose they could. +typedef std::map> DefaultEnv; + struct global_tc_state { Module& this_mod; // for name lookups like Bool, Num, etc. KindSigEnv kind_sigs; - std::vector defaults; + DefaultEnv default_env; std::optional unification_level; @@ -94,8 +97,8 @@ public: const TypeFamInfo* info_for_type_fam(const std::string& fname) const; - std::vector& defaults() {return global_state->defaults;} - const std::vector& defaults() const {return global_state->defaults;} + DefaultEnv& default_env() {return global_state->default_env;} + const DefaultEnv& default_env() const {return global_state->default_env;} std::vector& messages() {return this_mod().messages;} const std::vector& messages() const {return this_mod().messages;}