Commit bc918460 authored by John van Groningen's avatar John van Groningen
Browse files

allow deriving of a qualified type (more changes may be needed)

parent 921944dc
......@@ -326,11 +326,6 @@ where
# cs = {cs & cs_error = checkError type_def.td_ident "type synonym not allowed" cs.cs_error}
= (TA type_cons [], TypeConsSymb type_cons, type_defs, modules, heaps, cs)
= (TA type_cons [], TypeConsSymb type_cons, type_defs, modules, heaps, cs)
where
type_synonym_with_arguments (SynType _) arity
= arity>0
type_synonym_with_arguments _ _
= False
check_instance_type module_index (TB b) type_defs modules heaps cs
= (TB b, TypeConsBasic b, type_defs, modules,heaps, cs)
check_instance_type module_index TArrow type_defs modules heaps cs
......@@ -340,10 +335,39 @@ where
# tv = {tv & tv_info_ptr = tv_info_ptr}
= ( TV tv, TypeConsVar tv, type_defs, modules
, {heaps& hp_type_heaps = {hp_type_heaps & th_vars = th_vars}}, cs)
check_instance_type module_index type=:(TQualifiedIdent module_id type_name []) type_defs modules heaps cs
# (found,{decl_kind,decl_ident=type_ident,decl_index=type_index},cs) = search_qualified_ident module_id type_name TypeNameSpaceN cs
| not found
# cs_error = checkError ("'"+++module_id.id_name+++"'."+++type_name) "generic argument type undefined" cs.cs_error
= (type, TypeConsQualifiedIdent module_id type_name, type_defs, modules, heaps, {cs & cs_error=cs_error})
= case decl_kind of
STE_Imported STE_Type type_module
# (entry, cs_symbol_table) = readPtr type_ident.id_info cs.cs_symbol_table
# cs & cs_symbol_table = cs_symbol_table
# (type_index, type_module) = retrieveGlobalDefinition entry STE_Type module_index
# type_cons = MakeNewTypeSymbIdent type_ident 0
| type_index == NotFound
# cs_error = checkError type_ident "generic argument type undefined" cs.cs_error
-> (type, TypeConsQualifiedIdent module_id type_name, type_defs, modules, heaps, {cs & cs_error=cs_error})
# (type_def, type_defs, modules)
= getTypeDef module_index {glob_module=type_module, glob_object=type_index} type_defs modules
# type_cons = { type_cons & type_index = { glob_object = type_index, glob_module = type_module }}
| type_synonym_with_arguments type_def.td_rhs type_def.td_arity
# cs & cs_error = checkError type_def.td_ident "type synonym not allowed" cs.cs_error
-> (TA type_cons [], TypeConsSymb type_cons, type_defs, modules, heaps, cs)
-> (TA type_cons [], TypeConsSymb type_cons, type_defs, modules, heaps, cs)
_
# cs_error = checkError ("'"+++module_id.id_name+++"'."+++type_name) "not imported" cs.cs_error
-> (type, TypeConsQualifiedIdent module_id type_name, type_defs, modules, heaps, {cs & cs_error=cs_error})
check_instance_type module_index ins_type type_defs modules heaps cs=:{cs_error}
# cs_error = checkError {id_name="<>",id_info=nilPtr} "invalid generic type argument" cs_error
= (ins_type, TypeConsArrow, type_defs, modules, heaps, {cs & cs_error=cs_error})
type_synonym_with_arguments (SynType _) arity
= arity>0
type_synonym_with_arguments _ _
= False
get_generic_index :: !Ident !Index !*CheckState -> (!GlobalIndex, !*CheckState)
get_generic_index {id_name,id_info} mod_index cs=:{cs_symbol_table}
# (ste, cs_symbol_table) = readPtr id_info cs_symbol_table
......
......@@ -105,6 +105,7 @@ where
type_cons_to_str (TypeConsBasic bt) = toString bt
type_cons_to_str TypeConsArrow = "ARROW"
type_cons_to_str (TypeConsVar tv) = tv.tv_ident.id_name
type_cons_to_str (TypeConsQualifiedIdent _ type_name) = type_name
field_n_of_GenericTypeDefDescriptor :: !String -> Int
field_n_of_GenericTypeDefDescriptor "gtd_name" = 0
......
......@@ -1980,15 +1980,17 @@ where
= (derive_def, pState)
get_type_cons :: Type !*ParseState -> (TypeCons, !*ParseState)
get_type_cons (TA type_symb []) pState
get_type_cons (TA type_symb []) pState
= (TypeConsSymb type_symb, pState)
get_type_cons (TB tb) pState
get_type_cons (TB tb) pState
= (TypeConsBasic tb, pState)
get_type_cons TArrow pState
= (TypeConsArrow, pState)
get_type_cons (TV tv) pState
| isDclContext parseContext
= (TypeConsVar tv, pState)
= (TypeConsVar tv, pState)
get_type_cons (TQualifiedIdent module_id ident_name []) pState
= (TypeConsQualifiedIdent module_id ident_name, pState)
get_type_cons type pState
# pState = parseError "generic type" No " type constructor" pState
= (abort "no TypeCons", pState)
......
......@@ -445,7 +445,8 @@ instance == GenericDependency
= TypeConsSymb TypeSymbIdent
| TypeConsBasic BasicType
| TypeConsArrow
| TypeConsVar TypeVar
| TypeConsVar TypeVar
| TypeConsQualifiedIdent !Ident !String
:: GenericCaseDef =
{ gc_pos :: !Position // position in the source file
......
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment