add typecheck rules (wip)

tomooda · Feb 4, 2024 · bba58d7 · bba58d7
1 parent 1f9ed13
commit bba58d7
Show file tree

Hide file tree

Showing 6 changed files with 176 additions and 0 deletions.
diff --git a/repository/ViennaTalk-Parser-AST/ViennaMapDomainRestrictedByNode.class.st b/repository/ViennaTalk-Parser-AST/ViennaMapDomainRestrictedByNode.class.st
@@ -46,3 +46,18 @@ ViennaMapDomainRestrictedByNode >> paramType2 [
 
 	^ ViennaType any mapTo: ViennaType any
 ]
+
+{ #category : #accessing }
+ViennaMapDomainRestrictedByNode >> returnTypeFor: aViennaType1 and: aViennaType2 [
+
+	| setbasetype domainbasetype rangebasetype |
+	setbasetype := aViennaType1 basetype.
+	domainbasetype := aViennaType2 keytype.
+	rangebasetype := aViennaType2 valuetype.
+	(setbasetype isCompatibleWith: domainbasetype) ifFalse: [
+		^ ViennaTypeError
+			  on: self
+			  signal: 'Tye mismatch: ' , setbasetype printString , ' and '
+				  , domainbasetype printString ].
+	^ aViennaType2
+]
diff --git a/repository/ViennaTalk-Parser-AST/ViennaMapDomainRestrictedToNode.class.st b/repository/ViennaTalk-Parser-AST/ViennaMapDomainRestrictedToNode.class.st
@@ -34,3 +34,30 @@ ViennaMapDomainRestrictedToNode >> operatorPrecedence [
 
 	^ 34
 ]
+
+{ #category : #accessing }
+ViennaMapDomainRestrictedToNode >> paramType1 [
+
+	^ ViennaType any set
+]
+
+{ #category : #accessing }
+ViennaMapDomainRestrictedToNode >> paramType2 [
+
+	^ ViennaType any mapTo: ViennaType any
+]
+
+{ #category : #accessing }
+ViennaMapDomainRestrictedToNode >> returnTypeFor: aViennaType1 and: aViennaType2 [
+
+	| setbasetype domainbasetype rangebasetype |
+	setbasetype := aViennaType1 basetype.
+	domainbasetype := aViennaType2 keytype.
+	rangebasetype := aViennaType2 valuetype.
+	(setbasetype isCompatibleWith: domainbasetype) ifFalse: [
+		^ ViennaTypeError
+			  on: self
+			  signal: 'Tye mismatch: ' , setbasetype printString , ' and '
+				  , domainbasetype printString ].
+	^ aViennaType2
+]
diff --git a/repository/ViennaTalk-Parser-AST/ViennaMapMergeNode.class.st b/repository/ViennaTalk-Parser-AST/ViennaMapMergeNode.class.st
@@ -34,3 +34,38 @@ ViennaMapMergeNode >> operatorPrecedence [
 
 	^ 31
 ]
+
+{ #category : #accessing }
+ViennaMapMergeNode >> paramType1 [
+
+	^ ViennaType any mapTo: ViennaType any
+]
+
+{ #category : #accessing }
+ViennaMapMergeNode >> paramType2 [
+
+	^ ViennaType any mapTo: ViennaType any
+]
+
+{ #category : #accessing }
+ViennaMapMergeNode >> returnTypeFor: aViennaType1 and: aViennaType2 [
+
+	| domaintype1 domaintype2 domaintype rangetype1 rangetype2 rangetype |
+	domaintype1 := aViennaType1 keytype.
+	domaintype2 := aViennaType2 keytype.
+	domaintype := domaintype1 >= domaintype2
+		              ifTrue: [ domaintype1 ]
+		              ifFalse: [
+			              domaintype2 >= domaintype1
+				              ifTrue: [ domaintype2 ]
+				              ifFalse: [ domaintype1 | domaintype2 ] ].
+	rangetype1 := aViennaType1 valuetype.
+	rangetype2 := aViennaType2 valuetype.
+	rangetype := rangetype1 >= rangetype2
+		             ifTrue: [ rangetype1 ]
+		             ifFalse: [
+			             rangetype2 >= rangetype1
+				             ifTrue: [ rangetype2 ]
+				             ifFalse: [ rangetype1 | rangetype2 ] ].
+	^ domaintype mapTo: rangetype
+]
diff --git a/repository/ViennaTalk-Parser-Tests/ViennaMapDomainRestrictedByNodeTest.class.st b/repository/ViennaTalk-Parser-Tests/ViennaMapDomainRestrictedByNodeTest.class.st
@@ -0,0 +1,32 @@
+"
+A ViennaMapDomainRestrictedByNodeTest is a test class for testing the behavior of ViennaMapDomainRestrictedByNode
+"
+Class {
+	#name : #ViennaMapDomainRestrictedByNodeTest,
+	#superclass : #TestCase,
+	#category : #'ViennaTalk-Parser-Tests'
+}
+
+{ #category : #tests }
+ViennaMapDomainRestrictedByNodeTest >> testTypecheck [
+
+	| expr |
+	expr := 's <-: m' asViennaExpressionAst.
+
+	expr expression1 maximalType: ViennaType nat set.
+	expr expression2 maximalType: (ViennaType nat mapTo: ViennaType char).
+	self
+		assert: (expr typecheck: (ViennaType nat mapTo: ViennaType char))
+		equals: (ViennaType nat mapTo: ViennaType char).
+	expr expression1 maximalType: ViennaType nat optional set.
+	expr expression2 maximalType:
+		(ViennaType real mapTo: ViennaType char).
+	self
+		assert: (expr typecheck: (ViennaType real mapTo: ViennaType char))
+		equals: (ViennaType real mapTo: ViennaType char).
+	expr expression1 maximalType: ViennaType char set.
+	expr expression2 maximalType: (ViennaType nat mapTo: ViennaType char).
+	self
+		should: [ expr typecheck: (ViennaType real mapTo: ViennaType char) ]
+		raise: ViennaTypeError
+]
diff --git a/repository/ViennaTalk-Parser-Tests/ViennaMapDomainRestrictedToNodeTest.class.st b/repository/ViennaTalk-Parser-Tests/ViennaMapDomainRestrictedToNodeTest.class.st
@@ -0,0 +1,29 @@
+Class {
+	#name : #ViennaMapDomainRestrictedToNodeTest,
+	#superclass : #TestCase,
+	#category : #'ViennaTalk-Parser-Tests'
+}
+
+{ #category : #tests }
+ViennaMapDomainRestrictedToNodeTest >> testTypecheck [
+
+	| expr |
+	expr := 's <: m' asViennaExpressionAst.
+
+	expr expression1 maximalType: ViennaType nat set.
+	expr expression2 maximalType: (ViennaType nat mapTo: ViennaType char).
+	self
+		assert: (expr typecheck: (ViennaType nat mapTo: ViennaType char))
+		equals: (ViennaType nat mapTo: ViennaType char).
+	expr expression1 maximalType: ViennaType nat optional set.
+	expr expression2 maximalType:
+		(ViennaType real mapTo: ViennaType char).
+	self
+		assert: (expr typecheck: (ViennaType real mapTo: ViennaType char))
+		equals: (ViennaType real mapTo: ViennaType char).
+	expr expression1 maximalType: ViennaType char set.
+	expr expression2 maximalType: (ViennaType nat mapTo: ViennaType char).
+	self
+		should: [ expr typecheck: (ViennaType real mapTo: ViennaType char) ]
+		raise: ViennaTypeError
+]
diff --git a/repository/ViennaTalk-Parser-Tests/ViennaMapMergeNodeTest.class.st b/repository/ViennaTalk-Parser-Tests/ViennaMapMergeNodeTest.class.st
@@ -0,0 +1,38 @@
+"
+A ViennaMapMergeNodeTest is a test class for testing the behavior of ViennaMapMergeNode
+"
+Class {
+	#name : #ViennaMapMergeNodeTest,
+	#superclass : #TestCase,
+	#category : #'ViennaTalk-Parser-Tests'
+}
+
+{ #category : #tests }
+ViennaMapMergeNodeTest >> testTypecheck [
+
+	| expr |
+	expr := 'm1 munion m2' asViennaExpressionAst.
+
+	expr expression1 maximalType: (ViennaType nat mapTo: ViennaType char).
+	expr expression2 maximalType: (ViennaType nat mapTo: ViennaType char).
+	self
+		assert: (expr typecheck: (ViennaType nat mapTo: ViennaType char))
+		equals: (ViennaType nat mapTo: ViennaType char).
+
+	expr expression1 maximalType:
+		(ViennaType nat optional mapTo: ViennaType char).
+	expr expression2 maximalType:
+		(ViennaType nat mapTo: ViennaType char optional).
+	self
+		assert: (expr typecheck:
+				 (ViennaType nat optional mapTo: ViennaType char optional))
+		equals: (ViennaType nat optional mapTo: ViennaType char optional).
+
+	expr expression1 maximalType: (ViennaType nat mapTo: ViennaType char).
+	expr expression2 maximalType: (ViennaType char mapTo: ViennaType nat).
+	self
+		assert: (expr typecheck: (ViennaType nat | ViennaType char mapTo:
+					  ViennaType nat | ViennaType char))
+		equals: (ViennaType nat | ViennaType char mapTo:
+				 ViennaType char | ViennaType nat)
+]