Create Z3Datatypes from SpriteLang Data

src/Refinements/Z3BoolSort.extension.st

@@ -5,11 +5,6 @@ Z3BoolSort >> containsFVar [
 	^false
 ]
 
-{ #category : #'*Refinements' }
-Z3BoolSort >> functionSort [
-	^nil
-]
-
 { #category : #'*Refinements' }
 Z3BoolSort >> isMono [
 	^true

src/Refinements/Z3DatatypeSort.extension.st

@@ -0,0 +1,6 @@
+Extension { #name : #Z3DatatypeSort }
+
+{ #category : #'*Refinements' }
+Z3DatatypeSort >> containsFVar [
+	^false
+]

src/Refinements/Z3IntSort.extension.st

@@ -10,11 +10,6 @@ Z3IntSort >> containsFVar [
 	^false
 ]
 
-{ #category : #'*Refinements' }
-Z3IntSort >> functionSort [
-	^nil
-]
-
 { #category : #'*Refinements' }
 Z3IntSort >> isMono [
 	^true

src/Refinements/Z3Sort.extension.st

@@ -32,6 +32,11 @@ Z3Sort >> falseRefinement [
 	^self | [ :x | Bool false ]
 ]
 
+{ #category : #'*Refinements' }
+Z3Sort >> functionSort [
+	^nil
+]
+
 { #category : #'*Refinements' }
 Z3Sort >> goFunctionSort: vs _: ss [ 
 	^{ vs reversed . ss reversed . self }

src/Refinements/Z3UninterpretedSort.extension.st

@@ -20,11 +20,6 @@ Z3UninterpretedSort >> containsFVar [
 	^true
 ]
 
-{ #category : #'*Refinements' }
-Z3UninterpretedSort >> functionSort [
-	^nil "functionSort $ FObj (symbol 'a') >> Nothing"
-]
-
 { #category : #'*Refinements' }
 Z3UninterpretedSort >> guest [
 	^PreSort hotel at: self unsafeName

src/SpriteLang/Data.class.st

@@ -32,6 +32,15 @@ Data class >> name: ident vars: idents rvars: rvars ctors: bindToRType_Assocs in
 		yourself
 ]
 
+{ #category : #checking }
+Data >> checkData: aΓContext [
+"
+checkData :: Env -> SrcData -> CG SrcCstr
+"
+	"BOGUS"
+	^CstrAnd of: #()
+]
+
 { #category : #accessing }
 Data >> ctors [
 	^ ctors
@@ -109,6 +118,22 @@ Data >> printOn: aStream [
 
 ]
 
+{ #category : #reflect }
+Data >> reflectData [
+"
+---------------------------------------------------------------------------------
+reflectData :: SrcData -> F.DataDecl
+---------------------------------------------------------------------------------
+"
+	| tvM fCtors |
+	tvM := vars zip: (0 to: vars size - 1) with: [ :a :i | a -> (FVar new: i) ].
+	fCtors := ctors collectAssociations: [ :bind :s | s reflectCtor: bind tvSub: tvM ].
+	^DataDecl
+		ddTyCon: name symbolFTycon
+		ddVars: vars size
+		ddCtors: fCtors
+]
+
 { #category : #accessing }
 Data >> rvars [
 	^ rvars

src/SpriteLang/FunSig.class.st

@@ -0,0 +1,61 @@
+Class {
+	#name : #FunSig,
+	#superclass : #Object,
+	#instVars : [
+		'fsTVars',
+		'fsRVars',
+		'fsParams',
+		'fsOut'
+	],
+	#category : #SpriteLang
+}
+
+{ #category : #'instance creation' }
+FunSig class >> tVars: tVars rVars: rVars params: params out: out [
+	^self basicNew
+		fsTVars: tVars;
+		fsRVars: rVars;
+		fsParams: params;
+		fsOut: out;
+		yourself
+]
+
+{ #category : #accessing }
+FunSig >> fsOut [
+	^ fsOut
+]
+
+{ #category : #accessing }
+FunSig >> fsOut: anObject [
+	fsOut := anObject
+]
+
+{ #category : #accessing }
+FunSig >> fsParams [
+	^ fsParams
+]
+
+{ #category : #accessing }
+FunSig >> fsParams: anObject [
+	fsParams := anObject
+]
+
+{ #category : #accessing }
+FunSig >> fsRVars [
+	^ fsRVars
+]
+
+{ #category : #accessing }
+FunSig >> fsRVars: anObject [
+	fsRVars := anObject
+]
+
+{ #category : #accessing }
+FunSig >> fsTVars [
+	^ fsTVars
+]
+
+{ #category : #accessing }
+FunSig >> fsTVars: anObject [
+	fsTVars := anObject
+]

src/SpriteLang/Prog.class.st

@@ -93,7 +93,7 @@ Prog >> solve [
 
 { #category : #verification }
 Prog >> vcgen [
-	| expr′ env eL ps pqs c_cgi c cgi rfls syms c′ query |
+	| expr′ env eL ps pqs cI c_cgi c cgi rfls syms c′ decs |
 	expr′ := expr uniq2.
 	env := ΓContext empEnv: meas typs: data.
 	eL := expr′ elaborate: env.
@@ -103,16 +103,18 @@ Prog >> vcgen [
 		hcon symbol -> hcon sort
 	].
 	pqs := #(1 2 3) collect: [ :j | Qualifier pappQual: j ].
+	cI := [ CstrAnd of: (data collect: [ :t | t checkData: env ]) ] runCG key.
 	c_cgi := [ eL check: env rtype: TInt instance bTrue ] runCG.
 	c := c_cgi key. cgi := c_cgi value.
 	rfls := cgi cgiConsts.
 	syms := Dictionary newFromAssociations: ps, meas, rfls.
 	c′ := c strengthenInv: env.
+	decs := data collect: #reflectData.
 	^HornQuery
 		mkQuery_qs: quals, pqs
 		ks: cgi cgiKVars
-		cstr: "cI &" c′
+		cstr: cI & c′
 		syms: syms
 		defs: cgi cgiDefs
-		ddecls: #()
+		ddecls: decs
 ]

src/SpriteLang/RType.class.st

@@ -168,6 +168,20 @@ fresh :: F.SrcSpan -> Env -> RType -> CG RType
 	self subclassResponsibility
 ]
 
+{ #category : #reflect }
+RType >> funSig [
+"
+funSig :: RType -> FunSig
+"
+	| as_rs_t′ as rs t′ xts_ot xts ot |
+	as_rs_t′ := self bkAlls.
+	as := as_rs_t′ first. rs := as_rs_t′ second. t′ := as_rs_t′ third.
+	xts_ot := t′ bkFun.
+	xts := xts_ot key.
+	ot := xts_ot value.
+	^FunSig tVars: as rVars: rs params: xts out: ot
+]
+
 { #category : #'as yet unclassified' }
 RType >> generalize [
 	"Normalize types by generalizing tyvars, refactoring ref-var applications."
@@ -409,6 +423,25 @@ reflect :: Ident -> SrcExpr -> RType -> CG RType
 	^self reflectTy: f v: v expr: e
 ]
 
+{ #category : #reflect }
+RType >> reflectCtor: bind tvSub: tvSub [
+"
+reflectCtor :: TvSub -> (SrcBind, RType) -> F.DataCtor
+Cf. Reflect.hs
+NB: Here TvSub is 'type TvSub = [(Ident, F.Sort)]', not the other one!
+"
+	| fldTs fFields |
+	fldTs := self funSig fsParams collect: #value.
+	fFields := fldTs zip: (0 to: fldTs size - 1) with: [ :t :i |
+		| fldName fldSort |
+		fldName := bind id selDataCon: i.
+		fldSort := t rtypeSort sortSubst: (Dictionary newFromAssociations: tvSub).
+		DataField dfName: fldName dfSort: fldSort ].
+	^DataCtor
+		dcName: bind id
+		dcFields: fFields
+]
+
 { #category : #reflect }
 RType >> reflectTy: f v: v expr: e [
 "

src/SpriteLang/String.extension.st

@@ -39,6 +39,14 @@ rVar :: F.Symbol -> RType
 	^(TVar symbol: self) bTrue
 ]
 
+{ #category : #'*SpriteLang' }
+String >> selDataCon: i [
+"
+selDataCon :: DaCon -> Int -> F.Symbol
+"
+	^self intSymbol: i
+]
+
 { #category : #'*SpriteLang' }
 String >> unifyX: anotherString [ 
 	^self

src/SpriteLang/TCon.class.st

@@ -132,6 +132,11 @@ TCon >> reft [
 	^r
 ]
 
+{ #category : #'as yet unclassified' }
+TCon >> rtypeSort [
+	^c symbolFTycon fAppTC: (ts collect: #rtypeSort)
+]
+
 { #category : #'synthesis constraints' }
 TCon >> singleton: x [
 	^TCon