module org/webdsl/dsl/languages/data-model/constraints

imports
libstrategolib

imports
libwebdsl-front

signature constructors

EntityOfProperty : Term -> Term

rules

constraint-error-global =
all-keys-EntDecl
; map(bagof-EntDecl)
; concat
; try(constraint-double-decls(
get-entity-def; Fst; lower-case
, {
Snd; get-entity-def
; Fst => name
; rules(EntityDeclaredTwice :+ name -> name)
; !["Entity '", name, "' is defined multiple times."]
}
))
// only check properties for entities which are not defined multiple times
; all-keys-EntDecl; remove-all(EntityDeclaredTwice)
; filter(constraint-error-global-nondouble-entities; fatal-err(|"INTERNAL ERROR: Rule should fail"))
; fail

constraint-error-data :
Entity(x_class, s, _) -> <add-error(|["Super entity ", <pp-webdsl> s, " for ", x_class, " does not exist."])>
where not(<typecheck-supertype> s)

typecheck-supertype: x_class -> x_class
where IsEntity <+ ?"Object"

constraint-error-data =
?DerivedProperty(x, _, t, _, e)
; where( te := <type-of> e )
; not(<type-compatible> (te, t))
; add-error(|["The expression of the derived property ", x, " should have type ", <pp-type> t, " but has type ", <pp-type> te])

constraint-error-data =
?ent@Entity(x_id, x_super, _)
; where(<IsCachedEntity> x_id)
; where(<not(check-is-cached-entity(|[]))> x_super)
; <add-error(|["A sub-entity is only cached if it inherits from a cached entity."])> x_id

constraint-error-data =
?Property(name, k, srt, annos)
; where(
<fetch(?SimpleAnno("cache"))> annos
; <not(?GenericSort(_, [SimpleSort(<check-is-cached-entity(|[])>)]))> srt
)
; add-error(|["The cache annotation is only allowed on collection properties with elements of a cached entity."])

check-is-cached-entity(|alreadychecked) = // Same as is-cached-entity, but can also be used on an entity that subclasses itselft
?x_class
; where(not(<fetch(?x_class)> alreadychecked))
; (IsCachedEntity <+ <Extends; check-is-cached-entity(|[x_class|alreadychecked])> x_class)

// checks on types only for persisted property
constraint-error-data =
?Property(x, propkind, srt, annos)
; where(not(<fetch(?SimpleAnno("transient"))> annos))
; where(
check-disallowed-simplesort(|x, srt)
<+ check-no-ref-type(|x, srt)
<+ check-simple-propkind(|propkind, srt) // check for incompatible propkinds, such as :: Set<User> (which should be -> Set<User>)
<+ check-complex-propkind(|propkind, srt)
)
; fail

// checks on names also for derivedproperty
constraint-error-data =
( ?Property(x, propkind, srt, _)
<+ ?DerivedProperty(x, propkind, srt, _, _) )
; where(
check-builtin-property(|x)
<+ check-forbidden-property(|x)
<+ check-entity-name-overlap(|x)
)
; fail

check-disallowed-simplesort(|x, srt) :
_ -> <map(try(check-disallowed-simplesort-helper(|x, srt))); fail> ["Null", "Void", "Entity"]

check-disallowed-simplesort-helper(|x, srt) :
name -> <add-error(|["Type '", name, "' is not allowed in property '", x, "'"])> srt
where srt := SimpleSort(name)

// warning for now, because in some cases it works and it is used in one of the deployed applications
check-entity-name-overlap(| x ):
prop -> <add-warning(| ["Property name is not allowed to overlap with entity name '", x, "'"] )>
where <IsEntity> x

check-builtin-property(|x): prop -> <add-error(|["Cannot override the builtin property '",x,"'"])>
where <?"id" <+ ?"version" <+ ?"created" <+ ?"modified"> x

check-forbidden-property(|x): prop -> <add-error(|["Cannot use the reserved property name '",x,"'"])>
where <?"class"> x

check-no-ref-type(|x, srt) :
_ -> <add-error(|["Reference type is not allowed in property '", x, "'"])> srt
where <?RefSort(_)>srt

// this rule will never trigger when using ':', because it has is-simple-sort as condition to rewrite to Simple() propkind
check-simple-propkind(|propkind, srt) :
_ -> <add-error(|["Expected: primitive type. Encountered: ", <pp-type> srt])> srt
where <is-webdsl-type> srt
where not(<is-simple-sort> srt)
; Simple() := propkind

// has a general error message for ':', not just '->' and '<>'
check-complex-propkind(|propkind, srt) :
term -> <add-error(|["Expected: primitive or Entity type. Encountered: ", <pp-type> srt])> srt
where <is-webdsl-type> srt
where <?Ref() <+ ?Comp()> propkind
; <is-simple-sort <+ is-native-class-sort> srt

check-complex-propkind(|propkind, srt) :
_ -> <add-error(|["Expected: collection of Entity type. Encountered: ", <pp-type> srt])> srt
where <is-webdsl-type> srt
where <?GenericSort(_, [x])> srt
; <not(is-defined-entity-type)> x

rules //check for illegal entity names; built-ins are reserved

constraint-error-data =
( ?Entity(x, _, _)
<+ ?EntityNoSuper(x, _)
<+ ?SessionEntity(<capitalize-string;?x>, _)
)
; where (reserved-type-constraint-error(|x))

reserved-type-constraint-error(|entname) :
x -> <add-error(|["Entity name: \"",entname,"\" is not allowed"])>
where <is-simple-sort> SimpleSort(entname)
<+ <reserved-entity-name> entname

rules // check if entityname starts with a capital

constraint-error-data =
( ?Entity(x, _, _)
<+ ?EntityNoSuper(x, _)
)
; where (entity-start-with-lowercase-error(|x))

entity-start-with-lowercase-error(|entname) :
x -> <add-error(|["Entity name: \"",entname,"\" should start with a Capital"])>
where <explode-string; Hd; is-lower> entname

rules //assignment to derived property is not allowed

constraint-error:
Assignment(FieldAccess(e1,prop),e2) -> <add-error(|["Assignment to derived property is not allowed."])>
where SimpleSort(x) := <type-of> e1
; <is-derived-property> (x,<strip-annos> prop)

constraint-error:
Assignment(Var(prop), e2) -> <add-error(|["Assignment to derived property is not allowed."])>
where x := <IsEntPropGetEntName> prop
; <is-derived-property> (x,<strip-annos> prop)

constraint-error-templatecall(|p,arg*) :
_ -> <add-error(|["Derived property is not allowed in 'input'."])>
where "input" := p
; FieldAccess(e1,prop) := <Hd> arg*
; SimpleSort(x) := <type-of> e1
; <is-derived-property> (x,<strip-annos> prop)

constraint-error:
ObjectCreation(SimpleSort(x_class), objectpropassign*) -> <fail>
where <map(try(constraint-error-object-prop-derived(|x_class)))> objectpropassign*

constraint-error-object-prop-derived(|x_class):
ObjectPropertyAssignment(prop,_) -> <add-error(|["Assignment to derived property is not allowed."])>
where <is-derived-property> (x_class,<strip-annos> prop)

rules //subclassing the entity itself

constraint-error =
get-entity-class-name
; ?x_class
; <check-entity-extends-itself(|[])> x_class

check-entity-extends-itself(|subtypes):
x -> <add-error(|["Entity may not inherit from itself."])> x
where <fetch(?x)> subtypes

check-entity-extends-itself(|subtypes):
x -> <check-entity-extends-itself(|[x|subtypes])> <Extends> x
where not(<fetch(?x)> subtypes)
where not(<?x> "Entity") // in case the application contains an incorrect 'entity Entity' (catched by another check, but shouldn't cause this to loop)