Implement datatype-monomorphization plumbing

src/Refinements/FApp.class.st

@@ -72,6 +72,26 @@ FApp >> hash [
 	^s hash
 ]
 
+{ #category : #hotel }
+FApp >> monomorphicDeclIn: γ [
+	"Like fappSmtSort but don't go all the way to Z3.
+	 Do we want to keep this layer?"
+	(s isKindOf: FTC) ifFalse: [ self error ].
+	s isSetCon ifTrue: [ self error ].
+	s isMapCon ifTrue: [ self shouldBeImplemented ].
+	s isBitVec ifTrue: [ self shouldBeImplemented ].
+
+	^(s maybeDataIn: γ)
+		ifNil: [ self error]
+		ifNotNil: [ :d |
+			| instance ct_ts ct ts |
+			ct_ts := self unFApp.  ct := ct_ts first.  ts := ct_ts allButFirst.
+			instance := d apply: (ts collect: [ :each | each z3sort: γ ]).
+			instance monomorphicDeclIn: γ
+
+		]
+]
+
 { #category : #printing }
 FApp >> printOn: aStream [
 	aStream nextPutAll: '(FApp '.

src/Refinements/FTC.class.st

@@ -52,8 +52,10 @@ FTC >> fappSmtSort: ts originalFApp: anFApp in: γ [
 	^(self maybeDataIn: γ)
 		ifNil: [ (FObj symbol: typeConstructor symbol) fappSmtSort: ts originalFApp: anFApp in: γ ]
 		ifNotNil: [ :d |
+			| instance |
 			d ddVars = ts size ifFalse: [ self error ].
-			d instantiateZ3Sort: (ts collect: [ :t | t z3sort: γ ])
+			instance := d apply: (ts collect: [ :t | t z3sort: γ ]).
+			instance z3sort: γ
 		]
 ]
 

src/Refinements/TC.class.st

@@ -17,7 +17,19 @@ instance Eq FTycon where
 	^symbol = rhs symbol
 ]
 
-{ #category : #'as yet unclassified' }
+{ #category : #hotel }
+TC >> apply: ts [
+	| monoSymbol |
+	ts isEmpty ifTrue: [ ^self ].
+	monoSymbol :=
+		'(',
+		symbol,
+		(ts inject: '' into: [ :soFar :thisArgType | ' ', thisArgType printString ]),
+		')'.
+	^TC symbol: monoSymbol
+]
+
+{ #category : #hotel }
 TC >> fTyconSort [
 	^FTC new: self
 ]
@@ -27,7 +39,7 @@ TC >> hash [
 	^symbol hash
 ]
 
-{ #category : #'as yet unclassified' }
+{ #category : #hotel }
 TC >> isListTC [
 	^symbol isListConName
 ]

src/Refinements/Z3Sort.extension.st

@@ -94,6 +94,11 @@ Cf. Types/Sorts.hs
 
 ]
 
+{ #category : #'*Refinements' }
+Z3Sort >> monomorphicDeclIn: _ [ 
+	^self
+]
+
 { #category : #'*Refinements' }
 Z3Sort >> monomorphicSortName [
 	^self printString