diff --git a/.github/workflows/build-push-to-docker-hub.yml b/.github/workflows/build-push-to-docker-hub.yml index 496d2a76e7..0bcf6a5c0f 100644 --- a/.github/workflows/build-push-to-docker-hub.yml +++ b/.github/workflows/build-push-to-docker-hub.yml @@ -20,7 +20,7 @@ jobs: uses: actions/checkout@v2 - name: Build and push Docker images - uses: docker/build-push-action@v1 + uses: docker/build-push-action@v2 with: username: ${{ secrets.DOCKER_HUB_USERNAME }} password: ${{ secrets.DOCKER_HUB_PASSWORD }} diff --git a/AmpersandData/FormalAmpersand/AST.adl b/AmpersandData/FormalAmpersand/AST.adl deleted file mode 100644 index bda7257797..0000000000 --- a/AmpersandData/FormalAmpersand/AST.adl +++ /dev/null @@ -1,3 +0,0 @@ -CONTEXT Ampersand IN ENGLISH - - diff --git a/AmpersandData/FormalAmpersand/AST.docadl b/AmpersandData/FormalAmpersand/AST.docadl deleted file mode 100644 index 03e836c96a..0000000000 --- a/AmpersandData/FormalAmpersand/AST.docadl +++ /dev/null @@ -1,228 +0,0 @@ -CONTEXT RAP IN ENGLISH LATEX -{- This file contains the documentation of RAP in LaTeX format. - Each concept of the RAP metamodel has its own section, where sections are separated by comments -} -INCLUDE "FormalAmpersand.adl" -INCLUDE "Atoms.docadl" ---INCLUDE "Terms.docadl" -INCLUDE "Rules.docadl" - --- Context -PURPOSE PATTERN Context -{+The rules that govern contexts are brought together in one pattern, -in order to formalize contexts and determine their meaning. -+} -CONCEPT Context "A context is a set of statements in a formal language that are true within that context." -PURPOSE CONCEPT Context -{+ -Contexts exist in Ampersand for the purpose of dealing with truth. -Within one context there can be no contradictions. -Ampersand's way of dealing with a contradiction is either to resolve it or to separate them in different contexts. -\subsubsection*{Explanation} -The world is full of contradictions. Examples: -\begin{itemize} -\item Bob's personal income over March 2013 according to Bob's employer differs from Bob's personal income over March 2013 according to the National Tax Authority. -\item The police can be convinced that Peter X commited the crime, yet his attorney is convinced he is innocent. -\item One computer system can tell that the person with social security number 721-07-4426 was born on April 27th, 1943, while at the same time another computer system tells me this person was born on May 3rd, 1952. -\end{itemize} - -\begin{itemize} -In language philosopy, the idea of a context was invented to give truth a place. -\item In the context of the National Tax Authority, Bob's personal income over March 2013 can be computed to precisely one amount. In the context of his employment, Bob's personal income over March 2013 can be different, because that is another context. -\item The job of a court of law is to create a new truth, whose consequences (e.g. imprisonement) can be enforced by law. The court creates a new context, in which conflicts between the (different) truths of both parties are resolved by a decision of the court. -\item If two computers operate in the same context, yet disagree on matters of fact, we say there is an error. It is likely that in this example someone must step in to determine which date of birth is correct (if any). The error could be detected because we know (i.e. we have a rule that says) that a person must have a unique date of birth. -\end{itemize} - -Ampersand uses contexts to organize truth. -Within one context, there is a single truth and there are no contradictions. -For this reason, a context defines a language by means of concepts and relations, in which utterances can be made. -We say that these utterances {\emph make sense} in that context. -+} - -PURPOSE PATTERN Rules -{+The rules that govern rules are brought together in one pattern, -in order to formalize rules and determine their meaning. -+} -CONCEPT Rule "A rule is a statement that must be true in each context in which it is valid." -PURPOSE CONCEPT Rule -{+ -Rules are used as a concrete reason for people to act, feel or believe. -In philosophy, this is called a 'norm'. -\subsubsection*{Explanation} -A rule differs from a statement in that it must always be true. -Example: -\begin{itemize} -\item The statement "St. Paul street is a one way street." might be either true or false. - We just have to check the road signs on St. Paul street to know. - If, however, the city council decides that St. Paul street is a one way street, we have a rule. - It is a rule because St. Paul street must be a one way street. - As long as the appropriate road signs are absent, the situation on the street contradicts the decision of the city council. -\end{itemize} -The word 'must' implies that there is someone who says so. -In this example, the city council, by the authority invested upon it by the law, says that St. Paul street must be a one way street. -The people who are affected by this are called stakeholders. -All contexts in which this rule is valid are called the scope of this rule. -Outside its scope, a rule has no meaning. -For example a rule may be valid in downtown St. Catharines, Ontario, but totally meaningless in Smalltown, NY that does not even have a St. Paul street. -+} - -PURPOSE PATTERN Patterns -{+The rules that govern patterns are brought together in one pattern, -in order to formalize patterns and determine their meaning. -+} -CONCEPT Pattern "A pattern is a set of rules that describes a theme or a general reusable solution to a commonly occurring problem." -PURPOSE CONCEPT Pattern -{+ -Patterns are used to isolate discussions about a specific theme to a particular group of stakeholders, -who are competent to identify (define, select, invent, etc.) rules that define the theme. - -\subsubsection*{Explanation} -A pattern formalizes the agreement among stakeholders on this particular theme. -Design patterns are meant to make solutions reusable. -On top of that, Ampersand advocates "one theme in one pattern". -Stakeholders confine their discussion to one theme, and deliver the result in one pattern. -A pattern is created when a group of stakeholders is trying to agree on a solution for a particular problem. -The agreements they reach are written as rules, which are collected in a pattern. -Therefore, they are independent from a particular context. -\subsubsection*{Example} -The problem of identifying which persons have been using an information system can be solved by making rules -about log-in, users and sessions. -+} - --- Term -PATTERN Terms -PURPOSE PATTERN Terms -{+The rules that govern terms are brought together in one pattern, -in order to formalize terms and determine their meaning. -+} -CONCEPT Term "An term is a relation algebraic term, denoted in Ampersand syntax" -REPRESENT Term TYPE ALPHANUMERIC -PURPOSE CONCEPT Term -{+ -Ampersand uses relation algebra to formalize phrases. -The formalized phrases are called terms. -An Ampersand professional uses terms to calculate with language and to specify information systems and business processes. -\subsubsection*{Explanation} -An term combines relations with operators. -That results in new relations, the population of which can be calculated from the constituent parts. -This is similar to arithmetic, where for instance the result of term $(3+5)\times 2$ can be calculated from the constituent numbers. -In Ampersand, you calculate with relations rather than numbers. -\subsubsection*{Example} -The problem of identifying which persons have been using an information system can be solved by making rules -about log-in, users and sessions. -+} -ENDPATTERN - -PURPOSE PATTERN Specialization -{+Let us briefly recall, by example, what specialization is all about. -Citrus fruit comes in many colors: oranges are orange, lemons are yellow, limes are green, and grapefruits are red, yellow or a mixture of both. -Based on such an observation, we might have a concept $\id{Citrus}$, with a property $\id{color}$. -Since all limes are citrus fruits, we might have a concept $\id{Lime}$. -Every instance of $\id{Lime}$ is a small green and very sour fruit. It is not just a $\id{Lime}$, but it is a $\id{Citrus}$ as well. -This is called {\em specialization}. -The reason we call \id{Lime} a specialization of \id{Citrus} is that every lime (i.e.\ each instance of \id{Lime}) has all the properties of a citrus -and on top of that it has properties specific to limes. - -Specialization should be used on intrinsic properties only. -Ask yourself: once a lime, always a lime? If the answer is yes (which sounds right to me), you can use specialization. -Now ask yourself: once an employee, always an employee? The answer to this question is more likely to be no. -Therefore, don't use specialization to say that an employee is a person. -+} - --- Concept -PATTERN Concepts -PURPOSE PATTERN Concepts -{+The rules that govern concepts are brought together in one pattern, -in order to formalize concepts and determine their meaning. -+} ---HJO, 20150420: In het documentatie bestand moet je eigenlijk geen definities opnemen. Die moeten elders --CONCEPT A_Concept "A concept is a name for a category of similar objects." ---HJO, 20150420: In het documentatie bestand moet je eigenlijk geen definities opnemen. Die moeten elders ----CONCEPT ConceptOne "ConceptOne, also known as ONE, is a predefined concept that has the role of universal singleton" -PURPOSE CONCEPT Concept -{+ -In order to reason about meaning, -Ampersand has borrowed the idea of a "concept" from the field of semantics -(a part of the philosophy of language). -\subsubsection*{Example} -For example, the city of Amsterdam is an instance of the concept ``City''. -\subsubsection*{Explanation} -Concepts, such as City, Person, Document, Installment, and so on, -allow a designer to talk about things without having them. -We can discuss cities and persons that live in them -without referring to the actual instances of those concepts. -The distinction between an object (Amsterdam) and the corresponding concept (City) -has been studied for a long time [e.g.\ Frege, 1892] and is highly relevant for Ampersand. -+} -CONCEPT Concept "A set of things that we can talk about using the name of the concept." -ENDPATTERN - -PATTERN Populations -PURPOSE PATTERN Populations -{+The rules that govern atoms, pairs, and populations are brought together in one pattern, -in order to formalize them and determine their meaning. -+} - -CONCEPT Population "The contents of a Concept or Relation" -PURPOSE CONCEPT Population -{+ -Populations are a means to specify a number of true statements that are stored in a relation. -If an information system is generated, the population specified in an Ampersand script -is used as the initial data stored in the database. -This data can subsequently be changed by performing transactions on that database. -\subsubsection*{Example} -\begin{verbatim} - POPULATION address[Person,Address] CONTAINS - { ("Peter", "148 Browning Street") - ; ("Susan", "Dorpsstraat 78") - ; ("Bart", "2013 McGinnigall Drive") - } -\end{verbatim} -\subsubsection*{Explanation} -Populations provide the initial content of a database. - -The word {\emph population} is used sloppily for contexts as well. -It refers the the total of all populations in relations and concepts inside that context. -+} - -CONCEPT RelPopu "The content of a relation" -CONCEPT CptPopu "The content of a concept" -CONCEPT Pair "A pair is an identifier for a pair of atomic terms as an instance of an element with a sign e.g. the population of a relation or the violations of a rule" -CONCEPT Blob "A blob is a pString expected to need more than 256 characters of reserved space." -REPRESENT Blob TYPE BIGBINARY -CONCEPT String "A string is a pString expected to be less than 256 characters." ---HJO20150420: Uitgezet: CONCEPT Conid "A conid is an identifier starting with an uppercase" ---HJO20150420: Uitgezet: CONCEPT Varid "A varid is an identifier starting with a lowercase" ---HJO20150420: Uitgezet: CONCEPT ADLid "An ADLid is an identifier of type pVarid <|> pConid <|> pString" -CONCEPT Isa "An Isa, or generalization rule, represents an is-a-relation between two concepts, one of which we call specific and the other generic. It means that any atom of the specific concept is an atom of the generic concept as well." -CONCEPT IsE "An IsE, or generalization rule, is the is-relation between one concept, which is called specific, and other concepts which are called generic. It means that all atoms of the specific concepts are all atoms of the intersection set of the generic concepts. Note that if there is one generic concept, the IsE can be regarded as a synonym definition." -CONCEPT Signature "A signature is a pair of concepts, which are called source concept and target concept." -CONCEPT PropertyRule "A property rule is a rule, that is a property of a user-declared relation" -CONCEPT Property "UNI<|>TOT<|>INJ<|>SUR<|>RFX<|>IRF<|>SYM<|>ASY<|>TRN<|>PROP" -CONCEPT Relation "A relation is a set of pairs, that is characterized by a name, a source concept and a target concept." -CONCEPT Pair "A pair is an element of a relation, which has a left atom and a right atom." -ENDPATTERN - -PURPOSE PATTERN Plugs -{+Atoms are stored in pairs, pairs are stored in relations, relations are stored in plugs, and plugs are stored in databases. -To understand how (binary) relations are stored, -you may perceive a plug as a database table, in which a number of rules are being maintained. - -Plugs are defined merely for reasons of efficient storage. -Theoretically, each relation can be stored in a binary plug. -In that situation, the system will work. Such a system is likely to contain more joins to be executed, so a performance problem lures. -Ampersand tries to store multiple relations and concepts in one plug, in order to create tables with multiple columns, but with little data duplication. -The way it works is easily visualized by perceiving each plug as a single worksheet in a spreadsheet. -The first few colums are used as concept tables, in which concepts are stored that are related through generalization and specializations. -The other columns are used to store relations. -+} - -PURPOSE RULE "rule allocation" -{+In order to maintain a rule, a plug must have access to the data necessary for detecting violations. -Consequently, the information contents of a plug limits the number of rules it can maintain on its own. -+} - -PURPOSE RULE "All isas in one plug" -{+If every atom that is Lime is also Citrus, then creating a new limes must ensure that the newly made atom is a citrus too. -Similarly, deleting the lime must ensure that the atom does not remain existent as a citrus. -For this purpose, all concepts that are related through specialization or generalization are stored in the same plug. -+} - -ENDCONTEXT \ No newline at end of file diff --git a/AmpersandData/FormalAmpersand/Contexts.adl b/AmpersandData/FormalAmpersand/Contexts.adl index df5dbd638f..ec14689415 100644 --- a/AmpersandData/FormalAmpersand/Contexts.adl +++ b/AmpersandData/FormalAmpersand/Contexts.adl @@ -1,6 +1,7 @@ CONTEXT RAP IN ENGLISH INCLUDE "Rules.adl" INCLUDE "Relations.adl" +INCLUDE "Patterns.adl" VIEW Signature: Signature( TXT "[" , src;name[Concept*ConceptName] , TXT "*" , tgt;name[Concept*ConceptName] , TXT "]" ) @@ -32,6 +33,8 @@ PATTERN Context MEANING "A ContextName without Context will be removed." VIOLATION ( TXT "{EX} DelAtom;ContextName;", SRC I ) + IDENT Pattern: Pattern(name[Pattern*PatternName],context[Pattern*Context]) + RELATION name[Concept*ConceptName] [UNI,TOT] MEANING "Every relation has a name by which it can be referenced within its Context(s)." REPRESENT ConceptName TYPE ALPHANUMERIC @@ -145,45 +148,6 @@ PATTERN Validity VIOLATION (TXT "Rule ", SRC name, TXT " is not valid in context ", TGT I) ENDPATTERN -PATTERN Patterns - CONCEPT Pattern "A pattern is a container for relation declarations and rule definitions" - VIEW Pattern: Pattern(name[Pattern*PatternName]) - IDENT Pattern: Pattern(name[Pattern*PatternName],context[Pattern*Context]) - REPRESENT PatternName TYPE ALPHANUMERIC - RELATION name[Pattern*PatternName] [UNI,TOT,SUR] - MEANING "The name of a pattern." - ROLE ExecEngine MAINTAINS "del unused PatternName" - RULE "del unused PatternName" : I[PatternName] |- name~;name - MEANING "A PatternName without Pattern will be removed." - VIOLATION ( TXT "{EX} DelAtom;PatternName;", SRC I ) - - - RELATION allRules[Rule*Context] [] -- ^ all rules in the context, i.e. all user defined rules, property rules, and identity rules. - RELATION udefrules[Rule*Pattern] [] -- ^ all rules the user has declared within this pattern including the patterns it contains, - -- which are not property- and not identity rules. See ViewPoint.hs - RELATION proprules[Rule*Pattern] [] -- ^ all property rules the user has declared within a pattern. - RELATION identityRules[Rule*Pattern] [] -- ^ all identity rules the user has declared within this pattern. This contains all rules declared inside a pattern including the patterns it contains. - RELATION patRules[Pattern*Rule] -- This contains all rules declared inside a pattern. This contains all rules declared inside a pattern including the patterns it contains. - MEANING "The user-defined rules in a pattern." - RELATION declaredIn[Relation*Pattern] -- comes from class Language. This contains all relations declared inside a pattern. - MEANING "The relations that are declared in a pattern." - - ROLE ExecEngine MAINTAINS "Remove rule atom" - RULE "Remove rule atom" : I[Rule] - allRules;I[Context];allRules~ |- -V - MEANING "A rule without declaration will be removed." - VIOLATION ( TXT "{EX} DelAtom;Rule;", SRC I ) - - ROLE ExecEngine MAINTAINS "Remove relation atom" - RULE "Remove relation atom" : I[Relation] - relsDefdIn;I[Context];relsDefdIn~ |- -V - MEANING "A relation without declaration will be removed." - VIOLATION ( TXT "{EX} DelAtom;Relation;", SRC I ) - - ROLE User MAINTAINS "self-sustained rules" - RULE "self-sustained rules" : usedIn;formalTerm~;patRules~ |- declaredIn - MEANING "A relation that is used in a rule, which is declared in a pattern, must be declared in that same pattern." - -ENDPATTERN - ENDCONTEXT diff --git a/AmpersandData/FormalAmpersand/Contexts.docadl b/AmpersandData/FormalAmpersand/Contexts.docadl index 1dd64a5f9d..34ea6a1501 100644 --- a/AmpersandData/FormalAmpersand/Contexts.docadl +++ b/AmpersandData/FormalAmpersand/Contexts.docadl @@ -1,4 +1,4 @@ -CONTEXT RAP IN ENGLISH +CONTEXT FormalAmpersand IN ENGLISH PURPOSE RULE "validity of concepts in a context" {+The relation `context[Concept*Context]` represents all concepts that are valid within a context. Valid concepts can be used in the natural language and the formal language, which makes it relevant to register which concepts are valid within a context. diff --git a/AmpersandData/FormalAmpersand/Documentation.adl b/AmpersandData/FormalAmpersand/Documentation.adl index ead1822cb3..626bb4d89a 100644 --- a/AmpersandData/FormalAmpersand/Documentation.adl +++ b/AmpersandData/FormalAmpersand/Documentation.adl @@ -1,4 +1,4 @@ -CONTEXT RAP IN ENGLISH +CONTEXT FormalAmpersand IN ENGLISH PURPOSE PATTERN Documentation {+ +} diff --git a/AmpersandData/FormalAmpersand/Generics.adl b/AmpersandData/FormalAmpersand/Generics.adl index e95283950b..740ac436da 100644 --- a/AmpersandData/FormalAmpersand/Generics.adl +++ b/AmpersandData/FormalAmpersand/Generics.adl @@ -1,4 +1,4 @@ -CONTEXT Generics IN ENGLISH LATEX +CONTEXT FormalAmpersand IN ENGLISH LATEX PURPOSE CONTEXT Generics {+This context specifies the administration that currently is, and in future will have been, the contents of GENERICS.PHP+} diff --git a/AmpersandData/FormalAmpersand/Interfaces.adl b/AmpersandData/FormalAmpersand/Interfaces.adl index 7600e472d5..5846163a0c 100644 --- a/AmpersandData/FormalAmpersand/Interfaces.adl +++ b/AmpersandData/FormalAmpersand/Interfaces.adl @@ -25,8 +25,6 @@ PATTERN "Static Interface Structure" RELATION context[Interface*Context][UNI] CONCEPT Interface "An interface is a mechanism that communicates data between different (two) contexts." - IDENT Interface: Interface(name,context[Interface*Context]) - REPRESENT Origin TYPE ALPHANUMERIC RELATION ifcPos[Interface*Origin] [UNI] MEANING "The position in the file (filename, line- and column number)." diff --git a/AmpersandData/FormalAmpersand/Interfaces.docadl b/AmpersandData/FormalAmpersand/Interfaces.docadl index a2b4ecd442..6b58f839a3 100644 --- a/AmpersandData/FormalAmpersand/Interfaces.docadl +++ b/AmpersandData/FormalAmpersand/Interfaces.docadl @@ -1,4 +1,4 @@ -CONTEXT RAP IN ENGLISH LATEX +CONTEXT FormalAmpersand IN ENGLISH LATEX INCLUDE "Interfaces.adl" --! It is allowed to change texts and/or the order of texts IF AND ONLY IF this is also done in the corresponding Haskell files !-- diff --git a/AmpersandData/FormalAmpersand/Patterns.adl b/AmpersandData/FormalAmpersand/Patterns.adl index 510bef7c9a..bf474b2e87 100644 --- a/AmpersandData/FormalAmpersand/Patterns.adl +++ b/AmpersandData/FormalAmpersand/Patterns.adl @@ -1,7 +1,48 @@ -CONTEXT RAP IN ENGLISH +CONTEXT FormalAmpersand IN ENGLISH +INCLUDE "Terms.adl" +INCLUDE "Rules.adl" + PATTERN Patterns + CONCEPT Pattern "A pattern is a container for relation declarations and rule definitions" CONCEPT Pattern "A pattern is a file that is meant to contain Ampersand source code." + VIEW Pattern: Pattern(name[Pattern*PatternName]) + + REPRESENT PatternName TYPE ALPHANUMERIC + RELATION name[Pattern*PatternName] [UNI,TOT,SUR] + MEANING "The name of a pattern." + ROLE ExecEngine MAINTAINS "del unused PatternName" + RULE "del unused PatternName" : I[PatternName] |- name~;name + MEANING "A PatternName without Pattern will be removed." + VIOLATION ( TXT "{EX} DelAtom;PatternName;", SRC I ) + + RELATION allRules[Rule*Context] [] -- ^ all rules in the context, i.e. all user defined rules, property rules, and identity rules. + RELATION udefrules[Rule*Pattern] [] -- ^ all rules the user has declared within this pattern including the patterns it contains, + -- which are not property- and not identity rules. See ViewPoint.hs + RELATION proprules[Rule*Pattern] [] -- ^ all property rules the user has declared within a pattern. + RELATION identityRules[Rule*Pattern] [] -- ^ all identity rules the user has declared within this pattern. This contains all rules declared inside a pattern including the patterns it contains. + RELATION patRules[Pattern*Rule] -- This contains all rules declared inside a pattern. This contains all rules declared inside a pattern including the patterns it contains. + MEANING "The user-defined rules in a pattern." + RELATION declaredIn[Relation*Pattern] -- comes from class Language. This contains all relations declared inside a pattern. + MEANING "The relations that are declared in a pattern." + + ROLE ExecEngine MAINTAINS "Remove rule atom" + RULE "Remove rule atom" : I[Rule] - allRules;I[Context];allRules~ |- -V + MEANING "A rule without declaration will be removed." + VIOLATION ( TXT "{EX} DelAtom;Rule;", SRC I ) + + ROLE ExecEngine MAINTAINS "Remove relation atom" + RULE "Remove relation atom" : I[Relation] - relsDefdIn;I[Context];relsDefdIn~ |- -V + MEANING "A relation without declaration will be removed." + VIOLATION ( TXT "{EX} DelAtom;Relation;", SRC I ) + + ROLE User MAINTAINS "self-sustained patterns" + RULE "self-sustained patterns" : usedIn;formalTerm~;patRules~ |- declaredIn[Relation*Pattern] + MEANING "A relation that is used in a rule, which is declared in a pattern, must be declared in that same pattern." + +ENDPATTERN + +PATTERN Patterns CONCEPT Instance "An instance corresponds to an INSTANCE statement in a pattern." CONCEPT Entity "Something that refers to a definition." CONCEPT Definition "A definition is a locally defined entity." diff --git a/AmpersandData/FormalAmpersand/Patterns.docadl b/AmpersandData/FormalAmpersand/Patterns.docadl index 381d0939b5..a2d9e24bb4 100644 --- a/AmpersandData/FormalAmpersand/Patterns.docadl +++ b/AmpersandData/FormalAmpersand/Patterns.docadl @@ -1,4 +1,4 @@ -CONTEXT RAP IN ENGLISH MARKDOWN +CONTEXT FormalAmpersand IN ENGLISH MARKDOWN INCLUDE "Patterns.adl" PURPOSE PATTERN "Reusing Definitions" diff --git a/ReleaseNotes.md b/ReleaseNotes.md index 1b9065e5f2..5135b8f602 100644 --- a/ReleaseNotes.md +++ b/ReleaseNotes.md @@ -1,8 +1,13 @@ # Release notes of Ampersand +## v4.4.1 ( 10 October 2021) + +* [Issue #1212](https://github.com/AmpersandTarski/Ampersand/issues/1212) Solved issue with trailing whitespace. +* [PR #1210](https://github.com/AmpersandTarski/Ampersand/pull/1210) Partial implementation for [Issue #1189](https://github.com/AmpersandTarski/Ampersand/issues/1189). The prototype still has to be adapted, so this issue isn't closed yet. + ## v4.4.0 ( 10 September August 2021) -* PR #1201 changes to Transformers.hs for the new RAP release. +* [PR #1201](https://github.com/AmpersandTarski/Ampersand/pull/1201) Changes to Transformers.hs for the new RAP release. * [Issue #1171](https://github.com/AmpersandTarski/Ampersand/issues/1171) Duplicate labels in VIEW will now result in error, not warning. * [Issue #1204](https://github.com/AmpersandTarski/Ampersand/issues/1204) Introduction of ENFORCE statement. @@ -48,9 +53,9 @@ * [Issue #1084](https://github.com/AmpersandTarski/Ampersand/issues/1084) Add template attributes to BOX syntax * **Breaking change** Because of the implementation of feature of #1084 we could greatly reduce the number of BOX templates (e.g. ROWS, ROWSNL, HROWS and HROWSNL are merged into a single template). Documentation of new templates can be found [here](https://github.com/AmpersandTarski/prototype/tree/master/templates). This breaking change presented an opportunity to rename the built-in templates to more self explaining template names: - * ROWS -> BOX
- * COLS -> BOX - * TABS -> BOX + * ROWS -> BOX \ + * COLS -> BOX \ + * TABS -> BOX \ * Update default prototype framework version to v1.6.0, which includes new templates as described above ## v4.0.2 (17 july 2020) @@ -75,7 +80,6 @@ This breaking change presented an opportunity to rename the built-in templates t * [Issue #1054](https://github.com/AmpersandTarski/Ampersand/issues/1054) Ampersand daemon now also reports type errors * [Issue #1063](https://github.com/AmpersandTarski/Ampersand/issues/1063) Return violations of invariants with standard check * [Issue #735](https://github.com/AmpersandTarski/Ampersand/issues/735) Upgrade to pandoc 2.9. - * Remove option --skip-composer. Relates to topic of [Archicture of Ampersand compiler](https://github.com/AmpersandTarski/Ampersand/issues/903) * Introduce option --[no-]frontend to do/don't generate frontend (i.e. javascript and html files for Angular app) * Introduce option --[no-]backend to do/don't generate backend (i.e. json model for php framework) @@ -276,9 +280,9 @@ It has taken some time since the last release. This release has some major work * [Issue #624](https://github.com/AmpersandTarski/Ampersand/issues/624) New feature: ExecEngine can merge atoms to fix violations of univalence and other identity violations. * [Issue #625](https://github.com/AmpersandTarski/Ampersand/issues/625) Comparison of origins now based on canonicalized paths * [Issue #627](https://github.com/AmpersandTarski/Ampersand/issues/627) Fixed a bug in generation of queries for frontend - * FormalAmpersand.adl and PrototypeContext.adl are no longer used by the compiler. The metamodel is derived from the transformers, so the correspondence between the metamodel and the transformers is 100%. By definition. * There is a new option under "proto" called "metamodel", which is meant to show the metamodel to the user. + ## v3.8.1 (20 january 2017) * [Issue #605](https://github.com/AmpersandTarski/Ampersand/issues/605) Added modules "Modules.adl" and "Patterns.adl" in FormalAmpersand as preparatory work for issue #605. @@ -351,21 +355,21 @@ It has taken some time since the last release. This release has some major work ## v3.5.2 (10 juni 2016) * Work on meatgrinder (still experimental!) -* Bug fix: Issue with SQL query [Issue #152](https://github.com/AmpersandTarski/Ampersand/issues/152) -* Bug fix: minor issue with SQL query [Issue #436](https://github.com/AmpersandTarski/Ampersand/issues/436) -* Bug fix: Nontermination of functional document generator. [Issue #231](https://github.com/AmpersandTarski/Ampersand/issues/231) -* SQL query performance improvements: [Issue #426](https://github.com/AmpersandTarski/Ampersand/issues/426) and [Issue #217](https://github.com/AmpersandTarski/Ampersand/issues/217) +* [Issue #152](https://github.com/AmpersandTarski/Ampersand/issues/152) Issue with SQL query +* [Issue #436](https://github.com/AmpersandTarski/Ampersand/issues/436) Fix minor issue with SQL query +* [Issue #231](https://github.com/AmpersandTarski/Ampersand/issues/231) Fix nontermination of functional document generator. +* [Issue #426](https://github.com/AmpersandTarski/Ampersand/issues/426) and [Issue #217](https://github.com/AmpersandTarski/Ampersand/issues/217) SQL query performance improvements. * Back end performance: Postpone calculation of view and label for Atoms untill really needed (e.g. in interfaces) * Added frontend switch to turn on/off auto saving changes ## v3.5.1 (17 may 2016) * Minor enhancement of generation of Logical Data Model -* More consisten use of views in interface definitions: [Issue #416](https://github.com/AmpersandTarski/Ampersand/issues/416) +* [Issue #416](https://github.com/AmpersandTarski/Ampersand/issues/416) More consisten use of views in interface definitions. * Re-enabled output format for `--fSpec=asciidoc` * Added depth parameter in API resources call (?depth=\). This provides functionality to specify the depth of subinterfaces for which the content must be returned and is especially usefull for recursive (sub)interfaces using the LINKTO statement. * Added this release notes file. -* Bug fixes: [Issue #413](https://github.com/AmpersandTarski/Ampersand/issues/413) +* [Issue #413](https://github.com/AmpersandTarski/Ampersand/issues/413) Bugfix ## v3.5.0 (28 apr 2016) diff --git a/ampersand.cabal b/ampersand.cabal index 1b5de37d2a..1c2a9003ae 100644 --- a/ampersand.cabal +++ b/ampersand.cabal @@ -5,7 +5,7 @@ cabal-version: 2.0 -- see: https://github.com/sol/hpack name: ampersand -version: 4.3.0 +version: 4.4.1 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 @@ -23,8 +23,6 @@ tested-with: extra-source-files: LICENSE ReleaseNotes.md - AmpersandData/FormalAmpersand/AST.adl - AmpersandData/FormalAmpersand/AST.docadl AmpersandData/FormalAmpersand/Concepts.adl AmpersandData/FormalAmpersand/Concepts.docadl AmpersandData/FormalAmpersand/Conjuncts.adl @@ -104,20 +102,25 @@ extra-source-files: testing/Sentinel/Tests/ShouldFail/Issue1127.adl testing/Sentinel/Tests/ShouldFail/Issue1127.xlsx testing/Sentinel/Tests/ShouldFail/Issue298.adl + testing/Sentinel/Tests/ShouldFail/Issue335.adl + testing/Sentinel/Tests/ShouldFail/Issue406.adl + testing/Sentinel/Tests/ShouldFail/OnlyProto/testinfo.yaml + testing/Sentinel/Tests/ShouldFail/OnlyProto/ViewAnnotationCheck.adl testing/Sentinel/Tests/ShouldFail/Session.adl testing/Sentinel/Tests/ShouldFail/singletontest.adl - testing/Sentinel/Tests/ShouldSucceed/Bug335_Kl0Kl1.adl + testing/Sentinel/Tests/ShouldFail/testinfo.yaml testing/Sentinel/Tests/ShouldSucceed/Bug337_FatalONE.adl - testing/Sentinel/Tests/ShouldSucceed/Issue166.adl - testing/Sentinel/Tests/ShouldSucceed/Issue166_2.adl testing/Sentinel/Tests/ShouldSucceed/Issue233.adl testing/Sentinel/Tests/ShouldSucceed/Issue280.adl - testing/Sentinel/Tests/ShouldSucceed/Issue335.adl - testing/Sentinel/Tests/ShouldSucceed/Issue406.adl testing/Sentinel/Tests/ShouldSucceed/Issue751.adl testing/Sentinel/Tests/ShouldSucceed/Issue853.adl + testing/Sentinel/Tests/ShouldSucceed/OnlyValidation/testinfo.yaml + testing/Sentinel/Tests/ShouldSucceed/OnlyValidation/ViewAnnotationCheck.adl + testing/Sentinel/Tests/ShouldSucceed/testinfo.yaml testing/Sentinel/Tests/ShouldSucceed/Ticket580.adl - testing/Sentinel/Tests/ShouldSucceed/ViewAnnotationCheck.adl + testing/StillUnsupported/Bug335_Kl0Kl1.adl + testing/StillUnsupported/Issue166.adl + testing/StillUnsupported/Issue166_2.adl testing/Travis/README.md testing/Travis/testcases/Bugs/Current/Other/testinfo.yaml testing/Travis/testcases/Bugs/Current/SQL/ARM20-Test8.adl diff --git a/package.yaml b/package.yaml index daeaf3c3f0..35e08191d5 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: ampersand -version: 4.4.0 +version: 4.4.1 author: Stef Joosten maintainer: stef.joosten@ou.nl synopsis: Toolsuite for automated design of enterprise information systems. diff --git a/src/Ampersand/ADL1.hs b/src/Ampersand/ADL1.hs index ab46ed7709..1c0e3424c1 100644 --- a/src/Ampersand/ADL1.hs +++ b/src/Ampersand/ADL1.hs @@ -9,7 +9,6 @@ import Ampersand.Core.ParseTree ( PPurpose(..), PRef2Obj(..) , mkPair , FilePos(..), Origin(..), Traced(..) - , Prop(..) , P_Concept(..) , P_Sign(..) , P_Enforce(..), EnforceOperator(..) @@ -20,7 +19,8 @@ import Ampersand.Core.ParseTree ( , PairView(..), PairViewSegment(..) , SrcOrTgt(..) , P_Rule(..),Role(..) - , Prop(..),Props + , PProp(..) + , PPropDefault(..) , P_IdentDef, P_IdentSegment,P_IdentDf(..),P_IdentSegmnt(..) , P_ViewDef, P_ViewSegment(..),P_ViewSegmtPayLoad(..),P_ViewD(..),ViewHtmlTemplate(..) , P_Population(..),PAtomPair(..) @@ -55,6 +55,8 @@ import Ampersand.Core.AbstractSyntaxTree ( , Interface(..), getInterfaceByName , Pattern(..) , Relation(..), Relations, getExpressionRelation, showRel + , AProp(..), AProps + , APropDefault(..) , Rule(..), Rules, A_RoleRule(..) , A_Concept(..), A_Concepts, TType(..), showValADL, showValSQL, unsafePAtomVal2AtomValue , Representation(..) diff --git a/src/Ampersand/ADL1/P2A_Converters.hs b/src/Ampersand/ADL1/P2A_Converters.hs index 48ecd3110d..54d3be16a5 100644 --- a/src/Ampersand/ADL1/P2A_Converters.hs +++ b/src/Ampersand/ADL1/P2A_Converters.hs @@ -28,6 +28,7 @@ import qualified RIO.Map as Map import qualified RIO.Set as Set import qualified RIO.Text as T + pConcToType :: P_Concept -> Type pConcToType P_ONE = BuiltIn TypeOfOne pConcToType p = UserConcept (name p) @@ -252,7 +253,7 @@ pCtx2aCtx env interfaces <- traverse (pIfc2aIfc contextInfo) (p_interfaceAndDisambObjs declMap) -- TODO: explain ... The interfaces defined in this context, outside the scope of patterns purposes <- traverse (pPurp2aPurp contextInfo) p_purposes -- The purposes of objects defined in this context, outside the scope of patterns udpops <- traverse (pPop2aPop contextInfo) p_pops -- [Population] - relations <- traverse (pDecl2aDecl cptMap Nothing deflangCtxt deffrmtCtxt) p_relations + relations <- traverse (pDecl2aDecl (representationOf contextInfo) cptMap Nothing deflangCtxt deffrmtCtxt) p_relations enforces' <- traverse (pEnforce2aEnforce contextInfo Nothing) p_enfs let actx = ACtx{ ctxnm = n1 , ctxpos = n2 @@ -298,14 +299,15 @@ pCtx2aCtx env -- > SJ: It seems to mee that `multitypologies` can be implemented more concisely and more maintainably by using a transitive closure algorithm (Warshall). -- Also, `connectedConcepts` is not used in the result, so is avoidable when using a transitive closure approach. multitypologies <- traverse mkTypology connectedConcepts -- SJ: why `traverse` instead of `map`? Does this have to do with guarded as well? - decls <- traverse (pDecl2aDecl cptMap Nothing deflangCtxt deffrmtCtxt) (p_relations <> concatMap pt_dcs p_patterns) + let reprOf cpt = fromMaybe + Object -- default representation is Object (sometimes called `ugly identifiers') + (lookup cpt typeMap) + decls <- traverse (pDecl2aDecl reprOf cptMap Nothing deflangCtxt deffrmtCtxt) (p_relations <> concatMap pt_dcs p_patterns) let declMap = Map.map groupOnTp (Map.fromListWith (<>) [(name d,[EDcD d]) | d <- decls]) where groupOnTp lst = Map.fromListWith const [(SignOrd$ sign d,d) | d <- lst] let allConcs = Set.fromList (map aConcToType (map source decls <> map target decls)) :: Set.Set Type return CI { ctxiGens = gns - , representationOf = \cpt -> fromMaybe - Object -- default representation is Object (sometimes called `ugly identifiers') - (lookup cpt typeMap) + , representationOf = reprOf , multiKernels = multitypologies , reprList = allReprs , declDisambMap = declMap @@ -816,7 +818,7 @@ pCtx2aCtx env <*> traverse (pPop2aPop ci) (pt_pop ppat) <*> traverse (pViewDef2aViewDef ci) (pt_vds ppat) <*> traverse (pPurp2aPurp ci) (pt_xps ppat) - <*> traverse (pDecl2aDecl cptMap (Just $ name ppat) deflangCtxt deffrmtCtxt) (pt_dcs ppat) + <*> traverse (pDecl2aDecl (representationOf ci) cptMap (Just $ name ppat) deflangCtxt deffrmtCtxt) (pt_dcs ppat) <*> traverse (pure.pConcDef2aConcDef (defaultLang ci) (defaultFormat ci)) (pt_cds ppat) <*> traverse (pure.pRoleRule2aRoleRule) (pt_RRuls ppat) <*> traverse pure (pt_Reprs ppat) @@ -867,24 +869,24 @@ pCtx2aCtx env pEnforce2aEnforce ci mPat = typeCheckEnforce ci mPat . disambiguate (conceptMap ci) (termPrimDisAmb (conceptMap ci) (declDisambMap ci)) typeCheckEnforce :: ContextInfo -> Maybe Text -- name of pattern the enforce is defined in (if any) - -> P_Enforce (TermPrim, DisambPrim) + -> P_Enforce (TermPrim, DisambPrim) -> Guarded AEnforce typeCheckEnforce ci mPat P_Enforce { pos = pos' , penfRel = pRel , penfOp = oper , penfExpr= x - } + } = case pRel of (_,Known (EDcD rel)) -> do (expr,(_srcBounded,_tgtBounded)) <- typecheckTerm ci x - return AEnforce { pos=pos' + return AEnforce { pos=pos' , enfRel=rel , enfOp=oper , enfExpr=expr , enfPatName=mPat } - (o,dx) -> cannotDisambiguate o dx - + (o,dx) -> cannotDisambiguate o dx + pIdentity2aIdentity :: ContextInfo -> Maybe Text -- name of pattern the rule is defined in (if any) -> P_IdentDef -> Guarded IdentityRule @@ -1097,41 +1099,64 @@ pAtomValue2aAtomValue typ cpt pav = where ttyp = typ cpt pDecl2aDecl :: - ConceptMap + (A_Concept -> TType) + -> ConceptMap -> Maybe Text -- name of pattern the rule is defined in (if any) -> Lang -- The default language -> PandocFormat -- The default pandocFormat -> P_Relation -> Guarded Relation -pDecl2aDecl cptMap maybePatName defLanguage defFormat pd - = let (prL:prM:prR:_) = dec_pragma pd <> ["", "", ""] - dcl = Relation - { decnm = dec_nm pd - , decsgn = decSign - , decprps = dec_prps pd - , decprps_calc = Nothing --decprps_calc in an A_Context are still the user-defined only. prps are calculated in adl2fspec. - , decprL = prL - , decprM = prM - , decprR = prR - , decMean = map (pMean2aMean defLanguage defFormat) (dec_Mean pd) - , decfpos = origin pd - , decusr = True - , decpat = maybePatName - , dechash = hash (dec_nm pd) `hashWithSalt` decSign - } - in checkEndoProps >> pure dcl +pDecl2aDecl typ cptMap maybePatName defLanguage defFormat pd + = do checkEndoProps + propLists <- mapM pProp2aProps . Set.toList $ dec_prps pd + return Relation + { decnm = dec_nm pd + , decsgn = decSign + , decprps = Set.fromList . concat $ propLists + , decprL = prL + , decprM = prM + , decprR = prR + , decMean = map (pMean2aMean defLanguage defFormat) (dec_Mean pd) + , decfpos = origin pd + , decusr = True + , decpat = maybePatName + , dechash = hash (dec_nm pd) `hashWithSalt` decSign + } where + (prL:prM:prR:_) = dec_pragma pd <> ["", "", ""] + pProp2aProps :: PProp -> Guarded [AProp] + pProp2aProps p = case p of + P_Uni -> pure [Uni ] + P_Inj -> pure [Inj ] + P_Sur x -> f Sur x + P_Tot x -> f Tot x + P_Sym -> pure [Sym ] + P_Asy -> pure [Asy ] + P_Trn -> pure [Trn ] + P_Rfx -> pure [Rfx ] + P_Irf -> pure [Irf ] + P_Prop -> pure [Sym, Asy] + where f :: (Maybe APropDefault -> AProp) -> Maybe PPropDefault -> Guarded [AProp] + f surOrTot x = + case x of + Nothing -> pure [surOrTot Nothing] + Just d -> (: []) . surOrTot . Just <$> ppropDef2apropDef d + ppropDef2apropDef :: PPropDefault -> Guarded APropDefault + ppropDef2apropDef x = case x of + PDefAtom val -> ADefAtom <$> pAtomValue2aAtomValue typ (target decSign) val + PDefEvalPHP txt -> pure $ ADefEvalPHP txt + decSign = pSign2aSign cptMap (dec_sign pd) checkEndoProps :: Guarded () checkEndoProps | source decSign == target decSign = pure () - | Set.null xs + | null xs = pure () - | otherwise = Errors . pure $ mkEndoPropertyError (origin pd) (Set.elems xs) - where xs = Set.fromList [Prop,Sym,Asy,Trn,Rfx,Irf] `Set.intersection` dec_prps pd - - + | otherwise = Errors . pure $ mkEndoPropertyError (origin pd) (Set.toList xs) + where xs = Set.filter isEndoProp $ dec_prps pd + isEndoProp :: PProp -> Bool + isEndoProp p = p `elem` [P_Prop, P_Sym,P_Asy,P_Trn,P_Rfx,P_Irf] pDisAmb2Expr :: (TermPrim, DisambPrim) -> Guarded Expression pDisAmb2Expr (_,Known x) = pure x pDisAmb2Expr (_,Rel [x]) = pure x @@ -1153,11 +1178,11 @@ pConcDef2aConcDef defLanguage defFormat pCd = pCDDef2Mean :: Lang -- The default language -> PandocFormat -- The default pandocFormat -> PCDDef -> Meaning -pCDDef2Mean defLanguage defFormat x = case x of - PCDDefLegacy defStr refStr -> +pCDDef2Mean defLanguage defFormat x = case x of + PCDDefLegacy defStr refStr -> Meaning Markup{ amLang = defLanguage , amPandoc = string2Blocks defFormat (defStr <> if T.null refStr then mempty else "["<>refStr<>"]") - } + } PCDDefNew m -> pMean2aMean defLanguage defFormat m pMean2aMean :: Lang -- The default language -> PandocFormat -- The default pandocFormat diff --git a/src/Ampersand/ADL1/PrettyPrinters.hs b/src/Ampersand/ADL1/PrettyPrinters.hs index fd51b731e1..6043cf5c14 100644 --- a/src/Ampersand/ADL1/PrettyPrinters.hs +++ b/src/Ampersand/ADL1/PrettyPrinters.hs @@ -9,7 +9,6 @@ import Ampersand.Basics hiding ((<$>),view) import Ampersand.Core.ParseTree import Ampersand.Input.ADL1.Lexer(keywords) import RIO.Char (toUpper) -import qualified RIO.List as L import qualified RIO.NonEmpty as NE import qualified RIO.Text as T import qualified RIO.Text.Partial as Partial(replace) @@ -138,9 +137,8 @@ instance Pretty P_Pattern where instance Pretty P_Relation where pretty (P_Relation nm sign prps pragma mean _) = text "RELATION" <+> (text . T.unpack) nm <~> sign <+> props <+\> pragmas <+\> prettyhsep mean - where props | prps == Set.fromList [Sym, Asy] = text "[PROP]" - | null prps = empty - | otherwise = text ("["++(L.intercalate ",". map show . Set.toList) prps ++ "]") -- do not prettyprint list of properties. + where props | null prps = empty + | otherwise = pretty $ Set.toList prps pragmas | T.null (T.concat pragma) = empty | otherwise = text "PRAGMA" <+> hsep (map quote pragma) @@ -377,9 +375,20 @@ instance Pretty P_Markup where instance Pretty PandocFormat where pretty = text . map toUpper . show -instance Pretty Prop where - pretty = text . map toUpper . show - +instance Pretty PProp where + pretty p = case p of + P_Sur m_ppd -> text "SUR" <> doShow m_ppd + P_Tot m_ppd -> text "SUR" <> doShow m_ppd + _ -> text . map toUpper . show $ p + where + doShow :: Maybe PPropDefault -> Doc + doShow x = case x of + Nothing -> mempty + Just ppd -> text " "<+> pretty ppd +instance Pretty PPropDefault where + pretty x = case x of + PDefAtom pav -> text "VALUE "<+>pretty pav + PDefEvalPHP txt -> text "EVALPHP " <+> text (show txt) instance Pretty PAtomPair where pretty (PPair _ l r) = text "(" <+> pretty l <~> text "," <+> pretty r diff --git a/src/Ampersand/ADL1/Rule.hs b/src/Ampersand/ADL1/Rule.hs index 715dbef16d..ca3dff0ee1 100644 --- a/src/Ampersand/ADL1/Rule.hs +++ b/src/Ampersand/ADL1/Rule.hs @@ -34,7 +34,7 @@ isPropertyRule r= case rrkind r of Propty{} -> True _ -> False -- rulefromProp specifies a rule that defines property prp of relation d. -rulefromProp :: Prop -> Relation -> Rule +rulefromProp :: AProp -> Relation -> Rule rulefromProp prp d = Ru { rrnm = tshow prp<>" "<>showDcl , formalExpression = rExpr @@ -54,15 +54,14 @@ rulefromProp prp d = then fatal ("Illegal property of an endo relation "<>tshow (name d)) else case prp of Uni-> r .:. ECpl (EDcI (target r)) .:. flp r .|-. ECpl (EDcI (source r)) - Tot-> EDcI (source r) .|-. r .:. flp r + Tot _ -> EDcI (source r) .|-. r .:. flp r Inj-> flp r .:. ECpl (EDcI (source r)) .:. r .|-. ECpl (EDcI (target r)) - Sur-> EDcI (target r) .|-. flp r .:. r + Sur _ -> EDcI (target r) .|-. flp r .:. r Sym-> r .==. flp r Asy-> flp r ./\. r .|-. EDcI (source r) Trn-> r .:. r .|-. r Rfx-> EDcI (source r) .|-. r Irf-> r .|-. ECpl (EDcI (source r)) - Prop -> fatal "Prop should have been converted by the parser" meanings prop = map (Meaning . markup) [English,Dutch] where markup lang = Markup lang (string2Blocks ReST $ f lang) @@ -84,9 +83,8 @@ rulefromProp prp d = Irf-> explByFullName lang Uni-> "Each " <>s<>" may only have one "<>t<>"" <>" in the relation "<>name d Inj-> "Each " <>t<>" may only have one "<>s<>"" <>" in the relation "<>name d - Tot ->"Every "<>s<>" must have a " <>t<>"" <>" in the relation "<>name d - Sur ->"Every "<>t<>" must have a " <>s<>"" <>" in the relation "<>name d - Prop -> fatal "Prop should have been converted by the parser" + Tot _ ->"Every "<>s<>" must have a " <>t<>"" <>" in the relation "<>name d + Sur _ ->"Every "<>t<>" must have a " <>s<>"" <>" in the relation "<>name d Dutch -> case prop of Sym-> explByFullName lang @@ -96,12 +94,11 @@ rulefromProp prp d = Irf-> explByFullName lang Uni-> "Elke "<>s<>" mag slechts één "<>t<> " hebben" <>" in de relatie "<>name d Inj-> "Elke "<>t<>" mag slechts één "<>s<> " hebben" <>" in de relatie "<>name d - Tot-> "Elke "<>s<>" dient één " <>t<>" te hebben" <>" in de relatie "<>name d - Sur-> "Elke "<>t<>" dient een " <>s<>" te hebben" <>" in de relatie "<>name d - Prop -> fatal "Prop should have been converted by pattern the parser" + Tot _ -> "Elke "<>s<>" dient één " <>t<>" te hebben" <>" in de relatie "<>name d + Sur _ -> "Elke "<>t<>" dient een " <>s<>" te hebben" <>" in de relatie "<>name d explByFullName lang = showDcl<>" is "<>propFullName False lang prop -propFullName :: Bool -> Lang -> Prop -> Text +propFullName :: Bool -> Lang -> AProp -> Text propFullName isAdjective lang prop = case lang of English -> @@ -112,10 +109,9 @@ propFullName isAdjective lang prop = Rfx-> "reflexive" Irf-> "irreflexive" Uni-> "univalent" - Sur-> "surjective" + Sur _ -> "surjective" Inj-> "injective" - Tot-> "total" - Prop -> fatal "Prop should have been converted by the parser" + Tot _ -> "total" Dutch -> (if isAdjective then snd else fst) $ case prop of Sym-> ("symmetrisch" ,"symmetrische") @@ -124,7 +120,6 @@ propFullName isAdjective lang prop = Rfx-> ("reflexief" ,"reflexieve") Irf-> ("irreflexief" ,"irreflexieve") Uni-> ("univalent" ,"univalente") - Sur-> ("surjectief" ,"surjectieve") + Sur _ -> ("surjectief" ,"surjectieve") Inj-> ("injectief" ,"injectieve") - Tot-> ("totaal" ,"totale") - Prop -> fatal "Prop should have been converted by the parser" + Tot _ -> ("totaal" ,"totale") diff --git a/src/Ampersand/Classes/Relational.hs b/src/Ampersand/Classes/Relational.hs index 56bbcf162f..b63a6c64c7 100644 --- a/src/Ampersand/Classes/Relational.hs +++ b/src/Ampersand/Classes/Relational.hs @@ -10,7 +10,7 @@ import Ampersand.Basics import qualified RIO.Set as Set class HasProps r where - properties :: r -> Props + properties :: r -> AProps class Relational r where isProp :: r -> Bool -- > tells whether the argument is a property isImin :: r -> Bool -- > tells whether the argument is equivalent to I- @@ -30,7 +30,7 @@ class Relational r where isEpsilon :: r -> Bool -- > tells whether the argument is equivalent to I instance HasProps Relation where - properties d = fromMaybe (decprps d) (decprps_calc d) + properties = decprps -- | Is the concept the ONE and only? (universal singleton) isONE :: A_Concept -> Bool @@ -45,11 +45,11 @@ isSESSION cpt = -- but tries to derive the most obvious constraints as well. The more property constraints are known, -- the better the data structure that is derived. -- Not every constraint that can be proven is obtained by this function. This does not hurt Ampersand. -properties' :: Expression -> Props -properties' expr = case expr of +instance HasProps Expression where + properties expr = case expr of EDcD dcl -> properties dcl - EDcI{} -> Set.fromList [Uni,Tot,Inj,Sur,Sym,Asy,Trn,Rfx] - EEps a sgn -> Set.fromList $ [Tot | a == source sgn]++[Sur | a == target sgn] ++ [Uni,Inj] + EDcI{} -> Set.fromList [Uni,Tot Nothing,Inj,Sur Nothing,Sym,Asy,Trn,Rfx] + EEps a sgn -> Set.fromList $ [Tot Nothing| a == source sgn]++[Sur Nothing | a == target sgn] ++ [Uni,Inj] EDcV sgn -> Set.fromList $ --NOT totaal --NOT surjective @@ -59,13 +59,13 @@ properties' expr = case expr of ++[Sym | isEndo sgn] ++[Rfx | isEndo sgn] ++[Trn | isEndo sgn] - EBrk f -> properties' f - ECps (l,r) -> Set.filter (\x->x `elem` [Uni,Tot,Inj,Sur]) (properties' l `Set.intersection` properties' r) - EPrd (l,r) -> Set.fromList $ [Tot | isTot l]++[Sur | isSur r]++[Rfx | isRfx l&&isRfx r]++[Trn] - EKl0 e' -> Set.fromList [Rfx,Trn] `Set.union` (properties' e' Set.\\ Set.fromList [Uni,Inj]) - EKl1 e' -> Set.singleton Trn `Set.union` (properties' e' Set.\\ Set.fromList [Uni,Inj]) - ECpl e' -> Set.singleton Sym `Set.intersection` properties' e' - EFlp e' -> Set.map flp $ properties' e' + EBrk f -> properties f + ECps (l,r) -> Set.filter (\x->x `elem` [Uni,Tot Nothing,Inj,Sur Nothing]) (properties l `Set.intersection` properties r) + EPrd (l,r) -> Set.fromList $ [Tot Nothing | isTot l]++[Sur Nothing | isSur r]++[Rfx | isRfx l&&isRfx r]++[Trn] + EKl0 e' -> Set.fromList [Rfx,Trn] `Set.union` (properties e' Set.\\ Set.fromList [Uni,Inj]) + EKl1 e' -> Set.singleton Trn `Set.union` (properties e' Set.\\ Set.fromList [Uni,Inj]) + ECpl e' -> Set.singleton Sym `Set.intersection` properties e' + EFlp e' -> Set.map flp $ properties e' EMp1{} -> Set.fromList [Uni,Inj,Sym,Asy,Trn] _ -> Set.empty @@ -163,20 +163,20 @@ instance Relational Expression where -- TODO: see if we can find more pro _ -> False -- TODO: find richer answers for ELrs, ERrs, and EDia isFunction r = isUni r && isTot r - isTot = isTotSur Tot - isSur = isTotSur Sur + isTot = isTotSur (Tot Nothing) + isSur = isTotSur (Sur Nothing) isUni = isUniInj Uni isInj = isUniInj Inj - isRfx r = Rfx `elem` properties' r - isIrf r = Irf `elem` properties' r - isTrn r = Trn `elem` properties' r - isSym r = Sym `elem` properties' r - isAsy r = Asy `elem` properties' r + isRfx r = Rfx `elem` properties r + isIrf r = Irf `elem` properties r + isTrn r = Trn `elem` properties r + isSym r = Sym `elem` properties r + isAsy r = Asy `elem` properties r -- Not to be exported: -isTotSur :: Prop -> Expression -> Bool +isTotSur :: AProp -> Expression -> Bool isTotSur prop expr = case expr of EEqu (_,_) -> False @@ -197,16 +197,16 @@ isTotSur prop expr EDcD d -> prop `elem` properties d EDcI{} -> True EEps c sgn -> case prop of - Tot -> c == source sgn - Sur -> c == target sgn + Tot _ -> c == source sgn + Sur _ -> c == target sgn _ -> fatal $ "isTotSur must not be called with "<>tshow prop EDcV{} -> todo EBrk e -> isTotSur prop e EMp1{} -> True where - todo = prop `elem` properties' expr + todo = prop `elem` properties expr -isUniInj :: Prop -> Expression -> Bool +isUniInj :: AProp -> Expression -> Bool isUniInj prop expr = case expr of EEqu (_,_) -> False @@ -231,4 +231,4 @@ isUniInj prop expr EBrk e -> isUniInj prop e EMp1{} -> True where - todo = prop `elem` properties' expr + todo = prop `elem` properties expr diff --git a/src/Ampersand/Classes/ViewPoint.hs b/src/Ampersand/Classes/ViewPoint.hs index d85f32943c..055a23c410 100644 --- a/src/Ampersand/Classes/ViewPoint.hs +++ b/src/Ampersand/Classes/ViewPoint.hs @@ -86,14 +86,13 @@ instance Language A_Context where `Set.union` ctxds context) where -- relations with the same name, but different properties (decprps,pragma,etc.) may exist and need to be united - -- decprps and decprps_calc are united, all others are taken from the head. + -- decprps are united, all others are taken from the head. uniteRels :: Relations -> Relations uniteRels ds = Set.fromList . map fun . eqClass (==) $ Set.elems ds where fun :: NE.NonEmpty Relation -> Relation fun rels = (NE.head rels) {decprps = Set.unions . fmap decprps $ rels - ,decprps_calc = Nothing -- Calculation is only done in ADL2Fspc. - } + } udefrules context = (Set.unions . map udefrules $ ctxpats context) `Set.union` ctxrs context identities context = concatMap identities (ctxpats context) <> ctxks context viewDefs context = concatMap viewDefs (ctxpats context) <> ctxvs context diff --git a/src/Ampersand/Core/A2P_Converters.hs b/src/Ampersand/Core/A2P_Converters.hs index 43ffe155a3..ad13d6e9e3 100644 --- a/src/Ampersand/Core/A2P_Converters.hs +++ b/src/Ampersand/Core/A2P_Converters.hs @@ -11,6 +11,7 @@ module Ampersand.Core.A2P_Converters ( , aIdentityDef2pIdentityDef , aObjectDef2pObjectDef , aRelation2pRelation + , aProps2Pprops , aPopulation2pPopulation , aRule2pRule , aSign2pSign @@ -101,12 +102,34 @@ aRelation2pRelation :: Relation -> P_Relation aRelation2pRelation dcl = P_Relation { dec_nm = decnm dcl , dec_sign = aSign2pSign (decsgn dcl) - , dec_prps = decprps dcl + , dec_prps = aProps2Pprops $ decprps dcl , dec_pragma = [decprL dcl, decprM dcl, decprR dcl] , dec_Mean = map aMeaning2pMeaning (decMean dcl) , pos = decfpos dcl } +aProps2Pprops :: AProps -> Set PProp +aProps2Pprops aps + | P_Sym `elem` xs + && P_Asy `elem` xs = Set.singleton P_Prop `Set.union` (xs Set.\\ Set.fromList [P_Sym, P_Asy]) + | otherwise = xs + where + xs = Set.map aProp2pProp aps + aProp2pProp :: AProp -> PProp + aProp2pProp p = case p of + Uni -> P_Uni + Inj -> P_Inj + Sur x -> P_Sur (aPropDef2pPropDef <$> x) + Tot x -> P_Tot (aPropDef2pPropDef <$> x) + Sym -> P_Sym + Asy -> P_Asy + Trn -> P_Trn + Rfx -> P_Rfx + Irf -> P_Irf + aPropDef2pPropDef :: APropDefault -> PPropDefault + aPropDef2pPropDef x = case x of + ADefAtom val -> PDefAtom $ aAtomValue2pAtomValue val + ADefEvalPHP txt -> PDefEvalPHP txt aRelation2pNamedRel :: Relation -> P_NamedRel aRelation2pNamedRel dcl = PNamedRel { pos = decfpos dcl diff --git a/src/Ampersand/Core/AbstractSyntaxTree.hs b/src/Ampersand/Core/AbstractSyntaxTree.hs index ee029128b3..98c6130d42 100644 --- a/src/Ampersand/Core/AbstractSyntaxTree.hs +++ b/src/Ampersand/Core/AbstractSyntaxTree.hs @@ -16,6 +16,8 @@ module Ampersand.Core.AbstractSyntaxTree ( , RuleKind(..) , AEnforce(..) , Relation(..), Relations, showRel + , AProp(..), AProps + , APropDefault(..) , IdentityRule(..) , IdentitySegment(..) , ViewDef(..) @@ -43,7 +45,7 @@ module Ampersand.Core.AbstractSyntaxTree ( , Signature(..) , Population(..) , HasSignature(..) - , Prop(..),Traced(..) + , Traced(..) , Conjunct(..), DnfClause(..) , AAtomPair(..), AAtomPairs , AAtomValue(..), AAtomValues, mkAtomPair, PAtomValue(..) @@ -68,7 +70,6 @@ import Ampersand.Core.ParseTree , BoxHeader(..) -- , TemplateKeyValue(..) , PairView(..) , PairViewSegment(..) - , Prop(..), Props , Representation(..), TType(..), PAtomValue(..) ) import Ampersand.ADL1.Lattices (Op1EqualitySystem) @@ -187,7 +188,7 @@ instance Eq A_RoleRule where instance Traced A_RoleRule where origin = arPos data RuleKind = UserDefined -- This rule was specified explicitly as a rule in the Ampersand script - | Propty !Prop !Relation + | Propty !AProp !Relation -- This rule follows implicitly from the Ampersand script (Because of a property) and generated by a computer | Identity -- This rule follows implicitly from the Ampersand script (Because of a identity) and generated by a computer | Enforce -- This rule follows implicitly from the Ampersand script (Because of an Enforce statement) and generated by a computer @@ -243,13 +244,63 @@ instance Unique Conjunct where instance Ord Conjunct where compare = compare `on` rc_id +type AProps = Set.Set AProp +data AProp + = -- | univalent + Uni + | -- | injective + Inj + | -- | surjective + Sur (Maybe APropDefault) + | -- | total + Tot (Maybe APropDefault) + | -- | symmetric + Sym + | -- | antisymmetric + Asy + | -- | transitive + Trn + | -- | reflexive + Rfx + | -- | irreflexive + Irf + deriving (Eq, Ord, Data, Typeable) +instance Show AProp where + show Uni = "UNI" + show Inj = "INJ" + show (Sur x) = "SUR"<>(case x of + Nothing -> mempty + Just d -> " "<>show d) + show (Tot x) = "TOT"<>(case x of + Nothing -> mempty + Just d -> " "<>show d) + show Sym = "SYM" + show Asy = "ASY" + show Trn = "TRN" + show Rfx = "RFX" + show Irf = "IRF" + +instance Unique AProp where + showUnique = tshow + +instance Flippable AProp where + flp Uni = Inj + flp (Tot x) = Sur x + flp (Sur x) = Tot x + flp Inj = Uni + flp x = x + +data APropDefault = + ADefAtom !AAtomValue + | ADefEvalPHP !Text + deriving (Eq, Ord, Show, Data) + + type Relations = Set.Set Relation data Relation = Relation { decnm :: Text -- ^ the name of the relation , decsgn :: Signature -- ^ the source and target concepts of the relation - --properties returns decprps_calc, when it has been calculated. So if you only need the user defined properties do not use 'properties' but 'decprps'. - , decprps :: Props -- ^ the user defined properties (Uni, Tot, Sur, Inj, Sym, Asy, Trn, Rfx, Irf) - , decprps_calc :: Maybe Props -- ^ the calculated and user defined properties. Note that calculated properties are made by adl2fspec, so in the A-structure decprps and decprps_calc yield exactly the same answer. + , decprps :: AProps -- ^ the user defined properties (Uni, Tot, Sur, Inj, Sym, Asy, Trn, Rfx, Irf) , decprL :: Text -- ^ three strings, which form the pragma. E.g. if pragma consists of the three strings: "Person ", " is married to person ", and " in Vegas." , decprM :: Text -- ^ then a tuple ("Peter","Jane") in the list of links means that Person Peter is married to person Jane in Vegas. , decprR :: Text @@ -587,7 +638,7 @@ data AAtomValue | AAVDateTime { aavtyp :: TType , aadatetime :: UTCTime } - | AtomValueOfONE deriving (Eq,Ord, Show) + | AtomValueOfONE deriving (Eq,Ord, Show, Data) instance Unique AAtomValue where -- FIXME: this in incorrect! (AAtomValue should probably not be in Unique at all. We need to look into where this is used for.) showUnique pop@AAVString{} = (tshow.aavhash) pop diff --git a/src/Ampersand/Core/ParseTree.hs b/src/Ampersand/Core/ParseTree.hs index 3978d4d2ff..a03049582c 100644 --- a/src/Ampersand/Core/ParseTree.hs +++ b/src/Ampersand/Core/ParseTree.hs @@ -33,7 +33,8 @@ module Ampersand.Core.ParseTree ( , P_Markup(..) - , Prop(..), Props + , PProp(..), PProps + , PPropDefault(..) -- Inherited stuff: , module Ampersand.Input.ADL1.FilePos ) where @@ -82,10 +83,10 @@ data MetaData = MetaData { pos :: Origin instance Traced MetaData where origin = pos -data EnforceOperator = - IsSuperSet Origin +data EnforceOperator = + IsSuperSet Origin | IsSubSet Origin - | IsSameSet Origin + | IsSameSet Origin deriving (Show,Eq) data P_Enforce a = P_Enforce @@ -149,7 +150,7 @@ instance Ord P_Pattern where , tshow (origin b) ]) (maybeOrdering (origin a) (origin b)) - x -> x + x -> x instance Eq P_Pattern where a == b = compare a b == EQ instance Named P_Pattern where @@ -180,7 +181,7 @@ instance Ord PConceptDef where , tshow (origin b) ]) (maybeOrdering (origin a) (origin b)) - x -> x + x -> x instance Eq PConceptDef where a == b = compare a b == EQ instance Unique PConceptDef where @@ -219,7 +220,7 @@ data TType | Date | DateTime | Boolean | Integer | Float | Object | TypeOfOne --special type for the special concept ONE. - deriving (Eq, Ord, Typeable, Enum, Bounded) + deriving (Eq, Ord, Data, Typeable, Enum, Bounded) instance Unique TType where showUnique = tshow instance Show TType where @@ -238,16 +239,22 @@ instance Show TType where Float -> "FLOAT" Object -> "OBJECT" TypeOfOne -> "TYPEOFONE" -data P_Relation = - P_Relation { dec_nm :: Text -- ^ the name of the relation - , dec_sign :: P_Sign -- ^ the type. Parser must guarantee it is not empty. - , dec_prps :: Props -- ^ the user defined properties (Uni, Tot, Sur, Inj, Sym, Asy, Trn, Rfx, Irf) - , dec_pragma :: [Text] -- ^ Three strings, which form the pragma. E.g. if pragma consists of the three strings: "Person ", " is married to person ", and " in Vegas." - -- ^ then a tuple ("Peter","Jane") in the list of links means that Person Peter is married to person Jane in Vegas. - , dec_Mean :: [PMeaning] -- ^ the optional meaning of a relation, possibly more than one for different languages. - , pos :: Origin -- ^ the position in the Ampersand source file where this relation is declared. Not all relations come from the ampersand souce file. - } deriving (Show) --For QuickCheck error messages only! - +data P_Relation = P_Relation + { -- | the name of the relation + dec_nm :: !Text, + -- | the type. Parser must guarantee it is not empty. + dec_sign :: !P_Sign, + -- | the user defined properties (Uni, Tot, Sur, Inj, Sym, Asy, Trn, Rfx, Irf, Prop) + dec_prps :: !PProps, + -- | Three strings, which form the pragma. E.g. if pragma consists of the three strings: "Person ", " is married to person ", and " in Vegas." + -- ^ then a tuple ("Peter","Jane") in the list of links means that Person Peter is married to person Jane in Vegas. + dec_pragma :: ![Text], + -- | the optional meaning of a relation, possibly more than one for different languages. + dec_Mean :: ![PMeaning], + -- | the position in the Ampersand source file where this relation is declared. Not all relations come from the ampersand souce file. + pos :: !Origin + } + deriving (Show) --For QuickCheck error messages only! -- | Equality on P_Relation -- Normally, equality on relations means equality of both name (dec_nm) and signature (dec_sign). -- However, in the parser, we need to distinguish between two relations with the same name and signature when they are in different locations. @@ -272,7 +279,7 @@ mergeRels rs = map fun (eqCl signat rs) -- each equiv. class contains at least 1 fun rels = P_Relation { dec_nm = name r0 , dec_sign = dec_sign r0 - , dec_prps = Set.unions (fmap dec_prps rels) + , dec_prps = Set.unions (dec_prps <$> NE.toList rels) , dec_pragma = case NE.filter (not . T.null . T.concat . dec_pragma) rels of [] -> dec_pragma r0 h:_ -> dec_pragma h @@ -298,26 +305,10 @@ instance Traced PAtomPair where instance Flippable PAtomPair where flp pr = pr{ppLeft = ppRight pr ,ppRight = ppLeft pr} ---data PSingleton --- = PSingleton { pos :: Origin --- , psRaw :: Text --- , psInterprets :: [PAtomValue] --- } ---instance Show PSingleton where --- show = psRaw ---instance Eq PSingleton where --- a == b = compare a b == EQ ---instance Ord PSingleton where --- compare a b = compare (psRaw a) (psRaw b) ---instance Traced PSingleton where --- origin = pos ---type PSingleton = PAtomValue + makePSingleton :: Text -> PAtomValue makePSingleton s = PSingleton (Origin "ParseTree.hs") s Nothing --- PSingleton { psOrig =Origin "ParseTree.hs" --- , psRaw = s --- , psInterprets = fatal "Probably no need to make something up..." --- } + data PAtomValue = PSingleton Origin Text (Maybe PAtomValue) | ScriptString Origin Text -- string from script char to enquote with when printed @@ -329,6 +320,7 @@ data PAtomValue | ScriptDate Origin Day | ScriptDateTime Origin UTCTime deriving (Typeable, Data) + instance Show PAtomValue where -- Used for showing in Expressions as PSingleton show pav = case pav of @@ -341,7 +333,7 @@ instance Show PAtomValue where -- Used for showing in Expressions as PSingleton ComnBool _ b -> show b ScriptDate _ x -> show x ScriptDateTime _ x -> show x - + instance Eq PAtomValue where a == b = compare a b == EQ @@ -470,7 +462,7 @@ instance Functor P_BoxItem where fmap = fmapDefault instance Foldable P_BoxItem where foldMap = foldMapDefault instance Traversable P_BoxItem where traverse f (P_BxExpr nm orig ctx mCrud mView msub) - = (\ctx' msub'-> P_BxExpr nm orig ctx' mCrud mView msub') + = (\ctx' msub'-> P_BxExpr nm orig ctx' mCrud mView msub') <$> traverse f ctx <*> traverse (traverse f) msub traverse _ (P_BxTxt nm pos' str) = pure (P_BxTxt nm pos' str) @@ -484,15 +476,6 @@ instance Traced TermPrim where Pfull orig _ _ -> orig PNamedR r -> origin r ---instance Named TermPrim where --- name e = case e of --- PI _ -> "I" --- Pid _ _ -> "I" --- Patm _ s _ -> s --- PVee _ -> "V" --- Pfull _ _ _ -> "V" --- PNamedR r -> name r --- instance Traced P_NamedRel where origin (PNamedRel o _ _) = o @@ -540,7 +523,7 @@ data PairViewSegment a = instance Eq (PairViewSegment a) where p1 == p2 = compare p1 p2 == EQ instance Ord (PairViewSegment a) where - compare a b = fromMaybe + compare a b = fromMaybe (fatal . T.intercalate "\n" $ ["P_Rule a should have a non-fuzzy Origin." , tshow (origin a) @@ -573,7 +556,7 @@ instance Traversable PairView where instance Functor PairView where fmap = fmapDefault instance Foldable PairView where foldMap = foldMapDefault -data P_Rule a = P_Rule +data P_Rule a = P_Rule { pos :: Origin -- ^ Position in the Ampersand file , rr_nm :: Text -- ^ Name of this rule , rr_exp :: Term a -- ^ The rule expression @@ -589,7 +572,7 @@ instance Ord (P_Rule a) where , tshow (origin b) ]) (maybeOrdering (origin a) (origin b)) - x -> x + x -> x instance Eq (P_Rule a) where --Required for merge of P_Contexts a == b = compare a b == EQ instance Traced (P_Rule a) where @@ -669,15 +652,15 @@ data P_SubIfc a | P_InterfaceRef { pos :: !Origin , si_isLink :: !Bool --True iff LINKTO is used. (will display as hyperlink) , si_str :: !Text -- Name of the interface that is reffered to - } + } deriving (Show) -- | Key-value pairs used to supply attributes into an HTML template that is used to render a subinterface data BoxHeader = BoxHeader { pos :: !Origin - , btType :: !Text + , btType :: !Text -- ^ Type of the HTML template that is used for rendering - , btKeys :: [TemplateKeyValue] + , btKeys :: [TemplateKeyValue] -- ^ Key-value pairs } deriving (Show,Data) @@ -740,7 +723,7 @@ instance Ord (P_IdentDf a) where , tshow (origin b) ]) (maybeOrdering (origin a) (origin b)) -instance Eq (P_IdentDf a) where +instance Eq (P_IdentDf a) where a == b = compare a b == EQ instance Traced (P_IdentDf a) where origin = pos @@ -788,7 +771,7 @@ instance Foldable P_ViewD where foldMap = foldMapDefault instance Traversable P_ViewD where traverse fn (P_Vd a b c d e f) = P_Vd a b c d e <$> traverse (traverse fn) f -data P_ViewSegment a = +data P_ViewSegment a = P_ViewSegment { vsm_labl :: Maybe Text , pos :: Origin , vsm_load :: P_ViewSegmtPayLoad a @@ -799,7 +782,7 @@ instance Functor P_ViewSegment where fmap = fmapDefault instance Foldable P_ViewSegment where foldMap = foldMapDefault instance Traversable P_ViewSegment where traverse fn (P_ViewSegment a b c) = P_ViewSegment a b <$> traverse fn c -data P_ViewSegmtPayLoad a +data P_ViewSegmtPayLoad a = P_ViewExp { vs_expr :: Term a } | P_ViewText { vs_txt :: Text } deriving (Show) @@ -808,12 +791,6 @@ newtype ViewHtmlTemplate = ViewHtmlTemplateFile FilePath -- | ViewHtmlTemplateInline Text -- Future extension deriving (Eq, Ord, Show) -{- Future extension: -data ViewText = ViewTextTemplateFile Text - | ViewTextTemplateInline Text - deriving (Eq, Ord, Show) --} - instance Functor P_ViewSegmtPayLoad where fmap = fmapDefault instance Foldable P_ViewSegmtPayLoad where foldMap = foldMapDefault instance Traversable P_ViewSegmtPayLoad where @@ -821,9 +798,6 @@ instance Traversable P_ViewSegmtPayLoad where traverse _ (P_ViewText a) = pure (P_ViewText a) --- PPurpose is a parse-time constructor. It contains the name of the object it explains. --- It is a pre-explanation in the sense that it contains a reference to something that is not yet built by the compiler. --- Constructor name RefID Explanation data PRef2Obj = PRef2ConceptDef Text | PRef2Relation P_NamedRel | PRef2Rule Text @@ -863,7 +837,7 @@ instance Ord PPurpose where --Required for merge of P_Contexts ]) (maybeOrdering (origin a) (origin b)) x -> x - + instance Eq PPurpose where --Required for merge of P_Contexts a == b = compare a b == EQ @@ -909,42 +883,59 @@ instance Eq PClassify where instance Traced PClassify where origin = pos -type Props = Set.Set Prop - -data Prop = Uni -- ^ univalent - | Inj -- ^ injective - | Sur -- ^ surjective - | Tot -- ^ total - | Sym -- ^ symmetric - | Asy -- ^ antisymmetric - | Trn -- ^ transitive - | Rfx -- ^ reflexive - | Irf -- ^ irreflexive - | Prop -- ^ PROP keyword, the parser must replace this by [Sym, Asy]. It may not occur in the A-structure. - deriving (Eq, Ord, Enum, Bounded,Typeable, Data) - -instance Show Prop where - show Uni = "UNI" - show Inj = "INJ" - show Sur = "SUR" - show Tot = "TOT" - show Sym = "SYM" - show Asy = "ASY" - show Trn = "TRN" - show Rfx = "RFX" - show Irf = "IRF" - show Prop = "PROP" - -instance Unique Prop where +type PProps = Set PProp +data PProp + = -- | univalent + P_Uni + | -- | injective + P_Inj + | -- | surjective + P_Sur (Maybe PPropDefault) + | -- | total + P_Tot (Maybe PPropDefault) + | -- | symmetric + P_Sym + | -- | antisymmetric + P_Asy + | -- | transitive + P_Trn + | -- | reflexive + P_Rfx + | -- | irreflexive + P_Irf + | -- | PROP keyword, the parser must replace this by [Sym, Asy]. + P_Prop + deriving (Eq, Ord, Typeable, Data) + +instance Show PProp where + show P_Uni = "UNI" + show P_Inj = "INJ" + show (P_Sur x) = "SUR"<>case x of + Nothing -> mempty + Just d -> " "<>show d + show (P_Tot x) = "TOT"<>case x of + Nothing -> mempty + Just d -> " "<>show d + show P_Sym = "SYM" + show P_Asy = "ASY" + show P_Trn = "TRN" + show P_Rfx = "RFX" + show P_Irf = "IRF" + show P_Prop = "PROP" + +instance Unique PProp where showUnique = tshow -instance Flippable Prop where - flp Uni = Inj - flp Tot = Sur - flp Sur = Tot - flp Inj = Uni +instance Flippable PProp where + flp P_Uni = P_Inj + flp (P_Tot x) = P_Sur x + flp (P_Sur x) = P_Tot x + flp P_Inj = P_Uni flp x = x - +data PPropDefault = + PDefAtom !PAtomValue + | PDefEvalPHP !Text + deriving (Eq, Ord, Data, Show) mergeContexts :: P_Context -> P_Context -> P_Context mergeContexts ctx1 ctx2 = PCtx{ ctx_nm = case (filter (not.T.null) . map ctx_nm) contexts of @@ -975,26 +966,26 @@ mergeContexts ctx1 ctx2 = -- not know a proper origin of some element. Sometimes the origin -- is used to distinquish between two elements. That is not -- usefull here, and might lead to information lost. - fromContextsKeepDoubles :: (P_Context -> [a]) -> [a] - fromContextsKeepDoubles fun = concatMap fun contexts + fromContextsKeepDoubles :: (P_Context -> [a]) -> [a] + fromContextsKeepDoubles fun = concatMap fun contexts contexts = [ctx1,ctx2] fromContextsRemoveDoubles :: Ord b => (P_Context -> [b]) -> [b] - fromContextsRemoveDoubles f = + fromContextsRemoveDoubles f = Set.toList . Set.unions . map (Set.fromList . f) $ contexts mergePops :: [P_Population] -> [P_Population] mergePops = map mergePopsSameType . NE.groupBy groupCondition where groupCondition :: P_Population -> P_Population -> Bool - groupCondition a b = + groupCondition a b = case (a,b) of - (P_RelPopu{},P_RelPopu{}) -> p_src a == p_src b + (P_RelPopu{},P_RelPopu{}) -> p_src a == p_src b && p_tgt a == p_tgt b && sameNamedRels (p_nmdr a) (p_nmdr b) (P_CptPopu{},P_CptPopu{}) -> p_cpt a == p_cpt b _ -> False where sameNamedRels :: P_NamedRel -> P_NamedRel -> Bool - sameNamedRels x y = p_nrnm x == p_nrnm y + sameNamedRels x y = p_nrnm x == p_nrnm y && p_mbSign x == p_mbSign y mergePopsSameType :: NE.NonEmpty P_Population -> P_Population mergePopsSameType (h :| tl) = case h of diff --git a/src/Ampersand/FSpec/ShowHS.hs b/src/Ampersand/FSpec/ShowHS.hs index fb0f277b19..2d87811d27 100644 --- a/src/Ampersand/FSpec/ShowHS.hs +++ b/src/Ampersand/FSpec/ShowHS.hs @@ -432,7 +432,7 @@ instance ShowHS Rule where ," , rrviol = " <> showHS env "" (rrviol r) ," , rrpat = " <> tshow (rrpat r) ," , rrkind = " <> (case rrkind r of - Propty prp rel -> "Propty "<>showHSName prp<>", "<>showHSName rel + Propty prp rel -> "Propty "<>showHS env "" prp<>", "<>showHSName rel x -> tshow x ) @@ -586,9 +586,6 @@ instance ShowHS Relation where ["Relation { decnm = " <> tshow (decnm d) ," , decsgn = " <> showHS env "" (sign d) ," , decprps = " <> showL(map (showHS env "") (Set.elems $ decprps d)) - ," , decprps_calc = " <> case decprps_calc d of - Nothing -> "Nothing" - Just ps -> "Just "<>showL(map (showHS env "") (Set.elems ps)) ," , decprL = " <> tshow (decprL d) ," , decprM = " <> tshow (decprM d) ," , decprR = " <> tshow (decprR d) @@ -624,20 +621,27 @@ instance ShowHS A_Concept where PlainConcept{} -> "PlainConcept "<>tshow (name c) ONE -> "ONE" -instance ShowHSName Prop where +instance ShowHSName AProp where showHSName Uni = "Uni" showHSName Inj = "Inj" - showHSName Sur = "Sur" - showHSName Tot = "Tot" + showHSName Sur{} = "Sur" + showHSName Tot{} = "Tot" showHSName Sym = "Sym" showHSName Asy = "Asy" showHSName Trn = "Trn" showHSName Rfx = "Rfx" showHSName Irf = "Irf" - showHSName Prop = "Prop" -instance ShowHS Prop where - showHS _ _ = showHSName +instance ShowHS AProp where + showHS env indent prp = indent <> showHSName prp <> + case prp of + Sur d -> " "<> showHS env indent d + Tot d -> " "<> showHS env indent d + _ -> mempty +instance ShowHS APropDefault where + showHS _ _ d = case d of + ADefAtom aav -> "ADefAtom " <> tshow aav + ADefEvalPHP txt -> "ADefEvalPHP "<> tshow txt instance ShowHS FilePos where showHS _ _ = tshow diff --git a/src/Ampersand/FSpec/ShowMeatGrinder.hs b/src/Ampersand/FSpec/ShowMeatGrinder.hs index ae4768e551..340ee4a6b2 100644 --- a/src/Ampersand/FSpec/ShowMeatGrinder.hs +++ b/src/Ampersand/FSpec/ShowMeatGrinder.hs @@ -12,7 +12,7 @@ where import Ampersand.ADL1 import Ampersand.Basics import Ampersand.Core.ParseTree --- import Ampersand.Core.A2P_Converters +import Ampersand.Core.A2P_Converters import Ampersand.FSpec.FSpec import Ampersand.FSpec.Transformers -- import qualified RIO.Set as Set @@ -85,7 +85,7 @@ metarelation tr = P_Relation { dec_nm = tRel tr , dec_sign = P_Sign (mkPConcept (tSrc tr)) (mkPConcept (tTrg tr)) - , dec_prps = mults tr + , dec_prps = aProps2Pprops $ mults tr , dec_pragma = [] , dec_Mean = [] , pos = OriginUnknown diff --git a/src/Ampersand/FSpec/ToFSpec/NormalForms.hs b/src/Ampersand/FSpec/ToFSpec/NormalForms.hs index c875276a42..30ca7c3c4a 100644 --- a/src/Ampersand/FSpec/ToFSpec/NormalForms.hs +++ b/src/Ampersand/FSpec/ToFSpec/NormalForms.hs @@ -547,7 +547,6 @@ rTerm2expr term { decnm = nm , decsgn = sgn , decprps = fatal "Illegal RTerm in rTerm2expr" - , decprps_calc = Nothing , decprL = fatal "Illegal RTerm in rTerm2expr" , decprM = fatal "Illegal RTerm in rTerm2expr" , decprR = fatal "Illegal RTerm in rTerm2expr" @@ -1029,7 +1028,6 @@ delta sgn { decnm = T.pack "Delta" , decsgn = sgn , decprps = Set.empty - , decprps_calc = Nothing , decprL = "" , decprM = "" , decprR = "" diff --git a/src/Ampersand/FSpec/Transformers.hs b/src/Ampersand/FSpec/Transformers.hs index 74563ed0b7..af89f7f10c 100644 --- a/src/Ampersand/FSpec/Transformers.hs +++ b/src/Ampersand/FSpec/Transformers.hs @@ -28,7 +28,7 @@ data Transformer = Transformer { tRel :: Text -- name of relation , tSrc :: Text -- name of source , tTrg :: Text -- name of target - , mults :: Props -- property constraints + , mults :: AProps -- property constraints , tPairs :: [PAtomPair]-- the population of this relation from the user's script. } @@ -53,7 +53,7 @@ dirtyId :: Unique a => a -> PopAtom dirtyId = DirtyId . idWithoutType -- Function for PrototypeContext transformers. These atoms don't need to have a type prefix -toTransformer :: (Text, Text, Text, Props, [ (PopAtom,PopAtom)] ) -> Transformer +toTransformer :: (Text, Text, Text, AProps, [ (PopAtom,PopAtom)] ) -> Transformer toTransformer (rel,src,tgt,props,tuples) = Transformer rel src tgt props tuples' where @@ -140,20 +140,20 @@ transformersFormalAmpersand fSpec = map toTransformer [ ] ) ,("arg" , "UnaryTerm" , "Term" - , Set.fromList [Uni,Tot] + , Set.fromList [Uni,Tot Nothing] , [ (dirtyId expr, dirtyId x) | expr::Expression <- instanceList fSpec , Just x <- [arg expr] ] ) ,("asMarkdown" , "Markup" , "Text" - , Set.fromList [Uni,Tot] + , Set.fromList [Uni,Tot Nothing] , [ (dirtyId mrk,(PopAlphaNumeric . P.stringify . amPandoc) mrk) | mrk::Markup <- instanceList fSpec ] ) ,("bind" , "BindedRelation" , "Relation" - , Set.fromList [Uni,Tot] + , Set.fromList [Uni,Tot Nothing] , [ (dirtyId expr, dirtyId x) | expr::Expression <- instanceList fSpec , Just x <- [bindedRel expr] @@ -167,7 +167,7 @@ transformersFormalAmpersand fSpec = map toTransformer [ ] ) ,("rc_conjunct" , "Conjunct" , "Term" - , Set.fromList [Uni,Tot] + , Set.fromList [Uni,Tot Nothing] , [ (dirtyId conj, dirtyId (rc_conjunct conj)) | conj::Conjunct <- instanceList fSpec ] @@ -180,49 +180,49 @@ transformersFormalAmpersand fSpec = map toTransformer [ ] ) ,("context" , "Interface" , "Context" - , Set.fromList [Uni,Tot] + , Set.fromList [Uni,Tot Nothing] , [ (dirtyId ifc,dirtyId ctx) | ctx::A_Context <- instanceList fSpec , ifc::Interface <- ctxifcs ctx ] ) ,("context" , "Isa" , "Context" - , Set.fromList [Uni,Tot] + , Set.fromList [Uni,Tot Nothing] , [ (dirtyId isa, dirtyId ctx) | ctx::A_Context <- instanceList fSpec , isa@Isa{} <- instanceList fSpec ] ) ,("context" , "IsE" , "Context" - , Set.fromList [Uni,Tot] + , Set.fromList [Uni,Tot Nothing] , [ (dirtyId ise, dirtyId ctx) | ctx::A_Context <- instanceList fSpec , ise@IsE{} <- instanceList fSpec ] ) ,("context" , "Pattern" , "Context" - , Set.fromList [Uni,Tot] + , Set.fromList [Uni,Tot Nothing] , [ (dirtyId pat, dirtyId ctx) | ctx::A_Context <- instanceList fSpec , pat::Pattern <- instanceList fSpec ] ) ,("context" , "Population" , "Context" - , Set.fromList [Uni,Tot] + , Set.fromList [Uni,Tot Nothing] , [ (dirtyId pop, dirtyId ctx) | ctx::A_Context <- instanceList fSpec , pop::Population <- instanceList fSpec ] ) ,("ctxcds" , "ConceptDef" , "Context" - , Set.fromList [Uni,Tot] + , Set.fromList [Uni,Tot Nothing] , [ (dirtyId cdf, dirtyId ctx) | ctx::A_Context <- instanceList fSpec , cdf::AConceptDef <- instanceList fSpec ] ) ,("relsDefdIn" , "Relation" , "Context" ---contains ALL relations defined in this context - , Set.fromList [Uni,Tot] + , Set.fromList [Uni,Tot Nothing] , [ (dirtyId rel, dirtyId ctx) | ctx::A_Context <- instanceList fSpec , rel::Relation <- Set.elems $ relsDefdIn ctx @@ -286,14 +286,14 @@ transformersFormalAmpersand fSpec = map toTransformer [ , [] --TODO ) ,("fieldIn" , "FieldDef" , "ObjectDef" - , Set.fromList [Uni,Tot] + , Set.fromList [Uni,Tot Nothing] , [ (dirtyId fld, dirtyId obj) | obj::ObjectDef <- instanceList fSpec , fld <- fields obj ] ) ,("first" , "BinaryTerm" , "Term" - , Set.fromList [Uni,Tot] + , Set.fromList [Uni,Tot Nothing] , [ (dirtyId expr, dirtyId x) | expr::Expression <- instanceList fSpec , Just x <- [first expr] @@ -306,25 +306,25 @@ transformersFormalAmpersand fSpec = map toTransformer [ ] ) ,("gengen" , "Isa" , "Concept" - , Set.fromList [Uni,Tot] + , Set.fromList [Uni,Tot Nothing] , [ ( dirtyId isa, dirtyId (gengen isa)) | isa@Isa{} <- instanceList fSpec ] ) ,("gengen" , "IsE" , "Concept" - , Set.fromList [Tot] + , Set.fromList [Tot Nothing] -- it is Tot by definition, because genrhs is a NonEmpty. , [ ( dirtyId ise, dirtyId cpt) | ise@IsE{} <- instanceList fSpec , cpt <- NE.toList $ genrhs ise] ) ,("genspc" , "IsE" , "Concept" - , Set.fromList [Uni,Tot] + , Set.fromList [Uni,Tot Nothing] , [ ( dirtyId ise, dirtyId (genspc ise)) | ise@IsE{} <- instanceList fSpec ] ) ,("genspc" , "Isa" , "Concept" - , Set.fromList [Uni,Tot] + , Set.fromList [Uni,Tot Nothing] , [ ( dirtyId isa, dirtyId (genspc isa)) | isa@Isa{} <- instanceList fSpec ] @@ -355,7 +355,7 @@ transformersFormalAmpersand fSpec = map toTransformer [ , [] --TODO ) ,("ifcObj" , "Interface" , "ObjectDef" - , Set.fromList [Uni,Tot] + , Set.fromList [Uni,Tot Nothing] , [ (dirtyId ifc, dirtyId (ifcObj ifc)) | ifc::Interface <- instanceList fSpec ] @@ -402,16 +402,16 @@ transformersFormalAmpersand fSpec = map toTransformer [ ) ,("isa" , "Concept" , "Concept" , Set.empty - , [ ( dirtyId gCpt, dirtyId (genspc ise)) + , [ ( dirtyId (genspc ise), dirtyId gCpt) | ise@IsE{} <- instanceList fSpec , gCpt <- NE.toList $ genrhs ise ] ++ - [ ( dirtyId (genspc isa), dirtyId (genspc isa)) + [ ( dirtyId (genspc isa), dirtyId (gengen isa)) | isa@Isa{} <- instanceList fSpec ] ) ,("label" , "FieldDef" , "FieldName" - , Set.fromList [Uni,Tot] + , Set.fromList [Uni,Tot Nothing] , [ (dirtyId fld, PopAlphaNumeric (name obj)) | obj::ObjectDef <- instanceList fSpec , fld <- fields obj @@ -436,13 +436,13 @@ transformersFormalAmpersand fSpec = map toTransformer [ ] ) ,("markup" , "Meaning" , "Markup" - , Set.fromList [Uni,Tot] + , Set.fromList [Uni,Tot Nothing] , [ (dirtyId mean, dirtyId . ameaMrk $ mean) | mean::Meaning <- Set.toList . meaningInstances $ fSpec ] ) ,("markup" , "Purpose" , "Markup" - , Set.fromList [Uni,Tot] + , Set.fromList [Uni,Tot Nothing] , [ (dirtyId purp, dirtyId . explMarkup $ purp) | purp::Purpose <- Set.toList . purposeInstances $ fSpec ] @@ -473,7 +473,7 @@ transformersFormalAmpersand fSpec = map toTransformer [ ] ) ,("propertyRule" , "Relation" , "PropertyRule" - , Set.fromList [Sur] + , Set.fromList [Sur Nothing] , [ (dirtyId rel, dirtyId rul) | ctx::A_Context <- instanceList fSpec , rul <- Set.elems $ proprules ctx @@ -481,7 +481,7 @@ transformersFormalAmpersand fSpec = map toTransformer [ ] ) ,("declaredthrough" , "PropertyRule" , "Property" - , Set.fromList [Tot] + , Set.fromList [Tot Nothing] , [ (dirtyId rul, (PopAlphaNumeric . tshow) prop) | ctx::A_Context <- instanceList fSpec , rul <- Set.elems $ proprules ctx @@ -495,31 +495,31 @@ transformersFormalAmpersand fSpec = map toTransformer [ ] ) ,("name" , "Context" , "ContextName" - , Set.fromList [Uni,Tot] + , Set.fromList [Uni,Tot Nothing] , [ (dirtyId ctx, (PopAlphaNumeric . name) ctx) | ctx::A_Context <- instanceList fSpec ] ) ,("name" , "Interface" , "InterfaceName" - , Set.fromList [Uni,Tot] + , Set.fromList [Uni,Tot Nothing] , [ (dirtyId ifc, (PopAlphaNumeric . name) ifc) | ifc::Interface <- instanceList fSpec ] ) ,("name" , "ObjectDef" , "ObjectName" - , Set.fromList [Uni,Tot] + , Set.fromList [Uni,Tot Nothing] , [ (dirtyId obj, (PopAlphaNumeric . name) obj) | obj::ObjectDef <- instanceList fSpec ] ) ,("name" , "Pattern" , "PatternName" - , Set.fromList [Uni,Tot] + , Set.fromList [Uni,Tot Nothing] , [ (dirtyId pat,(PopAlphaNumeric . name) pat) | pat::Pattern <- instanceList fSpec ] ) ,("name" , "Relation" , "RelationName" - , Set.fromList [Uni,Tot] + , Set.fromList [Uni,Tot Nothing] , [ (dirtyId rel,(PopAlphaNumeric . name) rel) | rel::Relation <- instanceList fSpec ] @@ -531,13 +531,13 @@ transformersFormalAmpersand fSpec = map toTransformer [ ] ) ,("name" , "Rule" , "RuleName" - , Set.fromList [Uni,Tot] + , Set.fromList [Uni,Tot Nothing] , [ (dirtyId rul,(PopAlphaNumeric . name) rul) | rul::Rule <- instanceList fSpec ] ) - ,("name" , "ViewDef" , "ViewDefName" - , Set.fromList [Uni,Tot] + ,("name" , "View" , "ViewDefName" + , Set.fromList [Uni,Tot Nothing] , [ (dirtyId vd, PopAlphaNumeric . tshow . name $ vd) | vd::ViewDef <- instanceList fSpec ] @@ -557,14 +557,14 @@ transformersFormalAmpersand fSpec = map toTransformer [ ] ) ,("operator" , "BinaryTerm" , "Operator" - , Set.fromList [Uni,Tot] + , Set.fromList [Uni,Tot Nothing] , [ (dirtyId expr, PopAlphaNumeric . tshow $ op) | expr::Expression <- instanceList fSpec , Just op <- [binOp expr] ] ) ,("operator" , "UnaryTerm" , "Operator" - , Set.fromList [Uni,Tot] + , Set.fromList [Uni,Tot Nothing] , [ (dirtyId expr, PopAlphaNumeric . tshow $ op) | expr::Expression <- instanceList fSpec , Just op <- [unaryOp expr] @@ -652,13 +652,13 @@ transformersFormalAmpersand fSpec = map toTransformer [ ] --TODO ) ,("qDcl" , "Quad" , "Relation" - , Set.fromList [Uni,Tot] + , Set.fromList [Uni,Tot Nothing] , [ (dirtyId quad, dirtyId (qDcl quad)) | quad <- vquads fSpec ] --TODO ) ,("qRule" , "Quad" , "Rule" - , Set.fromList [Uni,Tot] + , Set.fromList [Uni,Tot Nothing] , [ (dirtyId quad, dirtyId (qRule quad)) | quad <- vquads fSpec ] --TODO @@ -678,7 +678,7 @@ transformersFormalAmpersand fSpec = map toTransformer [ ] ) ,("second" , "BinaryTerm" , "Term" - , Set.fromList [Uni,Tot] + , Set.fromList [Uni,Tot Nothing] , [ (dirtyId expr, dirtyId x) | expr::Expression <- instanceList fSpec , Just x <- [second expr] @@ -709,58 +709,58 @@ transformersFormalAmpersand fSpec = map toTransformer [ , [] --TODO ) ,("showADL" , "Term" , "ShowADL" - , Set.fromList [Uni,Tot] + , Set.fromList [Uni,Tot Nothing] , [ (dirtyId expr, PopAlphaNumeric (showA expr)) | expr::Expression <- instanceList fSpec ] ) ,("sign" , "Term" , "Signature" - , Set.fromList [Uni,Tot] + , Set.fromList [Uni,Tot Nothing] , [ (dirtyId expr, dirtyId (sign expr)) | expr::Expression <- instanceList fSpec ] ) ,("sign" , "Relation" , "Signature" - , Set.fromList [Uni,Tot] + , Set.fromList [Uni,Tot Nothing] , [ (dirtyId rel, dirtyId (sign rel)) | rel::Relation <- instanceList fSpec ] ) ,("singleton" , "Singleton" , "AtomValue" - , Set.fromList [Uni,Tot] + , Set.fromList [Uni,Tot Nothing] , [ (dirtyId expr, dirtyId x) | expr::Expression <- instanceList fSpec , Just x <- [singleton expr] ] ) ,("source" , "Relation" , "Concept" - , Set.fromList [Uni,Tot] + , Set.fromList [Uni,Tot Nothing] , [ (dirtyId rel, dirtyId (source rel)) | rel::Relation <- instanceList fSpec ] ) ,("src" , "Signature" , "Concept" - , Set.fromList [Uni,Tot] + , Set.fromList [Uni,Tot Nothing] , [ (dirtyId sgn, dirtyId (source sgn)) | sgn::Signature <- instanceList fSpec ] ) ,("srcOrTgt" , "PairViewSegment" , "SourceOrTarget" - , Set.fromList [Uni,Tot] + , Set.fromList [Uni,Tot Nothing] , [] --TODO ) ,("target" , "Relation" , "Concept" - , Set.fromList [Uni,Tot] + , Set.fromList [Uni,Tot Nothing] , [ (dirtyId rel, dirtyId (target rel)) | rel::Relation <- instanceList fSpec ] ) ,("text" , "PairViewSegment" , "String" - , Set.fromList [Uni,Tot] + , Set.fromList [Uni,Tot Nothing] , [] --TODO ) ,("tgt" , "Signature" , "Concept" - , Set.fromList [Uni,Tot] + , Set.fromList [Uni,Tot Nothing] , [ (dirtyId sgn, dirtyId (target sgn)) | sgn::Signature <- instanceList fSpec ] @@ -811,53 +811,53 @@ transformersFormalAmpersand fSpec = map toTransformer [ ] ) ,("userCpt" , "Epsilon" , "Concept" - , Set.fromList [Uni,Tot] + , Set.fromList [Uni,Tot Nothing] , [ (dirtyId expr, dirtyId x) | expr::Expression <- instanceList fSpec , Just (x::A_Concept) <- [userCpt expr] ] ) ,("userSrc" , "V" , "Concept" - , Set.fromList [Uni,Tot] + , Set.fromList [Uni,Tot Nothing] , [ (dirtyId expr, dirtyId x) | expr::Expression <- instanceList fSpec , Just x <- [userSrc expr] ] ) ,("userTgt" , "V" , "Concept" - , Set.fromList [Uni,Tot] + , Set.fromList [Uni,Tot Nothing] , [ (dirtyId expr, dirtyId x) | expr::Expression <- instanceList fSpec , Just x <- [userTgt expr] ] ) - ,("vdats" , "ViewDef" , "ViewSegment" - , Set.fromList [Inj,Sur] + ,("vdats" , "View" , "ViewSegment" + , Set.fromList [Inj,Sur Nothing] , [ (dirtyId vd, PopAlphaNumeric . tshow $ vs) | vd::ViewDef <- instanceList fSpec , vs <- vdats vd ] ) - ,("vdcpt" , "ViewDef" , "Concept" + ,("vdcpt" , "View" , "Concept" , Set.fromList [Uni] , [ (dirtyId vd, PopAlphaNumeric . tshow . vdcpt $ vd) | vd::ViewDef <- instanceList fSpec, vdIsDefault vd ] ) - ,("vdhtml" , "ViewDef" , "Concept" + ,("vdhtml" , "View" , "Concept" , Set.fromList [Uni] , [ (dirtyId vd, PopAlphaNumeric . tshow $ html) | vd::ViewDef <- instanceList fSpec , Just html <- [vdhtml vd] ] ) - ,("vdIsDefault" , "ViewDef" , "Concept" - , Set.fromList [Uni,Tot] + ,("vdIsDefault" , "View" , "Concept" + , Set.fromList [Uni,Tot Nothing] , [ (dirtyId vd, PopAlphaNumeric . tshow . vdcpt $ vd) | vd::ViewDef <- instanceList fSpec ] ) - ,("vdpos" , "ViewDef" , "Origin" + ,("vdpos" , "View" , "Origin" , Set.fromList [Uni] , [ (dirtyId vd, PopAlphaNumeric . tshow . origin $ vd) | vd::ViewDef <- instanceList fSpec @@ -865,7 +865,7 @@ transformersFormalAmpersand fSpec = map toTransformer [ ] ) ,("versionInfo" , "Context" , "AmpersandVersion" - , Set.fromList [Uni,Tot] + , Set.fromList [Uni,Tot Nothing] , [ (dirtyId ctx,PopAlphaNumeric (longVersion appVersion)) | ctx::A_Context <- instanceList fSpec ] diff --git a/src/Ampersand/Input/ADL1/CtxError.hs b/src/Ampersand/Input/ADL1/CtxError.hs index 78cea237c2..1e6dc6502e 100644 --- a/src/Ampersand/Input/ADL1/CtxError.hs +++ b/src/Ampersand/Input/ADL1/CtxError.hs @@ -333,7 +333,7 @@ mkUndeclaredError entity objDef ref = "Undeclared " <> entity <> " " <> tshow ref <> " referenced at field " <> tshow (obj_nm objDef) _ -> fatal "Unexpected use of mkUndeclaredError." -mkEndoPropertyError :: Origin -> [Prop] -> CtxError +mkEndoPropertyError :: Origin -> [PProp] -> CtxError mkEndoPropertyError orig ps = CTXE orig msg where diff --git a/src/Ampersand/Input/ADL1/Lexer.hs b/src/Ampersand/Input/ADL1/Lexer.hs index df9ef03ae9..0885ceaf6f 100644 --- a/src/Ampersand/Input/ADL1/Lexer.hs +++ b/src/Ampersand/Input/ADL1/Lexer.hs @@ -48,10 +48,8 @@ keywords = L.nub $ , "CONCEPT" -- Keywords for Relation-statements , "RELATION", "PRAGMA", "MEANING" - ] ++ - [map toUpper $ show x | x::Prop <-[minBound..] - ] ++ - [ "POPULATION", "CONTAINS" + , "ASY", "INJ", "IRF", "RFX", "SUR", "SYM", "TOT", "TRN", "UNI", "PROP", "VALUE", "EVALPHP" + , "POPULATION", "CONTAINS" -- Keywords for rules , "RULE", "MESSAGE", "VIOLATION", "TXT" ] ++ diff --git a/src/Ampersand/Input/ADL1/Parser.hs b/src/Ampersand/Input/ADL1/Parser.hs index 9cc8349af1..3f790352b7 100644 --- a/src/Ampersand/Input/ADL1/Parser.hs +++ b/src/Ampersand/Input/ADL1/Parser.hs @@ -98,9 +98,9 @@ data ContextElement = CMeta MetaData data Include = Include Origin FilePath [Text] --- IncludeStatement ::= 'INCLUDE' Text pIncludeStatement :: AmpParser Include -pIncludeStatement = +pIncludeStatement = Include <$> currPos - <* pKey "INCLUDE" + <* pKey "INCLUDE" <*> pDoubleQuotedString <*> (pBrackets (asText pDoubleQuotedString `sepBy` pComma) <|> return []) @@ -209,8 +209,8 @@ pClassify = fun <$> currPos where fun :: Origin -> NE.NonEmpty P_Concept -> (Bool, [P_Concept]) -> [PClassify] fun p lhs (isISA ,rhs) = NE.toList $ fmap f lhs - where - f s = PClassify + where + f s = PClassify { pos = p , specific = s , generics = if isISA then s NE.:| rhs else PARTIAL.fromList rhs @@ -245,7 +245,7 @@ pRuleDef = P_Rule <$> currPos pPairView :: AmpParser (PairView (Term TermPrim)) pPairView = PairView <$> pParens (pPairViewSegment `sepBy1` pComma) -- where f xs = PairView {ppv_segs = xs} - + --- PairViewSegmentList ::= PairViewSegment (',' PairViewSegment)* --- PairViewSegment ::= 'SRC' Term | 'TGT' Term | 'TXT' Text pPairViewSegment :: AmpParser (PairViewSegment (Term TermPrim)) @@ -264,7 +264,7 @@ pRelationDef = reorder <$> currPos <* optList (pOperator ".") where reorder pos' (nm,sign,fun) prop pragma meanings prs = (P_Relation nm sign props pragma meanings pos', map pair2pop prs) - where + where props = prop `Set.union` fun pair2pop :: PAtomPair -> P_Population pair2pop a = P_RelPopu Nothing Nothing (origin a) rel [a] @@ -272,14 +272,14 @@ pRelationDef = reorder <$> currPos rel = PNamedRel pos' nm (Just sign) --- RelationNew ::= 'RELATION' Varid Signature -pRelationNew :: AmpParser (Text,P_Sign,Props) +pRelationNew :: AmpParser (Text,P_Sign,PProps) pRelationNew = (,,) <$ pKey "RELATION" <*> asText pVarid <*> pSign <*> return Set.empty --- RelationOld ::= Varid '::' ConceptRef Fun ConceptRef -pRelationOld :: AmpParser (Text,P_Sign,Props) +pRelationOld :: AmpParser (Text,P_Sign,PProps) pRelationOld = relOld <$> asText pVarid <* pOperator "::" <*> pConceptRef @@ -288,42 +288,52 @@ pRelationOld = relOld <$> asText pVarid where relOld nm src fun tgt = (nm,P_Sign src tgt,fun) --- Props ::= '[' PropList? ']' -pProps :: AmpParser (Set.Set Prop) +pProps :: AmpParser (Set.Set PProp) pProps = normalizeProps <$> pBrackets (pProp `sepBy` pComma) --- PropList ::= Prop (',' Prop)* - --- Prop ::= 'UNI' | 'INJ' | 'SUR' | 'TOT' | 'SYM' | 'ASY' | 'TRN' | 'RFX' | 'IRF' | 'PROP' - where pProp :: AmpParser Prop - pProp = choice [ p <$ pKey (show p) | p <- [minBound..] ] - normalizeProps :: [Prop] -> Props + --- Prop ::= 'UNI' | 'INJ' | 'SUR' PropDefault? | 'TOT' PropDefault? | 'SYM' | 'ASY' | 'TRN' | 'RFX' | 'IRF' | 'PROP' + where pProp :: AmpParser PProp + pProp = choice $ + [ p <$ pKey (show p) | p <- [P_Uni, P_Inj, P_Sym, P_Asy, P_Trn, P_Rfx, P_Irf, P_Prop] + ] <> + [ P_Tot <$ pKey "TOT" <*> pMaybe pPropDefault + , P_Sur <$ pKey "SUR" <*> pMaybe pPropDefault] + --- PropDefault ::= 'VALUE' AtomValue | 'EVALPHP' DoubleQuotedString + where pPropDefault :: AmpParser PPropDefault + pPropDefault = choice + [ PDefAtom <$ pKey "VALUE" <*> pAtomValue + , PDefEvalPHP <$ pKey "EVALPHP" <*> (T.pack <$> pDoubleQuotedString) + ] + normalizeProps :: [PProp] -> PProps normalizeProps = conv.rep . Set.fromList where -- replace PROP by SYM, ASY - rep :: Props -> Props - rep ps - | Prop `elem` ps = Set.fromList [Sym, Asy] `Set.union` (Prop `Set.delete` ps) + rep :: PProps -> PProps + rep ps + | P_Prop `elem` ps = Set.fromList [P_Sym, P_Asy] `Set.union` (P_Prop `Set.delete` ps) | otherwise = ps -- add Uni and Inj if ps has neither Sym nor Asy - conv :: Props -> Props + conv :: PProps -> PProps conv ps = ps `Set.union` - if Sym `elem` ps && Asy `elem` ps - then Set.fromList [Uni,Inj] + if P_Sym `elem` ps && P_Asy `elem` ps + then Set.fromList [P_Uni,P_Inj] else Set.empty --- Fun ::= '*' | '->' | '<-' | '[' Mults ']' -pFun :: AmpParser Props +pFun :: AmpParser PProps pFun = Set.empty <$ pOperator "*" <|> - Set.fromList [Uni,Tot] <$ pOperator "->" <|> - Set.fromList [Sur,Inj] <$ pOperator "<-" <|> + Set.fromList [P_Uni ,P_Tot Nothing ] <$ pOperator "->" <|> + Set.fromList [P_Sur Nothing ,P_Inj ] <$ pOperator "<-" <|> pBrackets pMults --- Mults ::= Mult '-' Mult - where pMults :: AmpParser Props - pMults = Set.union <$> optSet (pMult (Sur,Inj)) + where pMults :: AmpParser PProps + pMults = Set.union <$> optSet (pMult (P_Sur Nothing ,P_Inj)) <* pDash - <*> optSet (pMult (Tot,Uni)) + <*> optSet (pMult (P_Tot Nothing ,P_Uni)) --- Mult ::= ('0' | '1') '..' ('1' | '*') | '*' | '1' --TODO: refactor to Mult ::= '0' '..' ('1' | '*') | '1'('..' ('1' | '*'))? | '*' - pMult :: (Prop,Prop) -> AmpParser Props + pMult :: (PProp,PProp) -> AmpParser PProps pMult (ts,ui) = Set.union <$> (Set.empty <$ pZero <|> Set.singleton ts <$ try pOne) <* pOperator ".." <*> (Set.singleton ui <$ try pOne <|> (Set.empty <$ pOperator "*" )) <|> @@ -339,11 +349,11 @@ pConceptDef = PConceptDef <$> currPos <*> many pMeaning where pPCDDef2 :: AmpParser PCDDef - pPCDDef2 = + pPCDDef2 = (PCDDefLegacy <$> (asText pDoubleQuotedString "concept definition (string)") <*> (asText pDoubleQuotedString `opt` "") -- a reference to the source of this definition. ) - <|> (PCDDefNew <$> pMeaning) + <|> (PCDDefNew <$> pMeaning) --- Representation ::= 'REPRESENT' ConceptNameList 'TYPE' AdlTType pRepresentation :: AmpParser Representation pRepresentation @@ -417,10 +427,10 @@ pFancyViewDef = mkViewDef <$> currPos pHtmlView :: AmpParser ViewHtmlTemplate pHtmlView = ViewHtmlTemplateFile <$ pKey "HTML" <* pKey "TEMPLATE" <*> pDoubleQuotedString --- ViewSegmentLoad ::= Term | 'TXT' Text -pViewSegmentLoad :: AmpParser (P_ViewSegmtPayLoad TermPrim) +pViewSegmentLoad :: AmpParser (P_ViewSegmtPayLoad TermPrim) pViewSegmentLoad = P_ViewExp <$> pTerm <|> P_ViewText <$ pKey "TXT" <*> asText pDoubleQuotedString - + --- ViewSegment ::= Label ViewSegmentLoad pViewSegment :: Bool -> AmpParser (P_ViewSegment TermPrim) pViewSegment labelIsOptional @@ -442,11 +452,11 @@ pViewDefLegacy = P_Vd <$> currPos --- Interface ::= 'INTERFACE' ADLid Params? Roles? ':' Term (ADLid | Conid)? SubInterface? pInterface :: AmpParser P_Interface -pInterface = lbl <$> currPos +pInterface = lbl <$> currPos <*> pInterfaceIsAPI <*> pADLid <*> pMaybe pParams - <*> pMaybe pRoles + <*> pMaybe pRoles <*> (pColon *> pTerm) -- the expression of the interface object <*> pMaybe pCruds -- The Crud-string (will later be tested, that it can contain only characters crud (upper/lower case) <*> pMaybe (pChevrons $ asText pConid) -- The view that should be used for this object @@ -474,29 +484,29 @@ pInterface = lbl <$> currPos --- SubInterface ::= 'BOX' BoxHeader? Box | 'LINKTO'? 'INTERFACE' ADLid pSubInterface :: AmpParser P_SubInterface pSubInterface = P_Box <$> currPos <*> pBoxHeader <*> pBox - <|> P_InterfaceRef <$> currPos - <*> pIsThere (pKey "LINKTO") <* pInterfaceKey + <|> P_InterfaceRef <$> currPos + <*> pIsThere (pKey "LINKTO") <* pInterfaceKey <*> pADLid where pBoxHeader :: AmpParser BoxHeader - pBoxHeader = + pBoxHeader = build <$> currPos <* pKey "BOX" <*> optional pBoxSpecification build :: Origin -> Maybe (Text, [TemplateKeyValue]) -> BoxHeader build o x = BoxHeader o typ keys - where (typ,keys) = case x of - Nothing -> ("FORM",[]) - Just (boxtype, atts) -> (boxtype,atts) + where (typ,keys) = case x of + Nothing -> ("FORM",[]) + Just (boxtype, atts) -> (boxtype,atts) pBoxSpecification :: AmpParser (Text, [TemplateKeyValue]) pBoxSpecification = pChevrons $ (,) <$> asText (pVarid <|> pConid <|> anyKeyWord) <*> many pTemplateKeyValue - + anyKeyWord :: AmpParser String anyKeyWord = case map pKey keywords of [] -> fatal "We should have keywords. We always have." h:tl -> foldr (<|>) h tl pTemplateKeyValue :: AmpParser TemplateKeyValue - pTemplateKeyValue = - TemplateKeyValue + pTemplateKeyValue = + TemplateKeyValue <$> currPos <*> asText (pVarid <|> pConid <|> anyKeyWord) <*> optional (id <$ pOperator "=" <*> asText pDoubleQuotedString) @@ -506,13 +516,13 @@ pSubInterface = P_Box <$> currPos <*> pBoxHeader <*> pBox pObjDef :: AmpParser P_BoxItemTermPrim pObjDef = pBoxItem <$> currPos <*> pLabel - <*> (pObj <|> pTxt) + <*> (pObj <|> pTxt) where --build p lable fun = pBoxItem p lable <$> fun pBoxItem :: Origin -> Text -> P_BoxItemTermPrim -> P_BoxItemTermPrim pBoxItem p nm fun = fun{ pos = p , obj_nm = nm} - + pObj :: AmpParser P_BoxItemTermPrim pObj = obj <$> pTerm -- the context expression (for example: I[c]) <*> pMaybe pCruds @@ -529,7 +539,7 @@ pObjDef = pBoxItem <$> currPos pTxt :: AmpParser P_BoxItemTermPrim pTxt = obj <$ pKey "TXT" <*> asText pDoubleQuotedString - where obj txt = + where obj txt = P_BxTxt { obj_nm = fatal "This should have been filled in promptly." , pos = fatal "This should have been filled in promptly." , obj_txt = txt @@ -705,10 +715,10 @@ pRelationRef = PNamedR <$> pNamedRel pfull orig (Just (P_Sign src trg)) = Pfull orig src trg pSingleton :: AmpParser PAtomValue -pSingleton = value2PAtomValue <$> currPos <*> +pSingleton = value2PAtomValue <$> currPos <*> ( pAtomValInPopulation True <|> pBraces (pAtomValInPopulation False) - ) + ) pAtomValue :: AmpParser PAtomValue pAtomValue = value2PAtomValue <$> currPos <*> pAtomValInPopulation False diff --git a/src/Ampersand/Input/Archi/ArchiAnalyze.hs b/src/Ampersand/Input/Archi/ArchiAnalyze.hs index 00d4ebc983..048ba9a205 100644 --- a/src/Ampersand/Input/Archi/ArchiAnalyze.hs +++ b/src/Ampersand/Input/Archi/ArchiAnalyze.hs @@ -390,13 +390,13 @@ instance MetaArchi ArchiRepo where typeMap _ archiRepo = typeMap Nothing (archFolders archiRepo) grindArchi env archiRepo - = [ translateArchiElem "name" ("ArchiRepo","Text") Nothing (Set.singleton Uni) + = [ translateArchiElem "name" ("ArchiRepo","Text") Nothing (Set.singleton P_Uni) [(archRepoId archiRepo, archRepoName archiRepo)] ] <> - [ translateArchiElem "purpose" ("ArchiRepo","Text") Nothing (Set.singleton Uni) + [ translateArchiElem "purpose" ("ArchiRepo","Text") Nothing (Set.singleton P_Uni) [(archRepoId archiRepo, archPurpVal purp) | purp<-archPurposes archiRepo] | (not.null.archPurposes) archiRepo ] <> - [ translateArchiElem "propOf" ("Property", "ArchiRepo") Nothing (Set.singleton Uni) [(propid, archRepoId archiRepo)] + [ translateArchiElem "propOf" ("Property", "ArchiRepo") Nothing (Set.singleton P_Uni) [(propid, archRepoId archiRepo)] | prop<-archProperties archiRepo, Just propid<-[archPropId prop]] <> concatMap (grindArchi env) (archFolders archiRepo) <> (concatMap (grindArchi env) . archProperties) archiRepo @@ -421,28 +421,28 @@ instance MetaArchi ArchiObj where = Map.fromList [(viewId diagram, "View") | (not.T.null.viewName) diagram] <> typeMap (Just (viewName diagram)) (viewProps diagram) grindArchi env@(_,_,maybeViewname) element@Element{} - = [ translateArchiElem "name" (elemType element,"Text") maybeViewname (Set.singleton Uni) [(elemId element, elemName element)] + = [ translateArchiElem "name" (elemType element,"Text") maybeViewname (Set.singleton P_Uni) [(elemId element, elemName element)] | (not . T.null . elemName) element] <> - [ translateArchiElem "docu" (elemType element,"Text") maybeViewname (Set.singleton Uni) [(elemId element, elemDocu element)] -- documentation in the XML-tag + [ translateArchiElem "docu" (elemType element,"Text") maybeViewname (Set.singleton P_Uni) [(elemId element, elemDocu element)] -- documentation in the XML-tag | (not . T.null . elemDocu) element] <> - [ translateArchiElem "docu" (elemType element,"Text") maybeViewname (Set.singleton Uni) [(elemId element, archDocuVal eldo)] -- documentation with tags. + [ translateArchiElem "docu" (elemType element,"Text") maybeViewname (Set.singleton P_Uni) [(elemId element, archDocuVal eldo)] -- documentation with tags. | eldo<-elemDocus element] <> - [ translateArchiElem "propOf" ("Property", "ArchiObject") maybeViewname (Set.singleton Uni) [(propid, elemId element)] + [ translateArchiElem "propOf" ("Property", "ArchiObject") maybeViewname (Set.singleton P_Uni) [(propid, elemId element)] | prop<-elemProps element, Just propid<-[archPropId prop]] <> (concatMap (grindArchi env).elemProps) element grindArchi env@(_,typeLookup,maybeViewname) relation@Relationship{} = [ translateArchiElem relLabel (xType,yType) maybeViewname Set.empty [(relSrc relation,relTgt relation)]] <> - [ translateArchiElem "name" ("Relationship","Text") maybeViewname (Set.singleton Uni) [(relId relation, relLabel)]] <> - [ translateArchiElem "type" ("Relationship","Text") maybeViewname (Set.singleton Uni) [(relId relation, relTyp)]] <> - [ translateArchiElem "source" ("Relationship",xType) maybeViewname (Set.singleton Uni) [(relId relation, relSrc relation)]] <> - [ translateArchiElem "target" ("Relationship",yType) maybeViewname (Set.singleton Uni) [(relId relation, relTgt relation)]] <> - [ translateArchiElem "docu" ("Relationship","Text") maybeViewname (Set.singleton Uni) [(relId relation, relDocu relation)] -- documentation in the XML-tag + [ translateArchiElem "name" ("Relationship","Text") maybeViewname (Set.singleton P_Uni) [(relId relation, relLabel)]] <> + [ translateArchiElem "type" ("Relationship","Text") maybeViewname (Set.singleton P_Uni) [(relId relation, relTyp)]] <> + [ translateArchiElem "source" ("Relationship",xType) maybeViewname (Set.singleton P_Uni) [(relId relation, relSrc relation)]] <> + [ translateArchiElem "target" ("Relationship",yType) maybeViewname (Set.singleton P_Uni) [(relId relation, relTgt relation)]] <> + [ translateArchiElem "docu" ("Relationship","Text") maybeViewname (Set.singleton P_Uni) [(relId relation, relDocu relation)] -- documentation in the XML-tag | (not . T.null . relDocu) relation] <> - [ translateArchiElem "docu" ("Relationship","Text") maybeViewname (Set.singleton Uni) [(relId relation, archDocuVal reldo)] -- documentation with tags. + [ translateArchiElem "docu" ("Relationship","Text") maybeViewname (Set.singleton P_Uni) [(relId relation, archDocuVal reldo)] -- documentation with tags. | reldo<-relDocus relation] <> - [ translateArchiElem "accessType" ("Relationship","AccessType") maybeViewname (Set.singleton Uni) [(relId relation, relAccTp relation)] + [ translateArchiElem "accessType" ("Relationship","AccessType") maybeViewname (Set.singleton P_Uni) [(relId relation, relAccTp relation)] | (not . T.null . relAccTp) relation] <> - [ translateArchiElem "propOf" ("Property", "Relationship") maybeViewname (Set.singleton Uni) [(propid, relId relation)] + [ translateArchiElem "propOf" ("Property", "Relationship") maybeViewname (Set.singleton P_Uni) [(propid, relId relation)] | prop<-relProps relation, Just propid<-[archPropId prop]] <> (concatMap (grindArchi env).relProps) relation where @@ -460,17 +460,17 @@ instance MetaArchi ArchiObj where Just str -> str Nothing -> fatal ("No Archi-object found for Archi-identifier "<>tshow (relTgt relation)) grindArchi (_, typeLookup,_) diagram@View{} - = [ translateArchiElem "name" ("View","Text") maybeViewName (Set.singleton Uni) [(viewId diagram, viewName diagram)] + = [ translateArchiElem "name" ("View","Text") maybeViewName (Set.singleton P_Uni) [(viewId diagram, viewName diagram)] | (not . T.null . viewName) diagram] <> - [ translateArchiElem "propOf" ("Property", "View") maybeViewName (Set.singleton Uni) [(propid, viewId diagram)] + [ translateArchiElem "propOf" ("Property", "View") maybeViewName (Set.singleton P_Uni) [(propid, viewId diagram)] | prop<-viewProps diagram, Just propid<-[archPropId prop]] <> - [ translateArchiElem "docu" ("View","Text") maybeViewName (Set.singleton Uni) [(viewId diagram, viewDocu diagram)] -- documentation in the XML-tag + [ translateArchiElem "docu" ("View","Text") maybeViewName (Set.singleton P_Uni) [(viewId diagram, viewDocu diagram)] -- documentation in the XML-tag | (not . T.null . viewDocu) diagram] <> - [ translateArchiElem "docu" ("View","Text") maybeViewName (Set.singleton Uni) [(viewId diagram, archDocuVal viewdoc)] -- documentation with tags. + [ translateArchiElem "docu" ("View","Text") maybeViewName (Set.singleton P_Uni) [(viewId diagram, archDocuVal viewdoc)] -- documentation with tags. | viewdoc<-viewDocus diagram] <> [ translateArchiElem "inView" (chldType,"View") maybeViewName Set.empty [(chldElem viewelem, viewId diagram)] -- register the views in which an element is used. | viewelem<-viewChilds diagram, Just chldType<-[typeLookup (chldElem viewelem)]] <> - [ translateArchiElem "viewpoint" ("View","ViewPoint") maybeViewName (Set.singleton Uni) [(viewId diagram, viewPoint diagram)] -- documentation with tags. + [ translateArchiElem "viewpoint" ("View","ViewPoint") maybeViewName (Set.singleton P_Uni) [(viewId diagram, viewPoint diagram)] -- documentation with tags. | (not . T.null . viewPoint) diagram] <> (concatMap (grindArchi (Nothing,typeLookup,maybeViewName)) . viewProps) diagram <> (concatMap (grindArchi (Just (viewId diagram),typeLookup,maybeViewName)) . viewChilds) diagram @@ -493,10 +493,10 @@ instance MetaArchi ArchiProp where typeMap _ property = Map.fromList [ (propid, "Property") | Just propid<-[archPropId property] ] grindArchi (_,_,maybeViewname) property - = [ translateArchiElem "key" ("Property","Text") maybeViewname (Set.singleton Uni) + = [ translateArchiElem "key" ("Property","Text") maybeViewname (Set.singleton P_Uni) [(propid, archPropKey property) | (not . T.null . archPropKey) property, Just propid<-[archPropId property] ] - , translateArchiElem "value" ("Property","Text") maybeViewname (Set.singleton Uni) + , translateArchiElem "value" ("Property","Text") maybeViewname (Set.singleton P_Uni) [(propid, archPropVal property) | (not . T.null . archPropVal) property, Just propid<-[archPropId property] ] ] @@ -508,7 +508,7 @@ instance MetaArchi a => MetaArchi [a] where -- | The function `translateArchiElem` does the actual compilation of data objects from archiRepo into the Ampersand structure. -- It looks redundant to produce both a `P_Population` and a `P_Relation`, but the first contains the population and the second is used to -- include the metamodel of ArchiMate in the population. This saves the author the effort of maintaining an ArchiMate-metamodel. -translateArchiElem :: Text -> (Text, Text) -> Maybe Text -> Set.Set Prop-> [(Text, Text)] +translateArchiElem :: Text -> (Text, Text) -> Maybe Text -> Set.Set PProp-> [(Text, Text)] -> (P_Population,P_Relation,Maybe Text,PPurpose) translateArchiElem label (srcLabel,tgtLabel) maybeViewName props tuples = ( P_RelPopu Nothing Nothing OriginUnknown ref_to_relation (transTuples tuples) diff --git a/src/Ampersand/Input/Xslx/XLSX.hs b/src/Ampersand/Input/Xslx/XLSX.hs index 8205550b0c..5a90b32172 100644 --- a/src/Ampersand/Input/Xslx/XLSX.hs +++ b/src/Ampersand/Input/Xslx/XLSX.hs @@ -116,7 +116,7 @@ addRelations pCtx = enrichedContext = L.unzip [ ( headrel{ dec_sign = P_Sign g (targt (NE.head sRel)) , dec_prps = let test prop = prop `elem` foldr Set.intersection Set.empty (fmap dec_prps sRel) - in Set.fromList ([Uni |test Uni]<>[Tot |test Tot]<>[Inj |test Inj]<>[Sur |test Sur]) + in Set.fromList $ filter (not . test) [P_Uni,P_Tot Nothing,P_Inj,P_Sur Nothing] } -- the generic relation that summarizes sRel -- , [ rel| rel<-sRel, sourc rel `elem` specs ] -- the specific (and therefore obsolete) relations , [ rel| rel<-NE.toList sRel, sourc rel `notElem` specs ] -- the remaining relations diff --git a/src/Ampersand/Output/ToJSON/Relations.hs b/src/Ampersand/Output/ToJSON/Relations.hs index d09d688825..3dea82d01d 100644 --- a/src/Ampersand/Output/ToJSON/Relations.hs +++ b/src/Ampersand/Output/ToJSON/Relations.hs @@ -7,6 +7,7 @@ where import Ampersand.ADL1 import Ampersand.FSpec.FSpecAux import Ampersand.Output.ToJSON.JSONutils +import qualified RIO.List as L import qualified RIO.Set as Set newtype Relationz = Relationz [RelationJson]deriving (Generic, Show) @@ -22,6 +23,8 @@ data RelationJson = RelationJson , relJSONprop :: Bool , relJSONaffectedConjuncts :: [Text] , relJSONmysqlTable :: RelTableInfo + , relJSONdefaultSrc :: Maybe Text + , relJSONdefaultTgt :: Maybe Text } deriving (Generic, Show) data RelTableInfo = RelTableInfo -- Contains info about where the relation is implemented in SQL { rtiJSONname :: Text @@ -57,9 +60,26 @@ instance JSON Relation RelationJson where , relJSONprop = isProp bindedExp , relJSONaffectedConjuncts = maybe [] (map rc_id) . lookup dcl . allConjsPerDecl $ fSpec , relJSONmysqlTable = fromAmpersand env fSpec dcl + , relJSONdefaultSrc = case L.nub [p | p@Sur {} <- Set.toList $ properties dcl] of + [] -> Nothing + [Sur Nothing] -> Nothing + [Sur (Just d)] -> Just $ toText d + [_] -> fatal "Nothing else than `Sur` is expected here!" + ps -> fatal $ "Multiple instances of Sur should have been prevented by the typechecker\n" + <>" "<>tshow ps + , relJSONdefaultTgt = case L.nub [p | p@Tot {} <- Set.toList $ properties dcl] of + [] -> Nothing + [Tot Nothing] -> Nothing + [Tot (Just d)] -> Just $ toText d + [_] -> fatal "Nothing else than `Tot` is expected here!" + ps -> fatal $ "Multiple instances of Tot should have been prevented by the typechecker\n" + <>" "<>tshow ps } where bindedExp = EDcD dcl - + toText :: APropDefault -> Text + toText d = case d of + ADefAtom aav -> tshow aav + ADefEvalPHP txt -> "{php}"<>txt instance JSON Relation RelTableInfo where fromAmpersand env fSpec dcl = RelTableInfo { rtiJSONname = name plug diff --git a/src/Ampersand/Prototype/PHP.hs b/src/Ampersand/Prototype/PHP.hs index c2fe88cd11..c162902967 100644 --- a/src/Ampersand/Prototype/PHP.hs +++ b/src/Ampersand/Prototype/PHP.hs @@ -243,7 +243,7 @@ createTempDatabase fSpec = do "DROP DATABASE "<>singleQuote (tempDbName fSpec) createDB :: SqlQuery createDB = SqlQuerySimple $ - "CREATE DATABASE "<>singleQuote (tempDbName fSpec)<>" DEFAULT CHARACTER SET UTF8 COLLATE utf8_bin" + "CREATE DATABASE "<>singleQuote (tempDbName fSpec)<>" DEFAULT CHARACTER SET UTF8MB4 COLLATE UTF8MB4_NOPAD_BIN" populatePlugPHP plug = case tableContents fSpec plug of [] -> [] diff --git a/src/Ampersand/Prototype/TableSpec.hs b/src/Ampersand/Prototype/TableSpec.hs index 00724ed8c4..45f4cc0dba 100644 --- a/src/Ampersand/Prototype/TableSpec.hs +++ b/src/Ampersand/Prototype/TableSpec.hs @@ -94,7 +94,7 @@ createTableSql withComment tSpec endings :: [Text] endings = [ ", " <> doubleQuote "ts_insertupdate"<>" TIMESTAMP ON UPDATE CURRENT_TIMESTAMP NULL DEFAULT CURRENT_TIMESTAMP"]<> - [ ") ENGINE = InnoDB DEFAULT CHARACTER SET UTF8 COLLATE UTF8_BIN" ]<> + [ ") ENGINE = InnoDB DEFAULT CHARACTER SET UTF8MB4 COLLATE UTF8MB4_NOPAD_BIN" ]<> [ ", ROW_FORMAT = DYNAMIC"] wrap :: [Text] -> [Text] wrap = map (\col -> T.replicate indnt " " <> col) diff --git a/src/Ampersand/Test/Parser/ArbitraryTree.hs b/src/Ampersand/Test/Parser/ArbitraryTree.hs index 715c8512e6..0b285f0baa 100644 --- a/src/Ampersand/Test/Parser/ArbitraryTree.hs +++ b/src/Ampersand/Test/Parser/ArbitraryTree.hs @@ -5,7 +5,7 @@ module Ampersand.Test.Parser.ArbitraryTree () where import Ampersand.Basics import Ampersand.Core.ParseTree -import Ampersand.Input.ADL1.Lexer ( keywords, isSafeIdChar ) +import Ampersand.Input.ADL1.Lexer ( keywords, isSafeIdChar ) import RIO.Char import qualified RIO.List as L import qualified RIO.NonEmpty as NE @@ -46,7 +46,7 @@ identifier = (T.cons <$> firstChar <*> (T.pack <$> listOf restChar)) firstChar :: Gen Char firstChar = arbitrary `suchThat` isAscii `suchThat` isSafeIdChar True restChar :: Gen Char - restChar = arbitrary `suchThat` isAscii `suchThat` isSafeIdChar False + restChar = arbitrary `suchThat` isAscii `suchThat` isSafeIdChar False noKeyword :: Text -> Bool @@ -87,21 +87,21 @@ makeObj isTxtAllowed genPrim ifcGen genView n = where term = Prim <$> genPrim ifc = if n == 0 then pure Nothing else Just <$> ifcGen (n`div`2) - + genIfc :: Arbitrary a => Int -> Gen (P_SubIfc a) genIfc = subIfc $ makeObj True arbitrary genIfc (pure Nothing) subIfc :: (Int -> Gen (P_BoxItem a)) -> Int -> Gen (P_SubIfc a) -subIfc objGen n +subIfc objGen n | n == 0 = P_InterfaceRef <$> arbitrary <*> arbitrary <*> identifier | otherwise = P_Box <$> arbitrary <*> arbitrary <*> vectorOf n (objGen$ n`div`2) instance Arbitrary BoxHeader where arbitrary = BoxHeader <$> arbitrary <*> pure "BOX" <*> listOf arbitrary - + instance Arbitrary TemplateKeyValue where - arbitrary = TemplateKeyValue - <$> arbitrary + arbitrary = TemplateKeyValue + <$> arbitrary <*> identifier `suchThat` startsWithLetter <*> liftArbitrary safeStr1 where startsWithLetter :: Text -> Bool @@ -134,7 +134,7 @@ instance Arbitrary P_RoleRule where arbitrary = Maintain <$> arbitrary <*> arbitrary <*> listOf1 identifier instance Arbitrary Representation where - arbitrary = Repr <$> arbitrary + arbitrary = Repr <$> arbitrary <*> arbitrary `suchThat` noOne <*> arbitrary @@ -153,7 +153,7 @@ instance Arbitrary P_Pattern where <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary instance Arbitrary P_Relation where - arbitrary = P_Relation + arbitrary = P_Relation <$> lowerId <*> arbitrary <*> arbitrary @@ -203,7 +203,7 @@ genTerm lv n = if n == 0 Prim <$> arbitrary]] instance Arbitrary TermPrim where - arbitrary = oneof + arbitrary = oneof [ PI <$> arbitrary , Pid <$> arbitrary <*> arbitrary , Patm <$> arbitrary <*> arbitrary <*> arbitrary @@ -214,9 +214,9 @@ instance Arbitrary TermPrim where instance Arbitrary a => Arbitrary (PairView (Term a)) where arbitrary = PairView <$> arbitrary - + instance Arbitrary a => Arbitrary (PairViewSegment (Term a)) where - arbitrary = oneof + arbitrary = oneof [ PairViewText <$> arbitrary <*> safeStr , PairViewExp <$> arbitrary <*> arbitrary <*> sized(genTerm 1) -- only accepts pTerm, no pRule. ] @@ -231,7 +231,7 @@ instance Arbitrary SrcOrTgt where arbitrary = elements [minBound..] instance Arbitrary a => Arbitrary (P_Rule a) where - arbitrary = P_Rule + arbitrary = P_Rule <$> arbitrary <*> identifier <*> sized (genTerm 0) -- rule is a term level 0 @@ -240,32 +240,32 @@ instance Arbitrary a => Arbitrary (P_Rule a) where <*> arbitrary instance Arbitrary (P_Enforce TermPrim) where - arbitrary = P_Enforce <$> arbitrary + arbitrary = P_Enforce <$> arbitrary <*> arbitrary `suchThat` isNamedRelation <*> arbitrary <*> arbitrary `suchThat` (not . isForRulesOnly) - where isForRulesOnly :: Term TermPrim -> Bool + where isForRulesOnly :: Term TermPrim -> Bool isForRulesOnly PEqu{} = True isForRulesOnly PInc{} = True isForRulesOnly _ = False isNamedRelation :: TermPrim -> Bool - isNamedRelation PNamedR{} = True + isNamedRelation PNamedR{} = True isNamedRelation _ = False instance Arbitrary EnforceOperator where - arbitrary = oneof + arbitrary = oneof [ IsSuperSet <$> arbitrary , IsSubSet <$> arbitrary , IsSameSet <$> arbitrary ] - + instance Arbitrary PConceptDef where arbitrary = PConceptDef <$> arbitrary <*> identifier <*> arbitrary <*> arbitrary <*> identifier instance Arbitrary PCDDef where - arbitrary = oneof + arbitrary = oneof [ PCDDefLegacy <$> safeStr <*> safeStr , PCDDefNew <$> arbitrary ] @@ -273,14 +273,14 @@ instance Arbitrary PAtomPair where arbitrary = PPair <$> arbitrary <*> arbitrary <*> arbitrary instance Arbitrary P_Population where - arbitrary = oneof - [ P_RelPopu + arbitrary = oneof + [ P_RelPopu <$> arbitrary `suchThat` noOne <*> arbitrary `suchThat` noOne <*> arbitrary <*> arbitrary <*> arbitrary - , P_CptPopu + , P_CptPopu <$> arbitrary <*> arbitrary `suchThat` notIsOne <*> arbitrary @@ -316,7 +316,7 @@ instance Arbitrary a => Arbitrary (P_SubIfc a) where arbitrary = sized genIfc instance Arbitrary P_IdentDef where - arbitrary = P_Id <$> arbitrary + arbitrary = P_Id <$> arbitrary <*> identifier <*> arbitrary `suchThat` notIsOne <*> arbitrary @@ -332,7 +332,7 @@ instance Arbitrary ViewHtmlTemplate where arbitrary = ViewHtmlTemplateFile <$> safeFilePath instance Arbitrary a => Arbitrary (P_ViewSegment a) where - arbitrary = P_ViewSegment <$> (Just <$> identifier) <*> arbitrary <*> arbitrary + arbitrary = P_ViewSegment <$> (Just <$> identifier) <*> arbitrary <*> arbitrary instance Arbitrary a => Arbitrary (P_ViewSegmtPayLoad a) where arbitrary = oneof [ P_ViewExp <$> sized(genTerm 1) -- only accepts pTerm, no pRule. @@ -362,7 +362,7 @@ instance Arbitrary PMessage where arbitrary = PMessage <$> arbitrary instance Arbitrary P_Concept where - arbitrary = frequency + arbitrary = frequency [ (100, PCpt <$> upperId) , ( 1, pure P_ONE) ] @@ -371,28 +371,36 @@ instance Arbitrary P_Sign where arbitrary = P_Sign <$> arbitrary <*> arbitrary instance Arbitrary PClassify where - arbitrary = PClassify - <$> arbitrary + arbitrary = PClassify + <$> arbitrary <*> arbitrary `suchThat` notIsOne <*> arbitrary `suchThat` noOne - + instance Arbitrary Lang where arbitrary = elements [minBound..] instance Arbitrary P_Markup where arbitrary = P_Markup <$> arbitrary <*> arbitrary <*> safeStr `suchThat` noEndMarkup - where + where noEndMarkup :: Text -> Bool noEndMarkup = not . T.isInfixOf "+}" instance Arbitrary PandocFormat where arbitrary = elements [minBound..] -instance Arbitrary Prop where - arbitrary = elements [minBound..] - +instance Arbitrary PProp where + arbitrary = oneof [ elements [ P_Uni, P_Inj + , P_Sym, P_Asy, P_Trn, P_Rfx, P_Irf, P_Prop + ] + , P_Tot <$> arbitrary + , P_Sur <$> arbitrary + ] +instance Arbitrary PPropDefault where + arbitrary = oneof [ PDefAtom <$> arbitrary + , PDefEvalPHP <$> safeStr + ] noOne :: Foldable t => t P_Concept -> Bool noOne = all notIsOne notIsOne :: P_Concept -> Bool -notIsOne = (P_ONE /= ) +notIsOne = (P_ONE /= ) diff --git a/testing/Sentinel/Tests/ShouldSucceed/Issue335.adl b/testing/Sentinel/Tests/ShouldFail/Issue335.adl similarity index 100% rename from testing/Sentinel/Tests/ShouldSucceed/Issue335.adl rename to testing/Sentinel/Tests/ShouldFail/Issue335.adl diff --git a/testing/Sentinel/Tests/ShouldSucceed/Issue406.adl b/testing/Sentinel/Tests/ShouldFail/Issue406.adl similarity index 100% rename from testing/Sentinel/Tests/ShouldSucceed/Issue406.adl rename to testing/Sentinel/Tests/ShouldFail/Issue406.adl diff --git a/testing/Sentinel/Tests/ShouldSucceed/ViewAnnotationCheck.adl b/testing/Sentinel/Tests/ShouldFail/OnlyProto/ViewAnnotationCheck.adl similarity index 100% rename from testing/Sentinel/Tests/ShouldSucceed/ViewAnnotationCheck.adl rename to testing/Sentinel/Tests/ShouldFail/OnlyProto/ViewAnnotationCheck.adl diff --git a/testing/Sentinel/Tests/ShouldFail/OnlyProto/testinfo.yaml b/testing/Sentinel/Tests/ShouldFail/OnlyProto/testinfo.yaml new file mode 100644 index 0000000000..42edb8f986 --- /dev/null +++ b/testing/Sentinel/Tests/ShouldFail/OnlyProto/testinfo.yaml @@ -0,0 +1,3 @@ +testCmds: + - command: ampersand proto --verbose + exitcode: 130 diff --git a/testing/Sentinel/Tests/ShouldFail/testinfo.yaml b/testing/Sentinel/Tests/ShouldFail/testinfo.yaml new file mode 100644 index 0000000000..52c4541b64 --- /dev/null +++ b/testing/Sentinel/Tests/ShouldFail/testinfo.yaml @@ -0,0 +1,5 @@ +testCmds: + - command: ampersand validate --verbose + exitcode: 10 + - command: ampersand proto --verbose + exitcode: 10 diff --git a/testing/Sentinel/Tests/ShouldSucceed/OnlyValidation/ViewAnnotationCheck.adl b/testing/Sentinel/Tests/ShouldSucceed/OnlyValidation/ViewAnnotationCheck.adl new file mode 100644 index 0000000000..650435eaa2 --- /dev/null +++ b/testing/Sentinel/Tests/ShouldSucceed/OnlyValidation/ViewAnnotationCheck.adl @@ -0,0 +1,42 @@ +CONTEXT ViewAnnotationCheck IN ENGLISH +{- Test view annotation typechecking for generalizations, failing cases are in ShouldFail/ViewAnnotationCheck.adl -} + +CLASSIFY Lime ISA Citrus +CLASSIFY Orange ISA Citrus +CLASSIFY Limorange IS Lime /\ Orange + +INTERFACE Overview : I[SESSION] +BOX [ "Citrus as Citrus" : V[SESSION*Citrus] + --, "Citrus as Orange" : V[SESSION*Citrus] -- should fail + --, "Citrus as Lime" : V[SESSION*Citrus] -- should fail + --, "Citrus as Limorange" : V[SESSION*Citrus] -- should fail + , "Lime as Citrus" : V[SESSION*Lime] + --, "Lime as Orange" : V[SESSION*Lime] -- should fail + , "Lime as Lime" : V[SESSION*Lime] + --, "Lime as Limorange" : V[SESSION*Lime] -- should fail + , "Orange as Citrus" : V[SESSION*Orange] + , "Orange as Orange" : V[SESSION*Orange] + --, "Orange as Lime" : V[SESSION*Orange] -- should fail + --, "Orange as Limorange" : V[SESSION*Orange] -- should fail + , "Limorange as Citrus" : V[SESSION*Limorange] + , "Limorange as Orange" : V[SESSION*Limorange] + , "Limorange as Lime" : V[SESSION*Limorange] + , "Limorange as Limorange" : V[SESSION*Limorange] + ] +VIEW CitrusView: Citrus DEFAULT { value: I } +HTML TEMPLATE "NonexistentDummy.html" +ENDVIEW + +VIEW LimeView: Lime DEFAULT { value: I } +HTML TEMPLATE "NonexistentDummy.html" +ENDVIEW + +VIEW OrangeView: Orange DEFAULT { value: I } +HTML TEMPLATE "NonexistentDummy.html" +ENDVIEW + +VIEW LimorangeView: Limorange DEFAULT { value: I } +HTML TEMPLATE "NonexistentDummy.html" +ENDVIEW + +ENDCONTEXT diff --git a/testing/Sentinel/Tests/ShouldSucceed/OnlyValidation/testinfo.yaml b/testing/Sentinel/Tests/ShouldSucceed/OnlyValidation/testinfo.yaml new file mode 100644 index 0000000000..d5e82ba3e3 --- /dev/null +++ b/testing/Sentinel/Tests/ShouldSucceed/OnlyValidation/testinfo.yaml @@ -0,0 +1,3 @@ +testCmds: + - command: ampersand validate --verbose + exitcode: 0 diff --git a/testing/Sentinel/Tests/ShouldSucceed/testinfo.yaml b/testing/Sentinel/Tests/ShouldSucceed/testinfo.yaml new file mode 100644 index 0000000000..4564a66ea7 --- /dev/null +++ b/testing/Sentinel/Tests/ShouldSucceed/testinfo.yaml @@ -0,0 +1,5 @@ +testCmds: + - command: ampersand validate --verbose + exitcode: 0 + - command: ampersand proto --verbose + exitcode: 0 diff --git a/testing/Sentinel/Tests/ShouldSucceed/Bug335_Kl0Kl1.adl b/testing/StillUnsupported/Bug335_Kl0Kl1.adl similarity index 100% rename from testing/Sentinel/Tests/ShouldSucceed/Bug335_Kl0Kl1.adl rename to testing/StillUnsupported/Bug335_Kl0Kl1.adl diff --git a/testing/Sentinel/Tests/ShouldSucceed/Issue166.adl b/testing/StillUnsupported/Issue166.adl similarity index 100% rename from testing/Sentinel/Tests/ShouldSucceed/Issue166.adl rename to testing/StillUnsupported/Issue166.adl diff --git a/testing/Sentinel/Tests/ShouldSucceed/Issue166_2.adl b/testing/StillUnsupported/Issue166_2.adl similarity index 100% rename from testing/Sentinel/Tests/ShouldSucceed/Issue166_2.adl rename to testing/StillUnsupported/Issue166_2.adl