Merge pull request #1392 from AmpersandTarski/feature/typecheck-ENFORCE

Feature/typecheck enforce

.ampersand

@@ -1,2 +1,2 @@
 AmpersandData/FormalAmpersand/FormalAmpersand.adl
-AmpersandData/PrototypeContext/PrototypeContext.adl
+AmpersandData/PrototypeContext/PrototypeContext.adl

ampersand.cabal

@@ -5,7 +5,7 @@ cabal-version: 2.0
 -- see: https://github.com/sol/hpack
 
 name:           ampersand
-version:        4.7.3
+version:        4.7.4
 synopsis:       Toolsuite for automated design of enterprise information systems.
 description:    You can define your business processes by means of rules, written in Relation Algebra.
 category:       Database Design
@@ -290,6 +290,7 @@ extra-source-files:
     testing/Travis/testcases/prototype/shouldSucceed/Issue1018.adl
     testing/Travis/testcases/prototype/shouldSucceed/Issue1026.adl
     testing/Travis/testcases/prototype/shouldSucceed/Issue1261.adl
+    testing/Travis/testcases/prototype/shouldSucceed/Issue1281.adl
     testing/Travis/testcases/prototype/shouldSucceed/Issue142.adl
     testing/Travis/testcases/prototype/shouldSucceed/Issue142.xlsx
     testing/Travis/testcases/prototype/shouldSucceed/Issue142TooGeneric.adl

package.yaml

@@ -1,5 +1,5 @@
 name: ampersand
-version: 4.7.3
+version: 4.7.4
 author: Stef Joosten
 maintainer: [email protected]
 synopsis: Toolsuite for automated design of enterprise information systems.

src/Ampersand/ADL1/P2A_Converters.hs

@@ -1012,16 +1012,47 @@ pCtx2aCtx
                 unless srcOk $ mustBeOrdered pos' (Src, expr) (Src, rel)
                 let tgtOk = target expr `isaC` target rel
                 unless tgtOk $ mustBeOrdered pos' (Tgt, expr) (Tgt, rel)
+                let expr' =
+                      addEpsilonLeft genLattice (source rel) $
+                        addEpsilonRight genLattice (target rel) expr
                 return
                   AEnforce
                     { pos = pos',
                       enfRel = rel,
                       enfOp = oper,
-                      enfExpr = expr,
-                      enfPatName = mPat
+                      enfExpr = expr',
+                      enfPatName = mPat,
+                      enfRules = enforce2Rules rel expr'
                     }
             (o, dx) -> cannotDisambiguate o dx
-
+          where
+            enforce2Rules :: Relation -> Expression -> [Rule]
+            enforce2Rules rel expr =
+              case oper of
+                IsSuperSet {} -> [insPair]
+                IsSubSet {} -> [delPair]
+                IsSameSet {} -> [insPair, delPair]
+              where
+                insPair = mkRule "InsPair" (EInc (expr, bindedRel))
+                delPair = mkRule "DelPair" (EInc (bindedRel, expr))
+                bindedRel = EDcD rel
+                mkRule command fExpr =
+                  Ru
+                    { rrnm = "Compute " <> showRel rel <> " using " <> command,
+                      formalExpression = fExpr,
+                      rrfps = pos',
+                      rrmean = [],
+                      rrmsg = [],
+                      rrviol =
+                        Just . PairView $
+                          PairViewText pos' ("{EX} " <> command <> ";" <> name rel <> ";" <> name (source rel) <> ";")
+                            NE.:| [ PairViewExp pos' Src (EDcI (source rel)),
+                                    PairViewText pos' $ ";" <> name (target rel) <> ";",
+                                    PairViewExp pos' Tgt (EDcI (target rel))
+                                  ],
+                      rrpat = mPat,
+                      rrkind = Enforce
+                    }
       pIdentity2aIdentity ::
         ContextInfo ->
         Maybe Text -> -- name of pattern the rule is defined in (if any)

src/Ampersand/Classes.hs

@@ -7,4 +7,4 @@ where
 
 import Ampersand.Classes.ConceptStructure (ConceptStructure (..))
 import Ampersand.Classes.Relational (HasProps (..), Relational (..), isONE, isSESSION)
-import Ampersand.Classes.ViewPoint (Language (..), enforce2Rules, ruleFromIdentity)
+import Ampersand.Classes.ViewPoint (Language (..), ruleFromIdentity)

src/Ampersand/Classes/ViewPoint.hs

@@ -1,4 +1,4 @@
-module Ampersand.Classes.ViewPoint (Language (..), enforce2Rules, ruleFromIdentity) where
+module Ampersand.Classes.ViewPoint (Language (..), ruleFromIdentity) where
 
 import Ampersand.ADL1
 import Ampersand.Basics hiding (Identity, Ord (..))
@@ -34,7 +34,7 @@ class Language a where
   identityRules :: a -> Rules -- all identity rules that are maintained within this viewpoint.
   identityRules x = Set.fromList . map ruleFromIdentity $ identities x
   enforceRules :: a -> Rules -- all enforce rules that are maintained within this viewpoint.
-  enforceRules x = Set.fromList . concatMap enforce2Rules . enforces $ x
+  enforceRules x = Set.fromList . concatMap enfRules . enforces $ x
   allRules :: a -> Rules
   allRules x = udefrules x `Set.union` proprules x `Set.union` identityRules x `Set.union` enforceRules x
   identities ::
@@ -150,40 +150,11 @@ instance Language Pattern where
   udefRoleRules = ptrrs
 
 roleRuleFromEnforceRule :: AEnforce -> [A_RoleRule]
-roleRuleFromEnforceRule = map mkRoleRule . enforce2Rules
+roleRuleFromEnforceRule = map mkRoleRule . enfRules
   where
     mkRoleRule rul =
       A_RoleRule
         { arPos = origin rul,
           arRoles = Role "ExecEngine" NE.:| [],
           arRules = name rul NE.:| []
         }
-
-enforce2Rules :: AEnforce -> [Rule]
-enforce2Rules (AEnforce orig rel op expr mPat) =
-  case op of
-    IsSuperSet {} -> [insPair]
-    IsSubSet {} -> [delPair]
-    IsSameSet {} -> [insPair, delPair]
-  where
-    insPair = mkRule "InsPair" (EInc (expr, bindedRel))
-    delPair = mkRule "DelPair" (EInc (bindedRel, expr))
-    bindedRel = EDcD rel
-    mkRule command fExpr =
-      Ru
-        { rrnm = "Compute " <> showRel rel <> " using " <> command,
-          formalExpression = fExpr,
-          rrfps = orig,
-          rrmean = [],
-          rrmsg = [],
-          rrviol =
-            Just . PairView $
-              PairViewText orig ("{EX} " <> command <> ";")
-                NE.:| [ PairViewText orig $ name rel <> ";" <> name (source rel) <> ";",
-                        PairViewExp orig Src (EDcI (source rel)),
-                        PairViewText orig $ ";" <> name (target rel) <> ";",
-                        PairViewExp orig Tgt (EDcI (target rel))
-                      ],
-          rrpat = mPat,
-          rrkind = Enforce
-        }

src/Ampersand/Core/A2P_Converters.hs

@@ -54,7 +54,7 @@ aCtx2pCtx ctx =
     }
 
 aEnforce2pEnforce :: AEnforce -> P_Enforce TermPrim
-aEnforce2pEnforce (AEnforce orig rel op expr _) =
+aEnforce2pEnforce (AEnforce orig rel op expr _ _) =
   P_Enforce
     { pos = orig,
       penfRel = PNamedR . aRelation2pNamedRel $ rel,

src/Ampersand/Core/AbstractSyntaxTree.hs

@@ -165,9 +165,6 @@ data A_Context = ACtx
   }
   deriving (Typeable)
 
-instance Show A_Context where
-  show = T.unpack . name
-
 instance Eq A_Context where
   c1 == c2 = name c1 == name c2
 
@@ -229,7 +226,8 @@ data AEnforce = AEnforce
     enfOp :: !EnforceOperator,
     enfExpr :: !Expression,
     -- | If the Enforce is defined in the context of a pattern, the name of that pattern.
-    enfPatName :: !(Maybe Text)
+    enfPatName :: !(Maybe Text),
+    enfRules :: ![Rule]
   }
   deriving (Eq)
 

testing/Travis/testcases/prototype/shouldSucceed/Issue1281.adl

@@ -0,0 +1,10 @@
+CONTEXT Issue1281
+
+   CLASSIFY Vrijwilliger ISA Person
+
+   RELATION personalia[AanmeldingVrijwilliger*Vrijwilliger]
+   RELATION nationaliteit[Person*Tekst]
+   RELATION nationaliteit[AanmeldingVrijwilliger*Tekst]
+   ENFORCE nationaliteit[Person*Tekst] >: personalia~;nationaliteit
+
+ENDCONTEXT