typesupport.dcl 6.44 KB
Newer Older
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
1
2
3
4
definition module typesupport

import checksupport, StdCompare

5
6
7
8
/*2.0
from unitype import ::Coercions, ::CoercionTree, ::AttributePartition, CT_Empty
0.2*/
//1.3
9
from unitype import Coercions, CoercionTree, AttributePartition, CT_Empty
10
//3.1
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
11

12
13
errorHeading :: !String !*ErrorAdmin -> *ErrorAdmin

14
15
16
17
// MW4 was:class (<::) infixl a :: !*File (!Format, !a) -> *File
(<::) infixl :: !*File (!Format, !a, !Optional TypeVarBeautifulizer) -> *File | writeType a

class writeType a :: !*File !(Optional TypeVarBeautifulizer) (!Format, !a) -> (!*File, !Optional TypeVarBeautifulizer)
18
19

:: Format =
20
21
	{	form_properties 	:: !BITVECT
	,	form_attr_position	:: Optional ([Int], Coercions)
22
23
24
	}

cNoProperties		:== 0
25
26
27
cAttributed			:== 1
cAnnotated			:== 2
cMarkAttribute		:== 4
28

29
30
31
32
33
:: TypeVarBeautifulizer // MW++

instance writeType SymbolType, Type, AType, [a] | writeType a

initialTypeVarBeautifulizer :: TypeVarBeautifulizer // MW4++
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
34
35
36
37
38
39
40

::	AttributeEnv	:== {! TypeAttribute }
::	VarEnv 			:== {! Type }

cleanSymbolType :: !Int !*TypeHeaps -> (!SymbolType, !*TypeHeaps)
extendSymbolType :: !SymbolType !Int !*TypeHeaps -> (!SymbolType, !*TypeHeaps)

Sjaak Smetsers's avatar
Sjaak Smetsers committed
41
42
43
cSpecifiedType	:== True
cDerivedType	:== False

clean's avatar
clean committed
44
cleanUpSymbolType :: !Bool !Bool !TempSymbolType ![TypeContext] ![ExprInfoPtr] !{! CoercionTree} !AttributePartition
Sjaak Smetsers's avatar
Sjaak Smetsers committed
45
46
						!*VarEnv !*AttributeEnv !*TypeHeaps !*VarHeap !*ExpressionHeap !*ErrorAdmin
							-> (!SymbolType, !*VarEnv, !*AttributeEnv, !*TypeHeaps, !*VarHeap, !*ExpressionHeap, !*ErrorAdmin)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
47

Sjaak Smetsers's avatar
Sjaak Smetsers committed
48
equivalent :: !SymbolType !TempSymbolType !Int !{# CommonDefs} !*AttributeEnv !*TypeHeaps -> (!Bool, !*AttributeEnv, !*TypeHeaps) 
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
49

50
51
NewAttrVarId :: !Int -> Ident

52
53
beautifulizeAttributes :: !SymbolType !*AttrVarHeap -> (!SymbolType, !.AttrVarHeap)

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
54
55
56
57
58
59
60
61
62
63
64
65
66
67
::	AttrCoercion =
	{	ac_demanded	:: !Int
	,	ac_offered	:: !Int
	}

::	TempSymbolType =
	{	tst_args		:: ![AType]
	,	tst_arity		:: !Int
	,	tst_lifted		:: !Int
	,	tst_result		:: !AType
	,	tst_context		:: ![TypeContext]
	,	tst_attr_env	:: ![AttrCoercion]
	}

Sjaak Smetsers's avatar
Sjaak Smetsers committed
68
69
70
71
::	FunctionType = CheckedType !SymbolType | SpecifiedType !SymbolType ![AType] !TempSymbolType
				 | UncheckedType !TempSymbolType | ExpandedType !SymbolType !TempSymbolType !TempSymbolType  | EmptyFunctionType


72
updateExpressionTypes :: !SymbolType !SymbolType ![ExprInfoPtr] !*TypeHeaps !*ExpressionHeap -> (!*TypeHeaps, !*ExpressionHeap)
73

74
class substitute a :: !a !*TypeHeaps -> (!a, !*TypeHeaps)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
75

76
77
instance substitute AType, Type, TypeContext, AttrInequality, CaseType, [a] | substitute a,
			(a,b) | substitute a & substitute b
78

79
substituteType :: !TypeAttribute !TypeAttribute ![ATypeVar] ![AType] !Type !*TypeHeaps -> (!Type, !*TypeHeaps)
80
81
82
83

bindTypeVarsAndAttributes :: !TypeAttribute !TypeAttribute ![ATypeVar] ![AType] !*TypeHeaps -> *TypeHeaps;
clearBindingsOfTypeVarsAndAttributes :: !TypeAttribute ![ATypeVar] !*TypeHeaps -> *TypeHeaps;

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
84
instance <<< TempSymbolType
85
86
87

removeInequality :: !Int !Int !*Coercions -> .Coercions
flattenCoercionTree :: !u:CoercionTree -> (![Int], !u:CoercionTree)
88
	// retrieve all numbers from a coercion tree
89
assignNumbersToAttrVars :: !SymbolType !*AttrVarHeap -> (!Int, ![AttributeVar], !.AttrVarHeap)
90
	// returns the number and a list of all attribute variables
91
getImplicitAttrInequalities :: !SymbolType -> [AttrInequality]
92
	// retrieve those inequalities that are implied by propagation
93
94
95
96
97
98
emptyCoercions :: !Int -> .Coercions
	// Int: nr of attribute variables
addAttrEnvInequalities :: ![AttrInequality] !*Coercions !u:AttrVarHeap
						-> (!.Coercions, !u:AttrVarHeap)
	// assertion: the attribute variables point to (AVI_Attr (TA_TempVar nr)) where
	// nr corresponds to the attribute variable
99
100
optBeautifulizeIdent :: !String -> Optional (!String, !LineNr)
	// convert something like "c;8;2" to Yes ("comprehension", 8)
101
removeUnusedAttrVars :: !{!CoercionTree} ![Int] -> Coercions
102
	
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
//accCoercionTree :: !.(u:CoercionTree -> (.a,u:CoercionTree)) !Int !*{!u:CoercionTree} -> (!.a,!{!u:CoercionTree})
accCoercionTree f i coercion_trees
	:== acc_coercion_tree i coercion_trees
  where
	acc_coercion_tree i coercion_trees
		# (coercion_tree, coercion_trees) = replace coercion_trees i CT_Empty
		  (x, coercion_tree) = f coercion_tree
		= (x, snd (replace coercion_trees i coercion_tree))
	
//accCoercionTree :: !.(u:CoercionTree -> u:CoercionTree) !Int !*{!u:CoercionTree} -> {!u:CoercionTree}
appCoercionTree f i coercion_trees
	:== acc_coercion_tree i coercion_trees
  where
	acc_coercion_tree i coercion_trees
		# (coercion_tree, coercion_trees) = replace coercion_trees i CT_Empty
		= snd (replace coercion_trees i (f coercion_tree))
	
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
class performOnTypeVars a :: !(TypeAttribute TypeVar .st -> .st) !a !.st -> .st
// run through a type and do something on each type variable

instance performOnTypeVars Type, AType, ConsVariable, [a] | performOnTypeVars a,
		(a, b) | performOnTypeVars a & performOnTypeVars b

getTypeVars :: !a !*TypeVarHeap -> (!.[TypeVar],!.TypeVarHeap) | performOnTypeVars a

class performOnAttrVars a :: !(AttributeVar .st -> .st) !a !.st -> .st
// run through a type and do something on each attribute variable

getAttrVars :: !a !*AttrVarHeap -> (!.[AttributeVar],!.AttrVarHeap) | performOnAttrVars a

instance performOnAttrVars Type, AType, [a] | performOnAttrVars a,
		(a, b) | performOnAttrVars a & performOnAttrVars b

initializeToTVI_Empty :: a !TypeVar !*TypeVarHeap -> .TypeVarHeap
initializeToAVI_Empty :: !AttributeVar !*AttrVarHeap -> .AttrVarHeap

appTypeVarHeap f type_heaps :== let th_vars = f type_heaps.th_vars in { type_heaps & th_vars = th_vars }
accTypeVarHeap f type_heaps :== let (r, th_vars) = f type_heaps.th_vars in (r, { type_heaps & th_vars = th_vars })
accAttrVarHeap f type_heaps :== let (r, th_attrs) = f type_heaps.th_attrs in (r, { type_heaps & th_attrs = th_attrs })
	
143
144
145
class removeAnnotations a :: !a  -> (!Bool, !a)

instance removeAnnotations Type, SymbolType
146
147
148
149
150
151
152

foldATypeSt on_atype on_type type st :== fold_atype_st type st
  where
	fold_type_st type=:(TA type_symb_ident args) st
		#! st
				= foldSt fold_atype_st args st
		= on_type type st
153
154
155
156
	fold_type_st type=:(TAS type_symb_ident args _) st
		#! st
				= foldSt fold_atype_st args st
		= on_type type st
157
158
159
160
	fold_type_st type=:(l --> r) st
		#! st
				= fold_atype_st r (fold_atype_st l st)
		= on_type type st
161
162
163
164
165
//AA..
	fold_type_st type=:(TArrow1 t) st
		#! st = fold_atype_st t st
		= on_type type st	
//..AA
166
167
168
169
	fold_type_st type=:(_ :@: args) st
		#! st
				= foldSt fold_atype_st args st
		= on_type type st
170
	fold_type_st type st
171
		= on_type type st
172
	
173
174
175
176
177
	fold_atype_st atype=:{at_type} st
		#! st
				= fold_type_st at_type st
		= on_atype atype st