Commit 3d0575cf authored by Martin Wierich's avatar Martin Wierich
Browse files

adding error message:left root * attribute expected

parent 58fd6750
implementation module analtypes implementation module analtypes
import StdEnv import StdEnv
import syntax, checksupport, checktypes, check, typesupport, utilities, RWSDebug import syntax, checksupport, checktypes, check, typesupport, utilities, analunitypes, RWSDebug
:: UnifyKindsInfo = :: UnifyKindsInfo =
{ uki_kind_heap ::!.KindHeap { uki_kind_heap ::!.KindHeap
...@@ -470,7 +470,10 @@ analTypeDefs modules used_module_numbers heaps error ...@@ -470,7 +470,10 @@ analTypeDefs modules used_module_numbers heaps error
as_next_num = 0, as_deps = [], as_next_group_num = 0, as_error = error } as_next_num = 0, as_deps = [], as_next_group_num = 0, as_error = error }
{as_td_infos,as_heaps,as_error} = anal_type_defs modules 0 sizes as {as_td_infos,as_heaps,as_error} = anal_type_defs modules 0 sizes as
= (as_td_infos, as_heaps, as_error) (as_td_infos, th_vars, as_error)
= foldSt (check_left_root_attribution_of_typedef_in_module modules)
[(s,i) \\ s<-sizes & i<-[0..]] (as_td_infos, as_heaps.th_vars, as_error)
= (as_td_infos, { as_heaps & th_vars = th_vars }, as_error)
where where
anal_type_defs modules mod_index [ size : sizes ] as anal_type_defs modules mod_index [ size : sizes ] as
# as = iFoldSt (anal_type_def modules mod_index) 0 size as # as = iFoldSt (anal_type_def modules mod_index) 0 size as
...@@ -484,6 +487,11 @@ where ...@@ -484,6 +487,11 @@ where
= as = as
= as = as
check_left_root_attribution_of_typedef_in_module modules (siz,mod_index) (as_td_infos, th_vars, as_error)
= iFoldSt (checkLeftRootAttributionOfTypeDef modules mod_index)
0 siz (as_td_infos, th_vars, as_error)
instance == AttributeVar instance == AttributeVar
where where
(==) av1 av2 = av1.av_info_ptr == av2.av_info_ptr (==) av1 av2 = av1.av_info_ptr == av2.av_info_ptr
...@@ -491,3 +499,71 @@ where ...@@ -491,3 +499,71 @@ where
instance <<< DynamicType instance <<< DynamicType
where where
(<<<) file {dt_global_vars,dt_type} = file <<< dt_global_vars <<< dt_type (<<<) file {dt_global_vars,dt_type} = file <<< dt_global_vars <<< dt_type
checkLeftRootAttributionOfTypeDef :: !{# CommonDefs} !Index !Index !(!*TypeDefInfos, !*TypeVarHeap, !*ErrorAdmin)
-> (!*TypeDefInfos, !*TypeVarHeap, !*ErrorAdmin)
checkLeftRootAttributionOfTypeDef common_defs mod_index type_index (td_infos, th_vars, error)
# {td_rhs, td_attribute, td_name, td_pos}
= common_defs.[mod_index].com_type_defs.[type_index]
| isUniqueAttr td_attribute
= (td_infos, th_vars, error)
# (is_unique, (td_infos, th_vars))
= isUniqueTypeRhs common_defs mod_index td_rhs (td_infos, th_vars)
| is_unique
= (td_infos, th_vars, checkErrorWithIdentPos (newPosition td_name td_pos)
" left root * attribute expected" error)
= (td_infos, th_vars, error)
isUniqueTypeRhs common_defs mod_index (AlgType constructors) state
= one_constructor_is_unique common_defs mod_index constructors state
isUniqueTypeRhs common_defs mod_index (SynType rhs) state
= isUnique common_defs rhs state
isUniqueTypeRhs common_defs mod_index (RecordType {rt_constructor}) state
= one_constructor_is_unique common_defs mod_index [rt_constructor] state
isUniqueTypeRhs common_defs mod_index _ state
= (False, state)
one_constructor_is_unique common_defs mod_index [] state
= (False, state)
one_constructor_is_unique common_defs mod_index [{ds_index}:constructors] state
# {cons_type}
= common_defs.[mod_index].com_cons_defs.[ds_index]
(uniqueness_of_args, state)
= mapSt (isUnique common_defs) cons_type.st_args state
= (or uniqueness_of_args, state)
class isUnique a :: !{# CommonDefs} !a !(!*TypeDefInfos, !*TypeVarHeap) -> (!Bool, !(!*TypeDefInfos, !*TypeVarHeap))
instance isUnique AType
where
isUnique common_defs {at_attribute=TA_Unique} state
= (True, state)
isUnique common_defs {at_type} state
= isUnique common_defs at_type state
instance isUnique Type
where
isUnique common_defs (TA {type_index={glob_module, glob_object}} type_args) (td_infos, th_vars)
# type_def
= common_defs.[glob_module].com_type_defs.[glob_object]
| isUniqueAttr type_def.td_attribute
= (True, (td_infos, th_vars))
# (prop_classification, th_vars, td_infos)
= propClassification glob_object glob_module (repeatn type_def.td_arity 0)
common_defs th_vars td_infos
(uniqueness_of_args, (td_infos, th_vars))
= mapSt (isUnique common_defs) type_args (td_infos, th_vars)
= (unique_if_arg_is_unique_and_propagating uniqueness_of_args prop_classification, (td_infos, th_vars))
where
unique_if_arg_is_unique_and_propagating [] _
= False
unique_if_arg_is_unique_and_propagating [is_unique_argument:rest] prop_classification
| isOdd prop_classification /*MW:cool!*/ && is_unique_argument
= True
= unique_if_arg_is_unique_and_propagating rest (prop_classification>>1)
isUnique common_defs _ state
= (False, state)
isUniqueAttr TA_Unique = True
isUniqueAttr _ = False
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