diff --git a/.ampersand b/.ampersand new file mode 100644 index 0000000000..ad8bb9fb10 --- /dev/null +++ b/.ampersand @@ -0,0 +1,2 @@ +AmpersandData/FormalAmpersand/AST.adl +AmpersandData/PrototypeContext/PrototypeContext.adl \ No newline at end of file diff --git a/.devcontainer/devcontainer.json b/.devcontainer/devcontainer.json index ced5306494..edbb46321f 100644 --- a/.devcontainer/devcontainer.json +++ b/.devcontainer/devcontainer.json @@ -7,8 +7,27 @@ // Use 'settings' to set *default* container specific settings.json values on container create. // You can edit these settings after create using File > Preferences > Settings > Remote. "settings": { - "terminal.integrated.shell.linux": "/bin/bash" - + "terminal.integrated.defaultProfile.linux":"bash", + "terminal.integrated.profiles.linux":{ + "bash": { + "path": "bash", + "icon": "terminal-bash" + }, + "zsh": { + "path": "zsh", + }, + "fish": { + "path": "fish" + }, + "tmux": { + "path": "tmux", + "icon": "terminal-tmux" + }, + "pwsh": { + "path": "pwsh", + "icon": "terminal-powershell" + } + } }, // Use 'appPort' to create a container with published ports. If the port isn't working, be sure diff --git a/AmpersandData/FormalAmpersand/AST.adl b/AmpersandData/FormalAmpersand/AST.adl index d8d8196c42..0c5481b2de 100644 --- a/AmpersandData/FormalAmpersand/AST.adl +++ b/AmpersandData/FormalAmpersand/AST.adl @@ -1,59 +1,17 @@ CONTEXT Ampersand IN ENGLISH --! 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 !-- INCLUDE "Concepts.adl" ---INCLUDE "AST.ifc" ---INCLUDE "MinimalAST.xlsx" -- Contains minimal population. Anything discarded from it must violate an invariant +-- INCLUDE "Conjuncts.adl" INCLUDE "Contexts.adl" -INCLUDE "Relations.adl" INCLUDE "Documentation.adl" -INCLUDE "Rules.adl" -INCLUDE "Expressions.adl" -INCLUDE "Views.adl" INCLUDE "Generics.adl" INCLUDE "Interfaces.adl" +--INCLUDE "MinimalAST.xlsx" -- Contains minimal population. Anything discarded from it must violate an invariant +INCLUDE "Relations.adl" +INCLUDE "Rules.adl" -- INCLUDE "Tables.adl" - -{- *** De volgende relaties zijn hier tijdelijk opgenomen - *** om te voorkomen dat Travis gaat piepen. Deze relaties ontbreken elders - *** in de FormalAmpersand scripts, maar worden door de - *** meatgrinder wél gevuld. --} -RELATION interfaces[Context*Interface] -RELATION name[Role*RoleName] -REPRESENT RoleName TYPE ALPHANUMERIC -RELATION markup[Meaning*Markup][UNI,TOT] -RELATION markup[Purpose*Markup][UNI,TOT] -RELATION asMarkdown[Markup*Text][UNI,TOT] -RELATION language[Markup*Language][UNI,TOT] -REPRESENT Language TYPE ALPHANUMERIC -REPRESENT Text TYPE BIGALPHANUMERIC -RELATION urlEncodedName[Concept*EncodedName] -REPRESENT EncodedName TYPE ALPHANUMERIC -RELATION context[Relation*Context] -RELATION ttype[Concept*TType][UNI] -REPRESENT TType TYPE ALPHANUMERIC -RELATION allRoles[Context*Role] -RELATION relsDefdIn[Pattern*Relation] -RELATION maintains[Role*Rule] -RELATION context[Population*Context] -RELATION gens[Context*IsE] -RELATION urlEncodedName[Pattern*EncodedName] -RELATION interfaces[Role*Interface] -RELATION context[Population*Context] -RELATION language[Context*Language] -REPRESENT Language TYPE ALPHANUMERIC -RELATION message[Rule*Message] -RELATION origin[Rule*Origin] -REPRESENT Origin TYPE ALPHANUMERIC -RELATION versionInfo[Context*AmpersandVersion] -REPRESENT AmpersandVersion TYPE ALPHANUMERIC -RELATION urlEncodedName[Rule*EncodedName] -RELATION context[IdentityDef*Context] - -{- ******************************************** - *** Einde elders neer te zetten relaties *** - ******************************************** --} +INCLUDE "Terms.adl" +--INCLUDE "Views.adl" ENDCONTEXT diff --git a/AmpersandData/FormalAmpersand/AST.docadl b/AmpersandData/FormalAmpersand/AST.docadl index c9cbd1ce5c..fa67f5dd68 100644 --- a/AmpersandData/FormalAmpersand/AST.docadl +++ b/AmpersandData/FormalAmpersand/AST.docadl @@ -3,7 +3,7 @@ CONTEXT RAP IN ENGLISH LATEX Each concept of the RAP metamodel has its own section, where sections are separated by comments -} INCLUDE "AST.adl" INCLUDE "Atoms.docadl" ---INCLUDE "Expressions.docadl" +--INCLUDE "Terms.docadl" INCLUDE "Rules.docadl" -- Context @@ -88,23 +88,23 @@ The problem of identifying which persons have been using an information system c about log-in, users and sessions. +} --- Expression -PATTERN Expressions -PURPOSE PATTERN Expressions -{+The rules that govern expressions are brought together in one pattern, -in order to formalize expressions and determine their meaning. +-- 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 Expression "An expression is a relation algebraic term, denoted in Ampersand syntax" -REPRESENT Expression TYPE ALPHANUMERIC -PURPOSE CONCEPT Expression +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 expressions. -An Ampersand professional uses expressions to calculate with language and to specify information systems and business processes. +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 expression combines relations with operators. +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 expression $(3+5)\times 2$ can be calculated from the constituent numbers. +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 diff --git a/AmpersandData/FormalAmpersand/Atoms.xlsx b/AmpersandData/FormalAmpersand/Atoms.xlsx deleted file mode 100644 index 8d1777327f..0000000000 Binary files a/AmpersandData/FormalAmpersand/Atoms.xlsx and /dev/null differ diff --git a/AmpersandData/FormalAmpersand/AtomsAsShouldBe.adl b/AmpersandData/FormalAmpersand/AtomsAsShouldBe.adl deleted file mode 100644 index bdf2fad1c8..0000000000 --- a/AmpersandData/FormalAmpersand/AtomsAsShouldBe.adl +++ /dev/null @@ -1,121 +0,0 @@ -CONTEXT AST IN ENGLISH -INCLUDE "Atoms.xlsx" - -PATTERN Atoms - RELATION name[Concept*Identifier] [UNI,TOT] - RELATION name[Relation*Identifier] [UNI,TOT] - RELATION source[Relation*Concept] [UNI,TOT] - RELATION target[Relation*Concept] [UNI,TOT] - - REPRESENT Identifier TYPE ALPHANUMERIC - - RULE "Identifiability of concepts": name;name~ |- I[Concept] - VIOLATION (TXT "The name \"", SRC I, TXT "\" is already in use") - - RELATION in[Pair*Relation] [UNI,TOT] - RELATION lAtom[Pair*Atom] [UNI,TOT] - RELATION rAtom[Pair*Atom] [UNI,TOT] -ENDPATTERN - -PATTERN "Compute sources, targets, and populations" - RELATION sources[Relation*Concept] -- meant for: sources = source;isaStar~ - RELATION targets[Relation*Concept] -- meant for: targets = target;isaStar~ - - ROLE ExecEngine MAINTAINS isaRelInsSrc, isaRelInsTgt, isaRelDelSrc, isaRelDelTgt - RULE isaRelInsSrc: source;isaStar~ |- sources - VIOLATION (TXT "{EX} InsPair;sources;Relation;", SRC I, TXT ";Concept;", TGT I) - RULE isaRelInsTgt: target;isaStar~ |- targets - VIOLATION (TXT "{EX} InsPair;targets;Relation;", SRC I, TXT ";Concept;", TGT I) - RULE isaRelDelSrc: sources |- source;isaStar~ - VIOLATION (TXT "{EX} DelPair;sources;Relation;", SRC I, TXT ";Concept;", TGT I) - RULE isaRelDelTgt: targets |- target;isaStar~ - VIOLATION (TXT "{EX} DelPair;targets;Relation;", SRC I, TXT ";Concept;", TGT I) - - RELATION pop[Atom*Concept] - MEANING "If a pop c, we say that atom a is in the population of concept c." - - ROLE ExecEngine MAINTAINS insPop, delPop - RULE insPop : lAtom~;in;source;isaStar \/ rAtom~;in;target;isaStar |- pop - VIOLATION (TXT "{EX} InsPair;pop;Atom;", SRC I, TXT ";Concept;", TGT I) - RULE delPop : pop |- lAtom~;in;source;isaStar \/ rAtom~;in;target;isaStar - VIOLATION (TXT "{EX} DelPair;pop;Atom;", SRC I, TXT ";Concept;", TGT I) -ENDPATTERN - -PATTERN "Compute Closures" - RELATION isa[Concept*Concept] [IRF,ASY] - MEANING "s isa g means that each element of concept s is defined to be an element of concept g as well." - RELATION isaStar[Concept*Concept] -- Transitive, reflexive closure of isa, aka isa* - MEANING "s isa g means that s is g or each element of concept s is an element of concept g as well." - RELATION isaPlus[Concept*Concept] -- Transitive closure of isa, aka isa+ - MEANING "s isa g means that each element of concept s is an element of concept g as well." - - RELATION isaCopy[Concept*Concept] -- necessary only for calling the Transitive closure function. - ROLE ExecEngine MAINTAINS "Compute transitive closure of isa" - RULE "Compute transitive closure of isa" : isa = isaCopy - VIOLATION (TXT "{EX} TransitiveClosure;isa;Concept;isaCopy;isaPlus") - - ROLE ExecEngine MAINTAINS "Compute transitive closure of isa by Ins", "Compute transitive closure of isa by Del" - RULE "Compute transitive closure of isa by Ins" : isaPlus\/I |- isaStar - VIOLATION (TXT "{EX} InsPair;isaStar;Concept;", SRC I, TXT ";Concept;", TGT I) - RULE "Compute transitive closure of isa by Del" : isaStar |- isaPlus\/I - VIOLATION (TXT "{EX} DelPair;isaStar;Concept;", SRC I, TXT ";Concept;", TGT I) -ENDPATTERN - -INTERFACE Overview : "_SESSION"[SESSION] -BOX - [ relations : V[SESSION*Relation] - BOX - [ relation : I[Relation] - , "pair(s)" : in~ - , sources : sources - , targets : targets - ] - , concepts :V[SESSION*Concept] - BOX
- [ name : I[Concept] - , "isa" : isa --- , "isa+" : isaPlus --- , "isa*" : isaStar - , "isa~" : isa~ --- , "isa+~" : isaPlus~ --- , "isa*~" : isaStar~ - , atoms : pop~ - ] - , pairs : V[SESSION*Pair] - BOX
- [ pair : I - , "relation(s)" : in - ] --- , atoms : V[SESSION*Atom] --- BOX
--- [ atom : I --- , type : pop - pop;isaPlus --- , pop : pop --- ] - ] - ---VIEW Atom : Atom(repr) -- When observing an atom, its representation is what you can see. -REPRESENT Atom TYPE ALPHANUMERIC -VIEW Concept : Concept(name) -VIEW Pair : Pair(TXT "(",lAtom,TXT ",",rAtom,TXT ")") -VIEW Relation : Relation(name,TXT "[",source;name,TXT "*",target;name,TXT "]") - -INTERFACE Concept(name[Concept*Identifier],isa) : I[Concept] -BOX [ name : name - , generalizations : isa - , specializations : isa~ - ] - -INTERFACE Pair(lAtom,rAtom,in[Pair*Relation]) : I[Pair] -BOX [ "relation(s)" : in - , lAtom : lAtom - , rAtom : rAtom - ] - -INTERFACE Relation(name[Relation*Identifier],source,target) : I[Relation] -BOX [ name : name - , source : source - , target : target - ] - -ENDCONTEXT \ No newline at end of file diff --git a/AmpersandData/FormalAmpersand/Concepts.adl b/AmpersandData/FormalAmpersand/Concepts.adl index c90d5fee49..d73e47570f 100644 --- a/AmpersandData/FormalAmpersand/Concepts.adl +++ b/AmpersandData/FormalAmpersand/Concepts.adl @@ -1,29 +1,28 @@ CONTEXT AST IN ENGLISH PATTERN Concepts - VIEW Concept: Concept(name) - RELATION name[Concept*ConceptName] [UNI,TOT,SUR] - ROLE ExecEngine MAINTAINS "del unused ConceptName" - RULE "del unused ConceptName" : I[ConceptName] |- name~;name - MEANING "A ConceptName without Concept will be removed." - VIOLATION ( TXT "{EX} DelAtom;ConceptName;", SRC I ) + RELATION name[Concept*ConceptName] [UNI,SUR] + + ROLE ExecEngine MAINTAINS "del unused ConceptName" + RULE "del unused ConceptName" : I[ConceptName] |- name~;name + MEANING "A ConceptName without Concept will be removed." + VIOLATION ( TXT "{EX} DelAtom;ConceptName;", SRC I ) + IDENT Concept : Concept(name,context[Concept*Context]) RELATION name[Relation*RelationName] [UNI,TOT] MEANING "Every relation has a name by which it can be referenced within its Context(s)." RELATION source[Relation*Concept] [UNI,TOT] RELATION target[Relation*Concept] [UNI,TOT] - REPRESENT ConceptName,RelationName TYPE ALPHANUMERIC + REPRESENT Identifier TYPE ALPHANUMERIC + CLASSIFY ConceptName, RelationName ISA Identifier + RELATION context[Concept*Context] [UNI] -- comes from concs, which is defined in FSpec. This contains all concepts declared inside a context but outside the patterns it contains. ENDPATTERN -- RULE "Identifiability of concepts": name[Concept*ConceptName];name[Concept*ConceptName]~ |- I[Concept] PATTERN Specialization --- VIEW Isa: Isa( TXT "CLASSIFY ", genspc;name{-[Concept*ConceptName]-} , TXT " ISA " , gengen;name{-[Concept*ConceptName]-} ) --- RULE "eq gen": gengen;gengen~ /\ genspc;genspc~ |- I --- MEANING "Two generalization rules are identical when the specific concepts are identical and the generic concepts are identical." --- HJO, 20160906: Disabled above rule and view, because a generalisation can currently have more than one generic concepts (CLASSIFY A IS B /\ C ) RELATION gengen[Isa*Concept] [UNI,TOT] MEANING "A generalization rule refers to one or more generic concepts." RELATION genspc[Isa*Concept] [UNI,TOT] @@ -32,15 +31,6 @@ PATTERN Specialization MEANING "A generalization rule refers to one or more generic concepts." RELATION genspc[IsE*Concept] [UNI,TOT] MEANING "A generalization rule refers to one or more specific concepts." - ---PURPOSE RULE specialization ---{+Specialization has the consequence that an atom is not necessarily an instance of one concept only. ---If limes are citrus fruits, then every lime is not only lime but a citrus fruit as well. ---+} ---RELATION instanceOf[Atom*Concept] [TOT] ---RULE specialization : instanceOf;genspc~;gengen |- instanceOf ---MEANING "Every instance of a specialized concept is an instance of the generic concept too." - ENDPATTERN PATTERN "Compute Closures" diff --git a/AmpersandData/FormalAmpersand/Concepts.docadl b/AmpersandData/FormalAmpersand/Concepts.docadl new file mode 100644 index 0000000000..9a9df21c7f --- /dev/null +++ b/AmpersandData/FormalAmpersand/Concepts.docadl @@ -0,0 +1,108 @@ +CONTEXT AST IN ENGLISH + +PATTERN Concepts + VIEW Concept: Concept(name) + RELATION name[Concept*ConceptName] [UNI,TOT,SUR] + ROLE ExecEngine MAINTAINS "del unused ConceptName" + RULE "del unused ConceptName" : I[ConceptName] |- name~;name + MEANING "A ConceptName without Concept will be removed." + VIOLATION ( TXT "{EX} DelAtom;ConceptName;", SRC I ) + + IDENT Concept : Concept(name,context[Concept*Context]) + + RELATION name[Relation*RelationName] [UNI,TOT] + MEANING "Every relation has a name by which it can be referenced within its Context(s)." + RELATION source[Relation*Concept] [UNI,TOT] + RELATION target[Relation*Concept] [UNI,TOT] + + REPRESENT Identifier TYPE ALPHANUMERIC + CLASSIFY ConceptName, RelationName ISA Identifier + RELATION context[Concept*Context] [UNI] -- comes from concs, which is defined in FSpec. This contains all concepts declared inside a context but outside the patterns it contains. +ENDPATTERN + +PATTERN Pairs + RELATION in[Pair*Relation] [UNI,TOT] + RELATION lAtom[Pair*Atom] [UNI,TOT] + RELATION rAtom[Pair*Atom] [UNI,TOT] +ENDPATTERN + +-- RULE "Identifiability of concepts": name[Concept*ConceptName];name[Concept*ConceptName]~ |- I[Concept] + +PATTERN Specialization +-- VIEW Isa: Isa( TXT "CLASSIFY ", genspc;name{-[Concept*ConceptName]-} , TXT " ISA " , gengen;name{-[Concept*ConceptName]-} ) +-- RULE "eq gen": gengen;gengen~ /\ genspc;genspc~ |- I +-- MEANING "Two generalization rules are identical when the specific concepts are identical and the generic concepts are identical." +-- HJO, 20160906: Disabled above rule and view, because a generalisation can currently have more than one generic concepts (CLASSIFY A IS B /\ C ) + RELATION gengen[Isa*Concept] [UNI,TOT] + MEANING "A generalization rule refers to one or more generic concepts." + RELATION genspc[Isa*Concept] [UNI,TOT] + MEANING "A generalization rule refers to one or more specific concepts." + RELATION gengen[IsE*Concept] [TOT] + MEANING "A generalization rule refers to one or more generic concepts." + RELATION genspc[IsE*Concept] [UNI,TOT] + MEANING "A generalization rule refers to one or more specific concepts." + +--PURPOSE RULE specialization +--{+Specialization has the consequence that an atom is not necessarily an instance of one concept only. +--If limes are citrus fruits, then every lime is not only lime but a citrus fruit as well. +--+} +--RELATION instanceOf[Atom*Concept] [TOT] +--RULE specialization : instanceOf;genspc~;gengen |- instanceOf +--MEANING "Every instance of a specialized concept is an instance of the generic concept too." + +ENDPATTERN + +PATTERN "Compute Closures" + RELATION isa[Concept*Concept] [ASY] + MEANING "s isa g means that each element of concept s is defined to be an element of concept g as well." + RELATION isaStar[Concept*Concept] -- Transitive, reflexive closure of isa, aka isa* + MEANING "s isaStar g means that s is g or each element of concept s is an element of concept g as well." + RELATION isaPlus[Concept*Concept] -- Transitive closure of isa, aka isa+ + MEANING "s isaPlus g means that each element of concept s is an element of concept g as well." + + RELATION isaCopy[Concept*Concept] -- necessary only for calling the Transitive closure function. + ROLE ExecEngine MAINTAINS "Compute transitive closure of isa" + RULE "Compute transitive closure of isa" : isa[Concept*Concept] = isaCopy[Concept*Concept] + MEANING "TODO: MEANING ONTBREEKT" + VIOLATION (TXT "{EX} TransitiveClosure;isa[Concept*Concept];Concept;isaCopy[Concept*Concept];isaPlus") + + ROLE ExecEngine MAINTAINS "Compute transitive closure of isa by Ins", "Compute transitive closure of isa by Del" + RULE "Compute transitive closure of isa by Ins" : isaPlus\/I |- isaStar + MEANING "TODO: MEANING ONTBREEKT" + VIOLATION (TXT "{EX} InsPair;isaStar;Concept;", SRC I, TXT ";Concept;", TGT I) + RULE "Compute transitive closure of isa by Del" : isaStar |- isaPlus\/I + MEANING "TODO: MEANING ONTBREEKT" + VIOLATION (TXT "{EX} DelPair;isaStar;Concept;", SRC I, TXT ";Concept;", TGT I) +ENDPATTERN + +PATTERN "Reflexive isa closures" + RELATION isaRfxStar[Concept*Concept] -- Transitive, reflexive closure of isa[Concept*Concept]\/isa[Concept*Concept]~ + MEANING "s isaRfxStar g means that s is g or each element of concept s is an element of concept g or vice-versa." + RELATION isaRfxPlus[Concept*Concept] -- Transitive closure of isa[Concept*Concept]\/isa[Concept*Concept]~ + MEANING "s isaRfxPlus g means that each element of concept s is an element of concept g or vice-versa." + + RELATION isaRfx[Concept*Concept] -- isaRfx[Concept*Concept]=isa[Concept*Concept]\/isa[Concept*Concept]~ + ROLE ExecEngine MAINTAINS "Compute isaRfxIns", "Compute isaRfxDel" + RULE "Compute isaRfxIns" : isa[Concept*Concept]\/isa[Concept*Concept]~ |- isaRfx[Concept*Concept] + MEANING "TODO: MEANING ONTBREEKT" + VIOLATION (TXT "{EX} InsPair;isaRfx[Concept*Concept];Concept;", SRC I, TXT ";Concept;", TGT I) + RULE "Compute isaRfxDel" : isaRfx[Concept*Concept] |- isa[Concept*Concept]\/isa[Concept*Concept]~ + MEANING "TODO: MEANING ONTBREEKT" + VIOLATION (TXT "{EX} DelPair;isaRfx[Concept*Concept];Concept;", SRC I, TXT ";Concept;", TGT I) + + RELATION isaRfxCopy[Concept*Concept] -- necessary only for calling the Transitive closure function. + ROLE ExecEngine MAINTAINS "Compute transitive closure of isa[Concept*Concept]\\/isa[Concept*Concept]~" + RULE "Compute transitive closure of isa[Concept*Concept]\\/isa[Concept*Concept]~" : isaRfx[Concept*Concept] = isaRfxCopy[Concept*Concept] + MEANING "TODO: MEANING ONTBREEKT" + VIOLATION (TXT "{EX} TransitiveClosure;isaRfx[Concept*Concept];Concept;isaRfxCopy[Concept*Concept];isaRfxPlus[Concept*Concept]") + + ROLE ExecEngine MAINTAINS "Compute isaRfxStar by Ins", "Compute isaRfxStar by Del" + RULE "Compute isaRfxStar by Ins" : isaRfxPlus[Concept*Concept]\/I |- isaRfxStar[Concept*Concept] + MEANING "TODO: MEANING ONTBREEKT" + VIOLATION (TXT "{EX} InsPair;isaRfxStar[Concept*Concept];Concept;", SRC I, TXT ";Concept;", TGT I) + RULE "Compute isaRfxStar by Del" : isaRfxStar[Concept*Concept] |- isaRfxPlus[Concept*Concept]\/I + MEANING "TODO: MEANING ONTBREEKT" + VIOLATION (TXT "{EX} DelPair;isaRfxStar[Concept*Concept];Concept;", SRC I, TXT ";Concept;", TGT I) +ENDPATTERN + +ENDCONTEXT \ No newline at end of file diff --git a/AmpersandData/FormalAmpersand/Conjuncts.adl b/AmpersandData/FormalAmpersand/Conjuncts.adl index f9b41b25e9..dca8d4c4b6 100644 --- a/AmpersandData/FormalAmpersand/Conjuncts.adl +++ b/AmpersandData/FormalAmpersand/Conjuncts.adl @@ -1,28 +1,33 @@ -CONTEXT FormalAmpersand IN ENGLISH LATEX +CONTEXT FormalAmpersand IN ENGLISH LATEX PATTERN Conjuncts -RELATION qRule[Quad*Rule] [UNI,TOT] -RELATION qConjuncts[Quad*Conjunct] -RELATION rc_rulename[Conjunct*Identifier] [UNI,TOT] -RELATION rc_conjunct[Conjunct*Expression] [UNI,TOT] -RELATION rc_dnfClauses[Conjunct*DnfClause] -RELATION conjuncts[Rule*Expression] -RELATION expr2dnfClause[Expression*DnfClause] [UNI,TOT] -RELATION allShifts[DnfClause*DnfClause] -RELATION term[Rule*Expression][UNI,TOT] --is defined somewhere else too. -RELATION conjNF[Expression*Expression] [UNI,TOT] -RELATION exprIsc2list[Expression*Expression] [TOT] -RELATION name[Rule*RuleName] [UNI,TOT] + RELATION allConjuncts[Context*Conjunct] [INJ] + MEANING "All conjuncts in a context." + RELATION allShifts[DnfClause*DnfClause] + RELATION conjNF[Term*Term] [UNI,TOT] + RELATION rc_conjunct[Conjunct*Term] [TOT] + RELATION conjuncts[Rule*Term] + RELATION exprIsc2list[Term*Term] [TOT] + RELATION expr2dnfClause[Term*DnfClause] [UNI,TOT] + RELATION name[Rule*RuleName] [UNI,TOT] + RELATION originatesFrom[Conjunct*Rule] [TOT] -- rule where the conjunct originates from. + RELATION qRule[Quad*Rule] [UNI,TOT] + RELATION qConjuncts[Quad*Conjunct] + RELATION rc_orgRules[Conjunct*RuleName] [UNI,TOT] + RELATION rc_conjunct[Conjunct*Term] [UNI,TOT] + RELATION rc_dnfClauses[Conjunct*DnfClause] + RELATION term[Rule*Term][UNI,TOT] --is defined somewhere else too. -RULE Conjuncts1 : qConjuncts;rc_conjunct |- qRule;conjuncts -MEANING "All conjuncts in a quad are derived by means of the relation ``conjuncts''." -RULE Conjuncts2 : rc_conjunct~;rc_dnfClauses = expr2dnfClause;allShifts -MEANING "A conjunct in a quad stores all dnf-clauses that are derived from the expression in that conjunct." + RULE Conjuncts1 : qConjuncts;rc_conjunct |- qRule;conjuncts + MEANING "All conjuncts in a quad are derived by means of the relation ``conjuncts''." -RULE defconjuncts : conjuncts = term[Rule*Expression];conjNF;exprIsc2list -MEANING "The conjuncts in a rule are defined as the top-level subexpressions in the conjunctive normal form of the expression related to that rule." + RULE Conjuncts2 : rc_conjunct~;rc_dnfClauses = expr2dnfClause;allShifts + MEANING "A conjunct in a quad stores all dnf-clauses that are derived from the term in that conjunct." -RULE Conjuncts4 : qConjuncts~;qRule |- rc_rulename;name~ -MEANING "The name of every conjunct in a quad is the name of the rule from which it has been derived." + RULE defconjuncts : conjuncts = term[Rule*Term];conjNF;exprIsc2list + MEANING "The conjuncts in a rule are defined as the top-level subterms in the conjunctive normal form of the term related to that rule." + + RULE Conjuncts4 : qConjuncts~;qRule |- rc_orgRules;name[Rule*RuleName] ~ + MEANING "The name of every conjunct in a quad is the name of the rule from which it has been derived." ENDPATTERN ENDCONTEXT \ No newline at end of file diff --git a/AmpersandData/FormalAmpersand/Conjuncts.docadl b/AmpersandData/FormalAmpersand/Conjuncts.docadl index 2e83c2aed7..b7e2ea866e 100644 --- a/AmpersandData/FormalAmpersand/Conjuncts.docadl +++ b/AmpersandData/FormalAmpersand/Conjuncts.docadl @@ -3,44 +3,44 @@ META "authors" "Stef Joosten" PURPOSE CONTEXT FormalAmpersand {+This file documents the Conjuncts pattern as of september 2014. It is meant to be included in FormalAmpersand.adl --} ++} PURPOSE CONCEPT Conjunct {+In order to maintain invariants, Ampersand breaks down all rules into conjuncts. -Each rule $r$ can be written as a conjunction of $n$ expressions: +Each rule $r$ can be written as a conjunction of $n$ terms: \[r\ =\ c_0\cap c_1\cap ... c_{n-1}\] Conjuncts are produced by a normalizer, which produces conjunctive forms. --} -CONCEPT Conjunct "A conjunct is an expression that represents an invariant in an information system." ++} +CONCEPT Conjunct "A conjunct is an term that represents an invariant in an information system." PURPOSE CONCEPT Quad {+The Ampersand compiler stores intermediate results of analysing a rule in a Haskell data structure called ``Quad'', As a result, the analysis is done only once and is reused when needed. --} ++} CONCEPT Quad "A quad is a Haskell data structure that corresponds to one rule in an Ampersand script." PURPOSE CONCEPT DnfClause {+Each conjunct is stored in disjunctive normal form, for the purpose of formula manipulation. --} -CONCEPT DnfClause "A DnfClause is a Haskell data structure that stores an expression in disjunctive normal form." ++} +CONCEPT DnfClause "A DnfClause is a Haskell data structure that stores an term in disjunctive normal form." -- Rules PURPOSE RULE Conjuncts1 {+In order to split a rule in one or more conjuncts, we use --} ++} PURPOSE RULE Conjuncts2 -{+In order to manipulate with expressions, they are stored in disjunctive normal form. +{+In order to manipulate with terms, they are stored in disjunctive normal form. As multiple variations of this form can be derived, all of them are stored in the conjunct. --} ++} PURPOSE RULE defconjuncts {+In order to compute the conjuncts from a rule, we need a computable relation, conjuncts. The conjuncts are derived from the conjunctive normal form. --} ++} PURPOSE RULE Conjuncts4 {+For the purpose of keeping track of things, every conjunct gets a name. That is the same name as the name of the rule from which the conjunct is derived. --} ++} ENDCONTEXT diff --git a/AmpersandData/FormalAmpersand/Contexts.adl b/AmpersandData/FormalAmpersand/Contexts.adl index cdd4e27d62..0776ff22dd 100644 --- a/AmpersandData/FormalAmpersand/Contexts.adl +++ b/AmpersandData/FormalAmpersand/Contexts.adl @@ -24,7 +24,6 @@ VIEW Signature: Signature( TXT "[" , src;name[Concept*ConceptName] , TXT "*" , t PATTERN Context CONCEPT Context "A context is the root of the abstract syntax tree of a valid Ampersand rule specification." - VIEW Context: Context(name[Context*ContextName]) REPRESENT ContextName TYPE ALPHANUMERIC RELATION name[Context*ContextName] [UNI] --Removed TOT, for it gives a nasty violation MEANING "The name of a context." @@ -33,21 +32,20 @@ PATTERN Context MEANING "A ContextName without Context will be removed." VIOLATION ( TXT "{EX} DelAtom;ContextName;", SRC I ) - RELATION name[Rule*RuleName] [UNI,TOT] - REPRESENT RuleName TYPE ALPHANUMERIC 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 - RELATION gens[Context*Isa] + RELATION context[Isa*Context] [UNI,TOT] + RELATION context[IsE*Context] [UNI,TOT] MEANING "The user-defined generalization rules in a context." RELATION concepts[Pattern*Concept] RELATION uses[Context*Pattern] MEANING "If a context uses a pattern, everything declared in that pattern is valid within the context." - RELATION context[Concept*Context] [UNI] -- comes from concs, which is defined in FSpec. This contains all concepts declared inside a context but outside the patterns it contains. + RELATION context[Concept*Context] [UNI] -- This contains all concepts declared inside a context. MEANING "If a concept declaration is used in a context, that concept exists in that context. This is registered in the system." RELATION ctxds[Relation*Context] [UNI] -- comes from ctxds, which is defined in A_Context. This contains all relations declared inside a context but outside the patterns it contains. MEANING "Any relation declared anywhere in a context outside the scope of a pattern is registered in the system." - RELATION declaredIn[Relation*Context] [UNI] -- comes from relsDefdIn, which is defined in FSpec. This contains all relations declared inside a context including the patterns it contains. + RELATION context[Relation*Context] [UNI] -- comes from relsDefdIn, which is defined in FSpec. This contains all relations declared inside a context including the patterns it contains. MEANING "Any relation declared anywhere in a context is registered in the system." RELATION ctxrs[Rule*Context] [UNI] -- This contains all rules declared inside a context but outside the patterns it contains. MEANING "If a rule is declared in a context outside any pattern, that rule exists in that context. This is registered in the system." @@ -55,7 +53,8 @@ PATTERN Context -- which are not multiplicity- and not identity rules. See ViewPoint.hs RELATION multrules[Rule*Context] [UNI] -- ^ all multiplicityrules the user has declared within this context including the patterns it contains. RELATION identityRules[Rule*Context] [UNI] -- ^ all identity rules the user has declared within this context. This contains all rules declared inside a context including the patterns it contains. - RELATION allRules[Context*Rule] [INJ] -- This contains all rules declared inside a context. This contains all rules declared inside a context including the patterns it contains. + -- Use allRules[Rule*Context] to get all rules declared inside a context, including all rules declared inside the patterns in that context. A rule can be either user defined, a multiplicity rule, or identity rule + MEANING "If a rule is declared anywhere in a context, that rule exists in that context. This is registered in the system." RELATION context[Pattern*Context] [UNI] -- comes from patterns, which is defined in FSpec. This contains all patterns declared inside a context. MEANING "If a pattern is declared inside a context, this is registered in the system." @@ -68,21 +67,13 @@ PATTERN Context MEANING "A rule declared in a context outside the scope of a pattern is registered in the system." VIOLATION (TXT "{EX} InsPair;udefrules;Rule;", SRC I, TXT ";Context;", TGT I) - PURPOSE RULE "all rules" - {+It is convenient to have one relation to contain all rules in a context. TODO: delete rules from allRules. - +} - ROLE ExecEngine MAINTAINS "all rules" - RULE "all rules" : udefrules[Rule*Context] \/ multrules \/ identityRules |- allRules[Context*Rule]~ - MEANING "All rules in a context consist of the user-defined rules, the multiplicity rules, and the identity rules." - VIOLATION (TXT "{EX} InsPair;allRules;Context;", TGT I, TXT ";Rule;", SRC I) - PURPOSE RULE "relation declared outside pattern" {+Ampersand allows its users to declare relations in a context, outside the scope of a pattern. +} ROLE ExecEngine MAINTAINS "relation declared outside pattern" - RULE "relation declared outside pattern" : ctxds[Relation*Context] |- declaredIn[Relation*Context] + RULE "relation declared outside pattern" : ctxds[Relation*Context] |- context[Relation*Context] MEANING "A relation declared in a context outside the scope of a pattern is registered in the system." - VIOLATION (TXT "{EX} InsPair;declaredIn;Relation;", SRC I, TXT ";Context;", TGT I) + VIOLATION (TXT "{EX} InsPair;context;Relation;", SRC I, TXT ";Context;", TGT I) PURPOSE RULE "pat defined in means used in" {+Patterns can be defined inside a context. This means that all declarations in that pattern are used in that context. @@ -150,11 +141,11 @@ PATTERN Validity - all rules defined in patterns used by the context +} ROLE ExecEngine MAINTAINS validRules - RULE validRules : allRules[Pattern*Rule]~;(context\/uses~) \/ allRules[Context*Rule]~ |- valid[Rule*Context] + RULE validRules : patRules[Pattern*Rule]~;(context\/uses~) \/ context[Rule*Context] |- valid[Rule*Context] MEANING "Every rule defined in one of the patterns inside a context, or in the context itself, or in one of the contexts used by this context, is valid throughout that context." VIOLATION (TXT "{EX} InsPair;valid;Rule;", SRC I, TXT ";Context;", TGT I) ROLE User MAINTAINS AllValidRules - RULE AllValidRules : valid[Rule*Context] |- allRules[Pattern*Rule]~;(context\/uses~) \/ allRules[Context*Rule]~ + RULE AllValidRules : valid[Rule*Context] |- patRules[Pattern*Rule]~;(context\/uses~) \/ context[Rule*Context] MEANING "TODO: MEANING ONTBREEKT" VIOLATION (TXT "Rule ", SRC name, TXT " is not valid in context ", TGT I) ENDPATTERN @@ -172,27 +163,28 @@ PATTERN Patterns VIOLATION ( TXT "{EX} DelAtom;PatternName;", SRC I ) + RELATION allRules[Rule*Context] [] -- ^ all rules in the context, i.e. all user defined rules, multiplicity 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 multiplicity- and not identity rules. See ViewPoint.hs RELATION multrules[Rule*Pattern] [] -- ^ all multiplicityrules 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 allRules[Pattern*Rule] -- This contains all rules declared inside a 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[Pattern];allRules\/allRules~;I[Context];allRules) |- -V + 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] - (declaredIn;I[Pattern];declaredIn~\/declaredIn;I[Context];declaredIn~) |- -V + RULE "Remove relation atom" : I[Relation] - (declaredIn;I[Pattern];declaredIn~\/context;I[Context];context~) |- -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;formalExpression~;allRules~ |- declaredIn[Relation*Pattern] + RULE "self-sustained rules" : 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 diff --git a/AmpersandData/FormalAmpersand/Documentation.adl b/AmpersandData/FormalAmpersand/Documentation.adl index 1872b70cfe..ead1822cb3 100644 --- a/AmpersandData/FormalAmpersand/Documentation.adl +++ b/AmpersandData/FormalAmpersand/Documentation.adl @@ -18,8 +18,6 @@ PATTERN Documentation MEANING "The meanings of a rule." RELATION purpose[Rule * Purpose] MEANING "The purposes of a rule." - RELATION purpose[Identity * Purpose] - MEANING "The purposes of an identity." RELATION purpose[View * Purpose] MEANING "The purposes of a view." RELATION purpose[Concept * Purpose] diff --git a/AmpersandData/FormalAmpersand/Generics.adl b/AmpersandData/FormalAmpersand/Generics.adl index 9ffb9e0d9f..e95283950b 100644 --- a/AmpersandData/FormalAmpersand/Generics.adl +++ b/AmpersandData/FormalAmpersand/Generics.adl @@ -6,6 +6,7 @@ REPRESENT MySQLQuery TYPE BIGALPHANUMERIC RELATION versionInfo[Context*AmpersandVersion] [UNI,TOT] -- e.g. 'Ampersand v3.0.3[master:029ea02], build time: 05-Feb-15 08:46:36 W. Europe Standard Time' +REPRESENT AmpersandVersion TYPE ALPHANUMERIC -- HJO20150206 @Rieks: Willen we hier nog iets met signalTableName, isDev, autoRefreshInterval? @@ -31,15 +32,24 @@ RELATION expSQL[PairViewSegment*MySQLQuery] [UNI] -- IFF SegmentType == 'Exp' --[Conjuncts]-- RELATION allConjuncts[Context*Conjunct] [INJ] -RELATION originatesFrom[Conjunct*Rule] [TOT] -- rule where the conjunct originates from. -RELATION conjunct[Conjunct*Expression] [TOT] +RELATION rc_conjunct[Conjunct*Term] [TOT] +ROLE ExecEngine MAINTAINS conjunctTotal +RULE conjunctTotal : I[Conjunct] |- rc_conjunct;rc_conjunct~ +-- VIOLATION ( TXT "The conjunct ", SRC showADL, TXT " should have been bound to a term.") +VIOLATION ( TXT "{EX} DelAtom;Conjunct;", SRC I ) + +RELATION originatesFrom[Conjunct*Rule] -- rule where the conjunct originates from. +ROLE ExecEngine MAINTAINS originatesFromTotal +RULE originatesFromTotal : I[Conjunct] |- originatesFrom;originatesFrom~ +-- VIOLATION ( TXT "The conjunct ", SRC showADL, TXT " should have been bound to a rule.") +VIOLATION ( TXT "{EX} DelAtom;Conjunct;", SRC I ) --[Roles]-- -- VIEW Role : Role(name) -- TODO: IDENT Role: Role(name[Role*RoleName], allRoles[Context*Role]~) RELATION allRoles[Context*Role] [INJ] -RELATION name[Role*RoleName] [UNI,TOT] +RELATION name[Role*RoleName] [UNI] REPRESENT RoleName TYPE ALPHANUMERIC RELATION maintains[Role*Rule] -- e.g. ("ExecEngine", "Activeren van rollen") (was "ruleNames") RELATION interfaces[Role*Interface] diff --git a/AmpersandData/FormalAmpersand/Interfaces.adl b/AmpersandData/FormalAmpersand/Interfaces.adl index 0330970803..7600e472d5 100644 --- a/AmpersandData/FormalAmpersand/Interfaces.adl +++ b/AmpersandData/FormalAmpersand/Interfaces.adl @@ -1,136 +1,80 @@ -CONTEXT RAP IN ENGLISH --! 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 !-- --- RJ: I wish you guys would use relation names that are easily interpretable by people that do not know about the Haskell stuff behind all this. Use 'ifcPurpose' rather than 'ifcPrp', and use something like 'ifcViolatableRules' rather than 'viol'. More or less self explanatory naming is considered a good practice. Use it. +-- SJ: I made some changes. By the way, the story is being told in the accompanying file called Interfaces.docadl. +CONTEXT RAP IN ENGLISH -PATTERN Interfaces -CONCEPT Interface "An interface is a mechanism that communicates data between different (two) contexts." -IDENT Interface: Interface(ifcObj;name,interfaces[Context*Interface]~) -CONCEPT ObjectDef "An ObjectDef is the (recursive) structure that corresponds with a BOX in an Ampersand script." +INCLUDE "Concepts.adl" +--INCLUDE "AtomsAsShouldBe.adl" + +PATTERN "Static Interface Structure" + CLASSIFY Interface ISA ObjectDef + CONCEPT ObjectDef "An ObjectDef is the (recursive) structure that corresponds with a BOX in an Ampersand script." + + CLASSIFY ObjectDef ISA Term + CONCEPT Term "Formerly known as Expression." + + {-Han, + ifcParams contain the editable relations. This needs to be enhanced to ifcInputs and ifcOutputs. + So I have substituted ifcParams by ifcInputs everywhere in the Haskell code. + ifcOutputs has to be added yet. + -} + RELATION name[Interface*InterfaceName] [UNI,TOT] + MEANING "This relation contains the name of each interface." + REPRESENT InterfaceName TYPE ALPHANUMERIC + + 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)." + RELATION ifcPurpose[Interface*Purpose] [UNI] + MEANING "The purpose of each interface is being registered." + + RELATION label[FieldDef*FieldName] [UNI,TOT] + MEANING "Every field definition has a label." + REPRESENT FieldName TYPE ALPHANUMERIC + RELATION objpos[ObjectDef*Origin] [UNI] + MEANING "Every object definition has a position in the text of the Ampersand source file (filename, line number and column number)." + RELATION objView[ObjectDef*View] [UNI] + MEANING "An object definition can have a view that should be used for this object (e.g. TABS, TABLE, etc.)." + RELATION usedIn[Relation*Term] + MEANING "If a relation is used in an term, this is registered in usedIn." + RELATION formalTerm[Rule*Term] + MEANING "The term, of which a rule consists, is accessible via the relation formalTerm." + + PURPOSE RELATION edit[FieldDef*Relation] + {+ To allow editing to insert, update and delete links, + Ampersand registers whether the term in a field def is just the relation.+} + RELATION edit[FieldDef*Relation] + MEANING "The term in this FieldDef is just the relation." + PURPOSE RELATION editFlp[FieldDef*Relation] + {+ To allow editing to insert, update and delete links, + Ampersand registers whether the term in a field def is just the flipped relation.+} + RELATION editFlp[FieldDef*Relation] + MEANING "The term in this FieldDef is just the flipped relation." + +ENDPATTERN -{-Han, -ifcParams contain the editable relations. This needs to be enhanced to ifcInputs and ifcOutputs. -So I have substituted ifcParams by ifcInputs everywhere in the Haskell code. -ifcOutputs has to be added yet. --} -RELATION name[Interface*InterfaceName] [UNI,TOT] -MEANING "This relation contains the name of each interface." -REPRESENT InterfaceName TYPE ALPHANUMERIC +PATTERN Interfaces RELATION ifcInputs[Interface*Relation] -- was: ifcParams MEANING "This relation contains the relations that can be edited in an interface by a user or another computer." RELATION ifcOutputs[Interface*Relation] MEANING "This relation contains the relations that can be edited by the computer for restoring invariants." -{- Replace ifcInputs and ifcOutputs with: -CONCEPT ContextRelation "a relation in a specific context" -RELATION ifcRelation[Interface*ContextRelation] -MEANING "This relation contains the relations in either of the contexts that the Interface connects and whose population may be modified within a transaction. --} -RELATION ifcClass[Interface*String] [UNI] --RJ: What is this for? + RELATION ifcRoles[Interface*Role] MEANING "This relation contains the roles for which an interface is available (empty means: available for all roles)." -RELATION ifcObj[Interface*ObjectDef] [UNI,TOT,INJ] -MEANING "Every interface has precisely one object definition, which defines the structure of objects to be changed by transactions of this interface." RELATION ifcQuads[Interface*Quad] -- RJ: What is a Quad? MEANING "All quads that are needed to perform computations for maintaining rules in an interface are registered." -RELATION ifcControls[Interface*Conjunct] -- RJ: Why not call this 'ifcConjuncts'? +RELATION ifcConjuncts[Interface*Conjunct] MEANING "All conjuncts that must be evaluated after a transation are registered." -RELATION ifcPos[Interface*Origin] [UNI,TOT] -MEANING "The position in the file (filename, line- and column number)." -RELATION ifcPrp[Interface*String] [UNI] -- RJ: use more self-explanatory (longer) name, please -MEANING "The purpose of each interface is being registered." -RELATION viol[Interface*Rule] -- RJ: use more self-explanatory (longer) name, please -MEANING "All rules that can be violated by an interface are included in viol." - -RELATION name[ObjectDef*ObjectName] [UNI,TOT] -MEANING "Every object definition has a name." -REPRESENT ObjectName TYPE ALPHANUMERIC -RELATION objpos[ObjectDef*Origin] [UNI,TOT] -MEANING "Every object definition has a position in the text of the Ampersand source file (filename, line number and column number)." -RELATION objExpression[ObjectDef*Expression] [UNI,TOT] -- RJ: Why not call this thing 'objExpr(ession)'? -MEANING "Every object definition has an expression, which determines the population for which that definition is applicable." -RELATION objmView[ObjectDef*View] [UNI] -- RJ: Why not call this thing 'objView' or 'objdefView' -MEANING "An object definition can have a view that should be used for this object (e.g. TABS, TABLE, etc.)." -RELATION usedIn[Relation*Expression] -MEANING "If a relation is used in an expression, this is registered in usedIn." -RELATION formalExpression[Rule*Expression] -MEANING "The expression, of which a rule consists, is accessible via the relation formalExpression." +RELATION violatable[Interface*Rule] +MEANING "All rules that can be violated by an interface are included in violatable." -RULE violatableByInterface : viol = (ifcInputs\/ifcOutputs);usedIn;formalExpression~ +RULE violatableByInterface : violatable = (ifcInputs\/ifcOutputs);usedIn;formalTerm~ MEANING "An interface may violate any rule that uses an input- or output relation of that interface." -RELATION getExpressionRelation[Expression*Relation] [UNI] -- RJ: use a more self-explanatory name, please -MEANING "An Expression that is equivalent to a Relation, allows that relation to be edited." - -RULE checkExpressionRelation : getExpressionRelation |- (usedIn~;-I;usedIn/\I);getExpressionRelation --- How is that different from: usedIn~;getExpressionRelation |- I -MEANING "An editable expression contains one relation only." - -{- HJO, 20170825 Disabled this rule, for kleenePlus is currently not supported by the database -RULE "possible inputs" : ifcInputs |- ifcObj;(attIn~;attObj)+;objExpression;getExpressionRelation -MEANING "Allow only those input relations that have an editable field inside the interface." -MESSAGE "Unusable input relation in interface:" -VIOLATION (TXT "Relation ", TGT I, TXT " has no editable field in interface ", SRC I) --} -RULE "accessible relations" : V[Context*Interface];ifcObj;objExpression;getExpressionRelation -MEANING "For every relation that is potentially editable, there exists an interface through which it can be accessed." -ROLE "FormalAmpersand" MAINTAINS "accessible relations" ENDPATTERN -{- -PATTERN InterfaceSession -RELATION sessAtom[SESSION*Atom] [UNI,TOT] -MEANING "Each session has a root atom, from which all data in the current interface is accessible." -RELATION sessIfc[SESSION*Interface] [UNI,TOT] -MEANING "Each session has a current interface." -RELATION sessionRole[SESSION*Role] [UNI,TOT] -MEANING "The current role of the session user is registered with the session a user is in." -RULE "Current role" : sessIfc |- sessionRole;ifcRoles~ \/ -(V;ifcRoles~) -MEANING "Each session has a current interface, which is linked to one of the roles allowed for that interface, or to any interface if no roles are specified." -RULE "Current atom" : sessIfc |- sessAtom;right~;in;(ifcObj;objExpression)~ -MEANING "Each session has a current interface, which is linked to one of the roles allowed for that interface, or to any interface if no roles are specified." -ENDPATTERN --} - -PATTERN InterfaceSemantics -CONCEPT Transaction "A transaction is an instance of an interface, which is being used (by a user or a program) to interact with the system." -- Transactions reside in the front end. -CONCEPT Object "An object is an instance of an ObjectDef." -- Objects reside in the front end. -CONCEPT Act "An act is an event that inserts or deletes a set of pairs in a relation." -- Acts occur in the front end. - -CLASSIFY Object ISA Pair -RELATION inst[Object*ObjectDef] [UNI,TOT] -MEANING "Because each object is an instance of an ObjectDef, we need to know that ObjectDef." -RELATION left[Pair*Atom] [UNI,TOT] -RELATION right[Pair*Atom] [UNI,TOT] -RELATION in[Pair*Expression] -MEANING "The combination of a pair and an expression yields a statement, which makes sense to users." -RULE "atoms in objects" : inst;objExpression = I[Object];in -MEANING "An object is a pair of atoms that is in the object expression" - -RELATION attIn[Attribute*ObjectDef] [UNI,TOT] -MEANING "Every attribute belongs to an ObjectDef." -RELATION attObj[Attribute*ObjectDef] [UNI,TOT] -MEANING "Every attribute represents an ObjectDef (inside another Objectdef)." -RULE "attributes in objects" : left~;inst[Object*ObjectDef];attObj~;attIn = right~;inst[Object*ObjectDef] -MEANING "A left atom in an attribute ob an object is the right atom in that object's instance." -RULE "attributes with unique names" : name;name~ /\ attIn~;attIn |- I[ObjectDef] -MEANING "Every attribute within one object definition has a unique name." - -RELATION transactionObject[Transaction*Object] [UNI,TOT] -MEANING "Each Ampersand transaction has a transaction object, in which the front end administers the progress of a transaction." -RELATION inst[Transaction*Interface] [UNI,TOT] -MEANING "Because each transaction is an instance of an interface, we need to know that interface." -RELATION delta[Act*Pair] -MEANING "The pairs that are inserted or deleted by an act are known as the delta." -RELATION changes[Act*Relation] [UNI,TOT] -MEANING "The relation affected by an act." -RELATION inQ[Quad*Act] [UNI,TOT] -MEANING "The act that causes a Quad to fire." -RELATION outQ[Quad*Act] -MEANING "The acts that can be caused by a Quad firing." -RULE quadsInInterface : ifcQuads = ifcInputs;changes~;inQ~ /\ ifcOutputs;changes~;outQ~ -MEANING "An interface contains those quads that are fired by its inputs and that produce changes in its outputs." -ENDPATTERN - - -ENDCONTEXT - - +ENDCONTEXT \ No newline at end of file diff --git a/AmpersandData/FormalAmpersand/Interfaces.docadl b/AmpersandData/FormalAmpersand/Interfaces.docadl index 738e8f58c8..a2b4ecd442 100644 --- a/AmpersandData/FormalAmpersand/Interfaces.docadl +++ b/AmpersandData/FormalAmpersand/Interfaces.docadl @@ -2,6 +2,11 @@ CONTEXT RAP 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 !-- +PURPOSE PATTERN "Data objects" MARKDOWN +{+This pattern describes the invariant semamtics of data objects (concept: Object). +An `Object` is a runtime thing, which is defined by an `ObjectDef`. ++} + PURPOSE PATTERN Interfaces {+One purpose of Interfaces is to convert/translate data from one context (that is governed by specific rules/relations/presentations) to another context (governed by another set of rules/relations/presentations). @@ -17,8 +22,12 @@ PURPOSE CONCEPT Interface {+An interface is used by persons or by computers to execute transactions on a data set. Interfaces are needed to communicate with persons or other computer programs. +} + +PURPOSE RELATION ifcRoles[Interface*Role] +{+ An interface is accessible only to the role(s) mentioned in this relation. +} + PURPOSE CONCEPT ObjectDef -{+ In essence, an interface is a hierarchical structure containing attributes. +{+ In essence, an interface is a hierarchical structure containing fields. It describes the structure of objects upon which transactions can be executed. The interface may also contain information related to such objects. +} @@ -28,24 +37,23 @@ PURPOSE RELATION ifcObj[Interface*ObjectDef] Each interface has precisely one object definition. +} -PURPOSE RELATION name[ObjectDef*ObjectName] -{+The name of an object definition serves as attribute name, if used inside some other object definition. -Otherwise, this name is the name of the interface. -The label has no meaning in the Compliant Service Layer, but is used in the generated user interface if it is not an empty string. +PURPOSE RELATION label[Field*ObjectName] +{+The label of an objectDef is typically the field name in the comprising ObjectDef. +An outside actor, whether a user or a machine, recognizes a field by its label to ensure that it interprets the data in this field correctly. +} -PURPOSE RELATION objExpression[ObjectDef*Expression] -{+Every object definition is associated with an expression. -If the object definition is an attribute, this expression yields the pairs that are used to ``walk'' through the population of the system. +PURPOSE RELATION objTerm[ObjectDef*Term] +{+Every object definition is associated with an term. +If the object definition is a field, this term yields the pairs that are used to ``walk'' through the population of the system. It works the same way if the object definition is related to an interface. -In that case, the expression characterizes the atoms on which it can be used. +In that case, the term characterizes the atoms on which it can be used. +} -PURPOSE RELATION getExpressionRelation[Expression*Relation] -{+Some expressions are equivalent to a relation. -Such expressions can be used to change the content of (i.e. to edit) a relation. -We say that the expression allows editing in that relation. -That is relevant, because such expressions allow the system to open a relation for editing during a transaction. +PURPOSE RELATION getTermRelation[Term*Relation] +{+Some terms are equivalent to a relation. +Such terms can be used to change the content of (i.e. to edit) a relation. +We say that the term allows editing in that relation. +That is relevant, because such terms allow the system to open a relation for editing during a transaction. So in order to be edited, a relation must occur in this relation. +} @@ -56,12 +64,17 @@ The following rule signals the developer if no such interface exists. It is meant to guard completeness, i.e. that every relation can be edited by at least one interface. +} +{- PURPOSE PATTERN InterfaceSession {+Every user and every computer program that interacts with an information system does so through an interface. +} PURPOSE RELATION sessionRole {+In order to allow role based access control, every session is assigned to a role. +} +-} + +PURPOSE RELATION ifcInputs[Interface*Relation] +{+Relations ifcInputs and ifcOutputs exist for computing automated functionality.+} PURPOSE PATTERN InterfaceSemantics {+Calling an interface in Ampersand corresponds with performing a database transaction. @@ -76,7 +89,7 @@ PURPOSE CONCEPT Object Starting on a particular atom (in the database), users may follow the links to browse through the data. However, the amount of data to navigate in is limited when using an interface. That amount of data is called "object". -Roughly speaking, an object consists of one atom (the root of the object) and all data that can be reached by following the links as defined in the attributes of that objects. +Roughly speaking, an object consists of one atom (the root of the object) and all data that can be reached by following the links as defined in the fields of that objects. Since objects are defined recursively, interfaces can involve a substantial amount of data. +} @@ -90,31 +103,31 @@ For that purpose, a transaction is treated as an instance of an interface. This makes interfaces useful as a description of communication with the information system. +} -PURPOSE RELATION inst[Object*ObjectDef] -{+Being an instance of an object definition, every object must be in the instance-relation to identify the object definition of which it is an instance. +PURPOSE RELATION def[Object*ObjectDef] +{+Being an instance of an object definition, every object must be in the def-relation to identify the object definition of which it is an instance. +} -PURPOSE RELATION left[Pair*Atom] +PURPOSE RELATION lAtom[Pair*Atom] {+The relation ``left'' is needed to identify one of the atoms in a pair. +} -PURPOSE RELATION right[Pair*Atom] +PURPOSE RELATION rAtom[Pair*Atom] {+The relation ``right'' is needed to identify the other atom in a pair. +} -PURPOSE RELATION in[Pair*Expression] -{+The relation ``in'' is needed to establish whether a pair is in an expression. -This can be computed by taking the populations of all relations that are used in the expression, and by computing the result of applying the relational operators in the expression on those relations. +PURPOSE RELATION in[Pair*Term] +{+The relation ``in'' is needed to establish whether a pair is in an term. +This can be computed by taking the populations of all relations that are used in the term, and by computing the result of applying the relational operators in the term on those relations. +} PURPOSE RULE "atoms in objects" -{+The data content of an object is defined by the attribute expressions inside that object. +{+The data content of an object is defined by the field terms inside that object. +} -PURPOSE RULE "attributes in objects" -{+An object may have a number of attributes, which are defined in the object's definition. +PURPOSE RULE "fields in objects" +{+An object may have a number of fields, which are defined in the object's definition. +} -PURPOSE RULE "attributes with unique names" -{+In order to identify attributes within an object, each attribute is given a name to identify its attribute expression. +PURPOSE RULE "fields with unique names" +{+In order to identify fields within an object, each field is given a name to identify its field term. +} PURPOSE RULE quadsInInterface @@ -143,7 +156,7 @@ PURPOSE RELATION changes[Act*Relation] +} PURPOSE RULE "atoms in objects" -{+Being an instance of an Objectdef, every object represents one pair of atoms that is in the object expression of that object. +{+Being an instance of an Objectdef, every object represents one pair of atoms that is in the object term of that object. +} diff --git a/AmpersandData/FormalAmpersand/Patterns.docadl b/AmpersandData/FormalAmpersand/Patterns.docadl index 043f97947c..381d0939b5 100644 --- a/AmpersandData/FormalAmpersand/Patterns.docadl +++ b/AmpersandData/FormalAmpersand/Patterns.docadl @@ -12,6 +12,10 @@ INCLUDE "Patterns.adl" When a pattern is instantiated (reused), its definitions are made visible in the environment where it is used. Patterns are also meant to formalize the stakeholders' agreement on a particular theme. +} + PURPOSE CONCEPT Pattern + {+ Patterns are also meant to keep a discussion among stakeholders focused on a single theme. + A large set of concepts and relations can be broken down in small subsets enclosed in a pattern. + +} CONCEPT Pattern "A pattern describes a solution to a generic problem." PURPOSE CONCEPT Entity LATEX diff --git a/AmpersandData/FormalAmpersand/Relations.adl b/AmpersandData/FormalAmpersand/Relations.adl index 6bf7abe486..e707edfe97 100644 --- a/AmpersandData/FormalAmpersand/Relations.adl +++ b/AmpersandData/FormalAmpersand/Relations.adl @@ -2,6 +2,7 @@ CONTEXT AST IN ENGLISH LATEX -- The comments for this script can be found in Rules.doc PATTERN Relations +RELATION context[Relation*Context] --VIEW Relation: Relation( name , TXT "::", sign[Relation*Signature];src;name[Concept*ConceptName] ,TXT " * ", sign[Relation*Signature];tgt[Signature*Concept];name[Concept*ConceptName] ) IDENT Relation: Relation( name, sign[Relation*Signature];src, sign[Relation*Signature];tgt[Signature*Concept] , context[Relation*Context]) RULE "eq relation": name[Relation*RelationName];name[Relation*RelationName]~ @@ -20,7 +21,7 @@ REPRESENT RelationName TYPE ALPHANUMERIC VIOLATION ( TXT "{EX} DelAtom;RelationName;", SRC I ) -RELATION sign[Relation*Signature] [UNI,TOT] +RELATION sign[Relation*Signature] [UNI] MEANING "The signature of a relation." RELATION src[Signature*Concept] [UNI,TOT] @@ -29,7 +30,11 @@ MEANING "The source of a signature." RELATION tgt[Signature*Concept] [UNI,TOT] MEANING "The target of a signature." -RELATION bind[BindedRelation*Relation][UNI,TOT] +RELATION bind[BindedRelation*Relation][UNI] +ROLE ExecEngine MAINTAINS bindTotal +RULE bindTotal : I[BindedRelation] |- bind;bind~ +-- VIOLATION ( TXT "The (sub-)expression ", SRC showADL, TXT " should have been bound to a relation. ") +VIOLATION ( TXT "{EX} DelAtom;BindedRelation;", SRC I ) RELATION prop[Relation*Property] diff --git a/AmpersandData/FormalAmpersand/Rules.adl b/AmpersandData/FormalAmpersand/Rules.adl index 621a829801..334e0a3268 100644 --- a/AmpersandData/FormalAmpersand/Rules.adl +++ b/AmpersandData/FormalAmpersand/Rules.adl @@ -3,26 +3,30 @@ CONTEXT AST IN ENGLISH LATEX -- This file has been aligned with ShowMeatgrinder on 2017-07-21 by SJ. PATTERN Rules - VIEW Rule: Rule(name[Rule*RuleName]) REPRESENT RuleName TYPE ALPHANUMERIC - IDENT Rules: Rule(allRules[Context*Rule]~,name[Rule*RuleName]) + IDENT Rules: Rule(context[Rule*Context],name[Rule*RuleName]) + + RELATION ctxrs[Rule*Context] -- This contains all rules declared inside a context but outside the patterns it contains. + RELATION context[Rule*Context] [UNI] -- This contains all rules declared inside a context - RELATION ctxrs[Rule*Context] [UNI] -- This contains all rules declared inside a context but outside the patterns it contains. MEANING "If a rule is declared in a context outside any pattern, that rule exists in that context. This is registered in the system." - RELATION name[Rule*RuleName] [UNI,TOT] -- e.g. 'ASY bfOUprop::BusinessFunction*BusinessFunction' + REPRESENT RuleName TYPE ALPHANUMERIC + RELATION name[Rule*RuleName] [UNI] -- e.g. 'ASY bfOUprop::BusinessFunction*BusinessFunction' MEANING "The name of a rule." ROLE ExecEngine MAINTAINS "del unused RuleName" RULE "del unused RuleName" : I[RuleName] |- name~;name MEANING "A RuleName without Rule will be removed." VIOLATION ( TXT "{EX} DelAtom;RuleName;", SRC I ) + REPRESENT EncodedName TYPE ALPHANUMERIC RELATION urlEncodedName[Rule*EncodedName] [UNI] - MEANING "The location where a graphic of this rule can be found." + RELATION urlEncodedName[Pattern*EncodedName] [UNI] + RELATION urlEncodedName[Concept*EncodedName] [UNI] RELATION origin[Rule*Origin] [UNI] MEANING "The location where a rule is defined." -- e.g. 'line 367:10, file "C:\\\\Ampersand\\\\Workspace\\\\NRM\\\\NRM-BasicProcesses.adl"' RELATION message[Rule*Message] -- e.g. 'bfOUprop[BusinessFunction] is not antisymmetric' -- RELATION srcConcept[Rule*Concept][UNI,TOT] -- e.g. 'BusinessFunction' -- RELATION tgtConcept[Rule*Concept][UNI,TOT] -- e.g. 'BusinessFunction' - RELATION formalExpression[Rule*Expression] [UNI,TOT] + RELATION formalTerm[Rule*Term] [UNI] MEANING "The rule expressed in relation algebra." RELATION meaning[Rule*Meaning] -- e.g. 'BusinessFunction' -- RELATION sign[Rule*Signature] [UNI,TOT] diff --git a/AmpersandData/FormalAmpersand/Rules.docadl b/AmpersandData/FormalAmpersand/Rules.docadl index 8f6b73f286..18764d5142 100644 --- a/AmpersandData/FormalAmpersand/Rules.docadl +++ b/AmpersandData/FormalAmpersand/Rules.docadl @@ -44,9 +44,9 @@ There may be multiple messages to support multiple languages +} PURPOSE RELATION sign[Rule*Signature] -- Haskell: rrtyp :: Signature {+ +} -PURPOSE RELATION formalExpression[Rule*Expression] -{+ The expression to be kept true must be registered, because it formalizes the semantics of this rule. -The consequences this rule has for the information system are derived from this expression. +PURPOSE RELATION formalTerm[Rule*Term] +{+ The term to be kept true must be registered, because it formalizes the semantics of this rule. +The consequences this rule has for the information system are derived from this term. +} ENDCONTEXT \ No newline at end of file diff --git a/AmpersandData/FormalAmpersand/Expressions.adl b/AmpersandData/FormalAmpersand/Terms.adl similarity index 60% rename from AmpersandData/FormalAmpersand/Expressions.adl rename to AmpersandData/FormalAmpersand/Terms.adl index 328a3d7703..5d835e2284 100644 --- a/AmpersandData/FormalAmpersand/Expressions.adl +++ b/AmpersandData/FormalAmpersand/Terms.adl @@ -4,68 +4,68 @@ INCLUDE "Concepts.adl" INCLUDE "Relations.adl" -PATTERN "Expression definitions" - RELATION usedIn[Relation*Expression] +PATTERN "Term definitions" + RELATION usedIn[Relation*Term] MEANING "The rule expressed in relation algebra." -- TODO make transitive closure of usedIn ROLE ExecEngine MAINTAINS bindUsedIn RULE bindUsedIn : bind |- usedIn~ - VIOLATION (TXT "{EX} InsPair;usedIn;Relation;", TGT I, TXT ";Expression;", SRC I[Expression]) + VIOLATION (TXT "{EX} InsPair;usedIn;Relation;", TGT I, TXT ";Term;", SRC I[Term]) - RELATION sign[Expression*Signature][UNI,TOT] - RELATION in[Pair*Expression] + RELATION sign[Term*Signature] [UNI] -- TODO should be TOT also, but this is TODO for ObjectDefs - VIEW Equivalence : Equivalence(TXT "RULE ", first[BinaryTerm*Expression], TXT " = ", second[BinaryTerm*Expression]) - VIEW Inclusion : Inclusion (TXT "RULE ", first[BinaryTerm*Expression], TXT " |- ", second[BinaryTerm*Expression]) - -- VIEW Truth : Truth (TXT "RULE ", I[Expression]) + VIEW Equivalence : Equivalence(TXT "RULE ", first[BinaryTerm*Term], TXT " = ", second[BinaryTerm*Term]) + VIEW Inclusion : Inclusion (TXT "RULE ", first[BinaryTerm*Term], TXT " |- ", second[BinaryTerm*Term]) + -- VIEW Truth : Truth (TXT "RULE ", I[Term]) VIEW Relation : Relation(name[Relation*RelationName], TXT "[", source[Relation*Concept];name[Concept*ConceptName], TXT "*", target[Relation*Concept];name[Concept*ConceptName], TXT "]") - VIEW UnaryMinus : UnaryMinus(TXT "-", arg[UnaryTerm*Expression]) - VIEW Converse : Converse (arg[UnaryTerm*Expression], TXT "~") - VIEW KleeneStar : KleeneStar(arg[UnaryTerm*Expression], TXT "*") - VIEW KleenePlus : KleenePlus(arg[UnaryTerm*Expression], TXT "+") - VIEW Intersection : Intersection (TXT "(", first[BinaryTerm*Expression], TXT "/\\", second[BinaryTerm*Expression], TXT ")") - VIEW Union : Union (TXT "(", first[BinaryTerm*Expression], TXT "\\/", second[BinaryTerm*Expression], TXT ")") - VIEW BinaryMinus : BinaryMinus (TXT "(", first[BinaryTerm*Expression], TXT "-" , second[BinaryTerm*Expression], TXT ")") - VIEW Composition : Composition (TXT "(", first[BinaryTerm*Expression], TXT ";" , second[BinaryTerm*Expression], TXT ")") - VIEW CartesianProduct : CartesianProduct (TXT "(", first[BinaryTerm*Expression], TXT "#" , second[BinaryTerm*Expression], TXT ")") - VIEW RelationalAddition : RelationalAddition(TXT "(", first[BinaryTerm*Expression], TXT "!" , second[BinaryTerm*Expression], TXT ")") - VIEW LeftResidual : LeftResidual (TXT "(", first[BinaryTerm*Expression], TXT "/" , second[BinaryTerm*Expression], TXT ")") - VIEW RightResidual : RightResidual (TXT "(", first[BinaryTerm*Expression], TXT "\\" , second[BinaryTerm*Expression], TXT ")") + VIEW UnaryMinus : UnaryMinus(TXT "-", arg[UnaryTerm*Term]) + VIEW Converse : Converse (arg[UnaryTerm*Term], TXT "~") + VIEW KleeneStar : KleeneStar(arg[UnaryTerm*Term], TXT "*") + VIEW KleenePlus : KleenePlus(arg[UnaryTerm*Term], TXT "+") + VIEW Intersection : Intersection (TXT "(", first[BinaryTerm*Term], TXT "/\\", second[BinaryTerm*Term], TXT ")") + VIEW Union : Union (TXT "(", first[BinaryTerm*Term], TXT "\\/", second[BinaryTerm*Term], TXT ")") + VIEW BinaryMinus : BinaryMinus (TXT "(", first[BinaryTerm*Term], TXT "-" , second[BinaryTerm*Term], TXT ")") + VIEW Composition : Composition (TXT "(", first[BinaryTerm*Term], TXT ";" , second[BinaryTerm*Term], TXT ")") + VIEW CartesianProduct : CartesianProduct (TXT "(", first[BinaryTerm*Term], TXT "#" , second[BinaryTerm*Term], TXT ")") + VIEW RelationalAddition : RelationalAddition(TXT "(", first[BinaryTerm*Term], TXT "!" , second[BinaryTerm*Term], TXT ")") + VIEW LeftResidual : LeftResidual (TXT "(", first[BinaryTerm*Term], TXT "/" , second[BinaryTerm*Term], TXT ")") + VIEW RightResidual : RightResidual (TXT "(", first[BinaryTerm*Term], TXT "\\" , second[BinaryTerm*Term], TXT ")") CONCEPT Operator "" REPRESENT Operator TYPE ALPHANUMERIC CONCEPT BinaryTerm "" - CLASSIFY BinaryTerm ISA Expression - RELATION first[BinaryTerm*Expression] [UNI] - RELATION second[BinaryTerm*Expression] [UNI] + CLASSIFY BinaryTerm ISA Term + RELATION first[BinaryTerm*Term] [UNI] + RELATION second[BinaryTerm*Term] [UNI] RELATION operator[BinaryTerm*Operator] [UNI] CONCEPT UnaryTerm "" - CLASSIFY UnaryTerm ISA Expression - RELATION arg[UnaryTerm*Expression] [UNI] + CLASSIFY UnaryTerm ISA Term + RELATION arg[UnaryTerm*Term] [UNI] RELATION operator[UnaryTerm*Operator] [UNI] - CONCEPT AtomValue "A value can exist on it's own, without having one or more concepts, where it is a value of an atom in it." + CONCEPT AtomValue "A value can exist on its own, without having one or more concepts, where it is a value of an atom in it." + REPRESENT AtomValue TYPE ALPHANUMERIC RELATION singleton[Singleton*AtomValue] [UNI] CONCEPT "V" "The cartesian product." - CLASSIFY "V" ISA Expression + CLASSIFY "V" ISA Term RELATION userSrc["V"*Concept] [UNI] - RELATION userTrg["V"*Concept] [UNI] + RELATION userTgt["V"*Concept] [UNI] - CONCEPT Epsilon "An expression between two concepts that have an generalisation relation between them" - CLASSIFY Epsilon ISA Expression + CONCEPT Epsilon "An term between two concepts that have an generalisation relation between them" + CLASSIFY Epsilon ISA Term RELATION userCpt[Epsilon*Concept] [UNI] - CONCEPT "I" "The identity expression on a concept." + CONCEPT "I" "The identity term on a concept." CLASSIFY "I" ISA Epsilon CLASSIFY Equivalence ISA BinaryTerm CLASSIFY Inclusion ISA BinaryTerm - --RELATION repr[Expression*Representation] [UNI, TOT, INJ] + --RELATION repr[Term*Representation] [UNI, TOT, INJ] --The relation repr, i.e. the representation of terms, is supplied by a spreadsheet or by the meatgrinder. Make sure it is injective. - CLASSIFY Singleton ISA Expression - CLASSIFY BindedRelation ISA Expression + CLASSIFY Singleton ISA Term + CLASSIFY BindedRelation ISA Term CLASSIFY Converse ISA UnaryTerm CLASSIFY KleeneStar ISA UnaryTerm CLASSIFY KleenePlus ISA UnaryTerm @@ -80,14 +80,14 @@ PATTERN "Expression definitions" CLASSIFY RightResidual ISA BinaryTerm ENDPATTERN -RELATION showADL[Expression*ShowADL] [UNI,TOT] +RELATION showADL[Term*ShowADL] [UNI] -- TODO should be TOT also, but this is TODO for ObjectDefs REPRESENT ShowADL TYPE BIGALPHANUMERIC ---HJI20161004: This execEngine rule doesn't work, because of the ';'-characters that may be in the ShowADL expression +--HJI20161004: This execEngine rule doesn't work, because of the ';'-characters that may be in the ShowADL term ROLE ExecEngine MAINTAINS "del unused ShowADL" RULE "del unused ShowADL" : I[ShowADL] |- showADL~;showADL - MEANING "A ShowADL without Expression will be removed." + MEANING "A ShowADL without Term will be removed." VIOLATION ( TXT "{EX}_;DelAtom_;ShowADL_;", SRC I ) -VIEW Expression : Expression(showADL) +VIEW Term : Term(showADL) {- I can't get the following to work... Grrr! PATTERN "Type graph" diff --git a/AmpersandData/FormalAmpersand/Expressions.docadl b/AmpersandData/FormalAmpersand/Terms.docadl similarity index 97% rename from AmpersandData/FormalAmpersand/Expressions.docadl rename to AmpersandData/FormalAmpersand/Terms.docadl index 871d54b134..0c9992b6b2 100644 --- a/AmpersandData/FormalAmpersand/Expressions.docadl +++ b/AmpersandData/FormalAmpersand/Terms.docadl @@ -39,12 +39,12 @@ Likewise, we will use type-term cod(t) to represent the set of atoms in the codo The set of atoms associated with a concept c will be represented by the type-term pop(c). +} -PURPOSE RELATION repr[Expression*Representation] +PURPOSE RELATION repr[Term*Representation] {+In order to define type-terms, we must have an injective representation for terms. With that representation, the system can construct all kinds of type terms from which the originating term can be determined. +} -PURPOSE RELATION dom[Expression*TypeTerm] +PURPOSE RELATION dom[Term*TypeTerm] {+In order to associate a type-term dom(t) with every term t, we use the function dom. Its totality is maintained automatically by rule "dom is total". +} @@ -55,7 +55,7 @@ the system uses a representation from which the original term can be reconstruct Momentarily, this hinges on the representation, which is specified by hand or by the meatgrinder. +} -PURPOSE RELATION cod[Expression*TypeTerm] +PURPOSE RELATION cod[Term*TypeTerm] {+In order to associate a type-term cod(t) with every term t, we use the function cod. Its totality is maintained automatically by rule "cod is total". +} @@ -75,7 +75,7 @@ PURPOSE RELATION sub[TypeTerm*TypeTerm] {+ +} -PURPOSE RELATION typehalf[Expression*Signature] +PURPOSE RELATION typehalf[Term*Signature] {+ +} diff --git a/AmpersandData/PrototypeContext/.ampersand b/AmpersandData/PrototypeContext/.ampersand new file mode 100644 index 0000000000..b787abfa50 --- /dev/null +++ b/AmpersandData/PrototypeContext/.ampersand @@ -0,0 +1 @@ +PrototypeContext.adl \ No newline at end of file diff --git a/AmpersandData/PrototypeContext/Interfaces.adl b/AmpersandData/PrototypeContext/Interfaces.adl index 566b12f3ea..e63b5d9f3f 100644 --- a/AmpersandData/PrototypeContext/Interfaces.adl +++ b/AmpersandData/PrototypeContext/Interfaces.adl @@ -3,6 +3,10 @@ CONTEXT PrototypeFramework IN ENGLISH CONCEPT PF_Interface "" REPRESENT PF_Interface TYPE OBJECT + -- RELATION label[PF_Interface*PF_Label] needs to be TOT because the prototype framework depends on having an interface label + -- The identitier of the PF_Interface itself can contain escaped characters, e.g. "Interface_32_label" + -- We want to show the user "Interface label" instead + -- The label is added to the population file by the meatgrinder using the Proto build recipe RELATION label[PF_Interface*PF_Label] [UNI,TOT] REPRESENT PF_Label TYPE ALPHANUMERIC @@ -12,7 +16,7 @@ CONTEXT PrototypeFramework IN ENGLISH RELATION isPublic[PF_Interface*PF_Interface] [PROP] MEANING "This property states that an interface is accessible for all roles (i.e. public)" - -- Cannot enfore this rule yet, because ExecEngine is still required to add missing roles + -- Cannot enforce this rule yet, because ExecEngine is still required to add missing roles -- RULE "Public interface integrity" : isPublic;V[PF_Interface*Role] |- pf_ifcRoles -- EQUIVALENCE pf_ifcRoles[PF_Interface*Role] == isPublic;V[PF_Interface*Role] diff --git a/AmpersandData/PrototypeContext/Interfaces.ifc b/AmpersandData/PrototypeContext/Interfaces.ifc index 45aebbc3e4..bf6f95ea3c 100644 --- a/AmpersandData/PrototypeContext/Interfaces.ifc +++ b/AmpersandData/PrototypeContext/Interfaces.ifc @@ -1,11 +1,16 @@ CONTEXT PrototypeFramework IN ENGLISH - INTERFACE "List all interfaces" FOR Administrator: "_SESSION";V[SESSION*PF_Interface] cRud BOX
+ -- The following population is required because RELATION label[PF_Interface*PF_Label] must be total. + -- That declaration is found in Interfaces.adl + POPULATION label[PF_Interface*PF_Label] CONTAINS + [ ("List_32_all_32_interfaces", "List_32_all_32_interfaces") ] + INTERFACE "List all interfaces" FOR Administrator: "_SESSION";V[SESSION*PF_Interface] cRud BOX
[ "Interface" : I cRud , "Label" : label cRud , "Is public" : isPublic cRud , "Is API" : isAPI cRud , "Nav items" : ifc~ cRud + , "For roles" : pf_ifcRoles cRud ] INTERFACE "Edit interface" FOR Administrator : I[PF_Interface] BOX diff --git a/AmpersandData/PrototypeContext/Navbar.adl b/AmpersandData/PrototypeContext/Navbar.adl index dda3c88494..3a7b83970e 100644 --- a/AmpersandData/PrototypeContext/Navbar.adl +++ b/AmpersandData/PrototypeContext/Navbar.adl @@ -4,6 +4,10 @@ CONTEXT PrototypeFramework IN ENGLISH CONCEPT PF_NavMenuItem "" REPRESENT PF_NavMenuItem TYPE OBJECT + -- RELATION label[PF_NavMenuItem*PF_Label] needs to be TOT because the prototype framework depends on having an interface label + -- The identitier of the PF_NavMenuItem itself is a generated UUID, e.g. "PF__NavMenuItem_1550521084_00490187" + -- We want to show the user a navigation label instead + -- The navigation menu items and its label (and other attributes) are added by the prototype framework during application installation RELATION label[PF_NavMenuItem*PF_Label] [UNI,TOT] MEANING "The human readable text that represents the navbar item and is shown to the user" CONCEPT PF_Label "" diff --git a/AmpersandData/PrototypeContext/Navbar.ifc b/AmpersandData/PrototypeContext/Navbar.ifc index 0e9a25e37d..15d3417a45 100644 --- a/AmpersandData/PrototypeContext/Navbar.ifc +++ b/AmpersandData/PrototypeContext/Navbar.ifc @@ -5,12 +5,17 @@ CONTEXT PrototypeFramework IN ENGLISH --[ADMIN INTERFACES to adapt the menus]-------------------------------------------------------- INTERFACE "Edit navigation menu" FOR Administrator: "_SESSION";V[SESSION*PF_NavMenu] INTERFACE "Edit menu item" + -- The following population is required because RELATION label[PF_Interface*PF_Label] must be total. + -- That declaration is found in Interfaces.adl + POPULATION label[PF_Interface*PF_Label] CONTAINS + [ ("Edit_32_navigation_32_menu", "Edit_32_navigation_32_menu") ] + INTERFACE "Edit menu item" FOR Administrator: I[PF_NavMenuItem] cRud BOX [ "Label" : label , "Parent" : isSubItemOf cRUd - , "Items" : isSubItemOf~ CRuD BOX
+ , "Items" : isSubItemOf~ CRuD BOX
[ "Item" : I LINKTO INTERFACE "Edit menu item" - , "# " : seqNr cRUd + , "Order" : seqNr cRUd , "Visible" : isVisible cRUd , "Label" : label cRUd , "Roles" : pf_navItemRoles cRud @@ -29,5 +34,4 @@ CONTEXT PrototypeFramework IN ENGLISH , "url" : url , "parent" : isSubItemOf ] - ENDCONTEXT \ No newline at end of file diff --git a/AmpersandData/PrototypeContext/PrototypeContext.adl b/AmpersandData/PrototypeContext/PrototypeContext.adl index 54d50e7c69..21115008dc 100644 --- a/AmpersandData/PrototypeContext/PrototypeContext.adl +++ b/AmpersandData/PrototypeContext/PrototypeContext.adl @@ -1,4 +1,4 @@ -CONTEXT PrototypeContxt IN ENGLISH +CONTEXT PrototypeFramework IN ENGLISH INCLUDE "Interfaces.adl" INCLUDE "Interfaces.ifc" diff --git a/AmpersandData/FormalAmpersand/AST.ifc b/AmpersandData/Repo Interfaces/AST.ifc similarity index 80% rename from AmpersandData/FormalAmpersand/AST.ifc rename to AmpersandData/Repo Interfaces/AST.ifc index ac41d1a8be..3eaacef03b 100644 --- a/AmpersandData/FormalAmpersand/AST.ifc +++ b/AmpersandData/Repo Interfaces/AST.ifc @@ -25,11 +25,11 @@ BOX ] ] -INTERFACE "Context" FOR Ampersand : I[Context] +INTERFACE Context FOR Ampersand : I[Context] BOX [ "About" : I BOX [ "name" : name[Context*ContextName] --- , "versionInfo" : versionInfo + , "versionInfo" : versionInfo , "valid~" : valid[Rule*Context]~ ] , "Patterns" : context[Pattern*Context]~ BOX @@ -44,7 +44,7 @@ BOX , "Relations" : declaredIn[Relation*Context]~ LINKTO INTERFACE "Relation" , "Roles" : allRoles[Context*Role] -- , "allConjuncts" : allConjuncts[Context*Conjunct] - , "Rules" : allRules[Context*Rule] INTERFACE "Rule" + , "Rules" : context[Rule*Context]~ INTERFACE "Rule" ] INTERFACE IsaTree FOR Ampersand : I[Concept] BOX
@@ -56,21 +56,21 @@ INTERFACE Pattern FOR Ampersand : I[Pattern] BOX [ Pattern : name[Pattern*PatternName] cRud , "context" : context[Pattern*Context] cRud , "Relations" : declaredIn[Relation*Pattern]~ LINKTO INTERFACE "Relation" - , "rules" : allRules[Pattern*Rule] cRud + , "rules" : patRules[Pattern*Rule] cRud , "purpose" : purpose[Pattern*Purpose] cRud ] INTERFACE "Rule" FOR Ampersand : I[Rule] BOX [ "name" : name[Rule*RuleName] , "valid" : valid[Rule*Context] - , "context" : allRules[Context*Rule]~ + , "context" : context[Rule*Context] -- , "originatesFrom~" : originatesFrom[Conjunct*Rule]~ - , "pattern" : allRules[Pattern*Rule]~ + , "pattern" : patRules[Pattern*Rule]~ -- , "maintains~ (Role)" : maintains[Role*Rule]~ -- , "tgtConcept" : tgtConcept[Rule*Concept] -- , "srcConcept" : srcConcept[Rule*Concept] - , "formalExpression" : formalExpression[Rule*Expression] - , "sign" : formalExpression[Rule*Expression];sign[Expression*Signature] + , "formalTerm" : formalTerm[Rule*Term] + , "sign" : formalTerm[Rule*Term];sign[Term*Signature] -- , "maintains~ (Plug)" : maintains[Plug*Rule]~ -- , "origin" : origin[Rule*Origin] -- , "rrviols" : rrviols @@ -83,7 +83,7 @@ BOX [ "name" : name[Rule*RuleName] INTERFACE "Conjunct" FOR Ampersand : I[Conjunct] BOX [ "ID" : I -- , "originatesFrom" : originatesFrom[Conjunct*Rule] --- , "conjunct" : conjunct[Conjunct*Expression] +-- , "conjunct" : rc_conjunct[Conjunct*Term] ] INTERFACE "Concept" FOR Ampersand : I[Concept] BOX [ concept : I @@ -94,8 +94,8 @@ INTERFACE "Concept" FOR Ampersand : I[Concept] BOX , "gengen~" : gengen[Isa*Concept]~ , "genspc~" : genspc[Isa*Concept]~ -- , "rootConcept~" : rootConcept~ - , "src of expression~" : (sign[Expression*Signature];src[Signature*Concept])~ - , "tgt of expression~" : (sign[Expression*Signature];tgt[Signature*Concept])~ + , "src of term~" : (sign[Term*Signature];src[Signature*Concept])~ + , "tgt of term~" : (sign[Term*Signature];tgt[Signature*Concept])~ , "src of sign~" : src[Signature*Concept]~ , "tgt of sign~" : tgt[Signature*Concept]~ -- , "concept~" : concept~ @@ -103,19 +103,19 @@ INTERFACE "Concept" FOR Ampersand : I[Concept] BOX -- , "in" : in[Concept*Plug] ] -INTERFACE Expression FOR Ampersand : I[Expression] cRud -BOX [ up : first~ \/ second~ \/ arg~ cRud LINKTO INTERFACE Expression - , expression: I[Expression] cRud LINKTO INTERFACE Expression - , first : first[BinaryTerm*Expression] cRud LINKTO INTERFACE Expression +INTERFACE Term FOR Ampersand : I[Term] cRud +BOX [ up : first~ \/ second~ \/ arg~ cRud LINKTO INTERFACE Term + , term: I[Term] cRud LINKTO INTERFACE Term + , first : first[BinaryTerm*Term] cRud LINKTO INTERFACE Term , binaryOperator : operator[BinaryTerm*Operator] cRud - , second : second[BinaryTerm*Expression] cRud LINKTO INTERFACE Expression - , arg : arg[UnaryTerm*Expression] cRud LINKTO INTERFACE Expression + , second : second[BinaryTerm*Term] cRud LINKTO INTERFACE Term + , arg : arg[UnaryTerm*Term] cRud LINKTO INTERFACE Term , unaryOperator : operator[UnaryTerm*Operator] cRud - , "defines rule" : formalExpression[Rule*Expression]~ cRud + , "defines rule" : formalTerm[Rule*Term]~ cRud , bind : bind[BindedRelation*Relation] cRud LINKTO INTERFACE Relation , singleton : singleton[Singleton*AtomValue] cRud -- , "user defined src" : userSrc["V"*Concept]cRud --- , "user defined trg" : userTrg["V"*Concept]cRud +-- , "user defined trg" : userTgt["V"*Concept]cRud -- , "user defined cpt" : userCpt["I"*Concept]cRud ] INTERFACE Signature FOR Ampersand : I[Signature] cRud @@ -123,21 +123,24 @@ BOX [ Signature: I[Signature] , src : src[Signature*Concept] LINKTO INTERFACE "Concept" , tgt : tgt[Signature*Concept] LINKTO INTERFACE "Concept" , "sign~ (Relation)" : sign[Relation*Signature]~ LINKTO INTERFACE "Relation" - , "sign~ (Rule)" : sign[Expression*Signature]~;formalExpression[Rule*Expression]~ LINKTO INTERFACE "Rule" + , "sign~ (Rule)" : sign[Term*Signature]~;formalTerm[Rule*Term]~ LINKTO INTERFACE "Rule" ] - INTERFACE PropertyRule FOR Ampersand : I[PropertyRule] BOX [ "declaredthrough": declaredthrough[PropertyRule*Property] , "propertyRule~" : propertyRule[Relation*PropertyRule]~ LINKTO INTERFACE "Relation" ] - - INTERFACE Isa FOR Ampersand : I[Isa] -BOX [ "gens~" : gens[Context*Isa]~ - , "gengen" : gengen[Isa*Concept] - , "genspc" : genspc[Isa*Concept] +BOX [ "context" : context[Isa*Context] + , "gengen" : gengen[Isa*Concept] + , "genspc" : genspc[Isa*Concept] + ] + +INTERFACE IsE FOR Ampersand : I[IsE] +BOX [ "context" : context[IsE*Context] + , "gengen" : gengen[IsE*Concept] + , "genspc" : genspc[IsE*Concept] ] INTERFACE Relation FOR Ampersand : I[Relation] @@ -184,10 +187,10 @@ BOX [ "table" : table -} --INTERFACE Role FOR Ampersand : I[Role] --BOX [ "name" : name[Role*RoleName] --- , "interfaces" : interfaces[Role*Interface] +-- , "interfaces" : ifcRoles[Interface*Role]~ -- ] --INTERFACE Interface FOR Ampersand : I[Interface] ---BOX [ "interfaces~" : interfaces[Role*Interface]~ +--BOX [ "interfaces~" : ifcRoles[Interface*Role] -- ] ENDCONTEXT diff --git a/AmpersandData/FormalAmpersand/Atoms.ifc b/AmpersandData/Repo Interfaces/Atoms.ifc similarity index 100% rename from AmpersandData/FormalAmpersand/Atoms.ifc rename to AmpersandData/Repo Interfaces/Atoms.ifc diff --git a/AmpersandData/FormalAmpersand/Contexts.ifc b/AmpersandData/Repo Interfaces/Contexts.ifc similarity index 91% rename from AmpersandData/FormalAmpersand/Contexts.ifc rename to AmpersandData/Repo Interfaces/Contexts.ifc index c385bf6099..cff398cfd9 100644 --- a/AmpersandData/FormalAmpersand/Contexts.ifc +++ b/AmpersandData/Repo Interfaces/Contexts.ifc @@ -13,11 +13,11 @@ BOX ] -INTERFACE "Context" FOR Ampersand : I[Context] +INTERFACE Context FOR Ampersand : I[Context] BOX [ "About" : I BOX [ "name" : name[Context*ContextIdentifier] --- , "versionInfo" : versionInfo + , "versionInfo" : versionInfo -- , "owner" : owner[Context*Account] , "valid rules" : valid[Rule*Context]~ , "valid relations" : valid[Relation*Context]~ @@ -43,7 +43,7 @@ BOX ] , "Roles" : allRoles[Context*Role] -- , "allConjuncts" : allConjuncts[Context*Conjunct] --- , "Rules" : allRules[Context*Rule] INTERFACE "Rule" +-- , "Rules" : context[Rule*Context]~ INTERFACE "Rule" ] ENDCONTEXT diff --git a/AmpersandData/FormalAmpersand/DomainAnalysis.ifc b/AmpersandData/Repo Interfaces/DomainAnalysis.ifc similarity index 100% rename from AmpersandData/FormalAmpersand/DomainAnalysis.ifc rename to AmpersandData/Repo Interfaces/DomainAnalysis.ifc diff --git a/AmpersandData/FormalAmpersand/Expressions.ifc b/AmpersandData/Repo Interfaces/Expressions.ifc similarity index 98% rename from AmpersandData/FormalAmpersand/Expressions.ifc rename to AmpersandData/Repo Interfaces/Expressions.ifc index d96873aa34..d2c329d985 100644 --- a/AmpersandData/FormalAmpersand/Expressions.ifc +++ b/AmpersandData/Repo Interfaces/Expressions.ifc @@ -1,5 +1,5 @@ CONTEXT AST IN ENGLISH -INCLUDE "Expressions.adl" +INCLUDE "Terms.adl" INCLUDE "Views.adl" INCLUDE "Atoms.adl" diff --git a/AmpersandData/FormalAmpersand/IS.ifc b/AmpersandData/Repo Interfaces/IS.ifc similarity index 77% rename from AmpersandData/FormalAmpersand/IS.ifc rename to AmpersandData/Repo Interfaces/IS.ifc index e67ee7bf9c..2911140b29 100644 --- a/AmpersandData/FormalAmpersand/IS.ifc +++ b/AmpersandData/Repo Interfaces/IS.ifc @@ -3,13 +3,13 @@ CONTEXT RAP IN ENGLISH LATEX INTERFACE ruleOverview : I[ONE] BOX [ rules : V[ONE*Rule] BOX [ rule : I - , expression : characteristic + , term : characteristic ] ] INTERFACE newRule (characteristic, meaning["Rule"*"NatLang"], purpose["Rule"*"NatLang"]): I[Rule] BOX [ rule : I - , expression : characteristic + , term : characteristic ] ENDCONTEXT \ No newline at end of file diff --git a/AmpersandData/FormalAmpersand/Rules.ifc b/AmpersandData/Repo Interfaces/Rules.ifc similarity index 96% rename from AmpersandData/FormalAmpersand/Rules.ifc rename to AmpersandData/Repo Interfaces/Rules.ifc index 2bb2d9008c..b42b5b18e1 100644 --- a/AmpersandData/FormalAmpersand/Rules.ifc +++ b/AmpersandData/Repo Interfaces/Rules.ifc @@ -32,7 +32,7 @@ BOX , rules : V[SESSION*Rule] BOX
[ name : name , signature : sign - , term : term[Rule*Expression] + , term : term[Rule*Term] , meaning : meaning , purpose : purpose ] @@ -70,4 +70,6 @@ BOX [ name : name , target : target ] +VIEW Rule: Rule(name[Rule*RuleName]) + ENDCONTEXT \ No newline at end of file diff --git a/AmpersandData/FormalAmpersand/Tables.ifc b/AmpersandData/Repo Interfaces/Tables.ifc similarity index 100% rename from AmpersandData/FormalAmpersand/Tables.ifc rename to AmpersandData/Repo Interfaces/Tables.ifc diff --git a/AmpersandData/FormalAmpersand/TypeChecking.ifc b/AmpersandData/Repo Interfaces/TypeChecking.ifc similarity index 92% rename from AmpersandData/FormalAmpersand/TypeChecking.ifc rename to AmpersandData/Repo Interfaces/TypeChecking.ifc index 11889b7d6e..1cc83d4df0 100644 --- a/AmpersandData/FormalAmpersand/TypeChecking.ifc +++ b/AmpersandData/Repo Interfaces/TypeChecking.ifc @@ -3,15 +3,6 @@ INCLUDE "TypeChecking.adl" INCLUDE "Views.adl" INCLUDE "Terms.xlsx" -INTERFACE Contexts (valid,relations) : "_SESSION" -BOX - [ "" : V[SESSION*Context] - BOX [ context : I - , "valid rules" : valid~ - , relations : relations - ] - ] - INTERFACE "Domain Anaylsis" (name[Relation*Identifier], source, target) : "_SESSION" BOX [ relations : V[SESSION*Relation] diff --git a/AmpersandData/FormalAmpersand/Views.ifc b/AmpersandData/Repo Interfaces/Views.ifc similarity index 100% rename from AmpersandData/FormalAmpersand/Views.ifc rename to AmpersandData/Repo Interfaces/Views.ifc diff --git a/AmpersandData/FormalAmpersand/admin_interfaces.ifc b/AmpersandData/Repo Interfaces/admin_interfaces.ifc similarity index 100% rename from AmpersandData/FormalAmpersand/admin_interfaces.ifc rename to AmpersandData/Repo Interfaces/admin_interfaces.ifc diff --git a/AmpersandData/FormalAmpersand/student_AST_interfaces.ifc b/AmpersandData/Repo Interfaces/student_AST_interfaces.ifc similarity index 92% rename from AmpersandData/FormalAmpersand/student_AST_interfaces.ifc rename to AmpersandData/Repo Interfaces/student_AST_interfaces.ifc index 50f0bd4e5f..580ccac5d4 100644 --- a/AmpersandData/FormalAmpersand/student_AST_interfaces.ifc +++ b/AmpersandData/Repo Interfaces/student_AST_interfaces.ifc @@ -22,14 +22,14 @@ BOX ["loaded into Atlas" : V[ONE*Context] --css refers to this interface INTERFACE "Diagnosis" FOR Student: I[ONE] -BOX [ "concepts without definition": V[ONE*Concept];(-(cptdf;cptdf~) /\ I) -- THIS IS A THIRD CHOICE expression!! +BOX [ "concepts without definition": V[ONE*Concept];(-(cptdf;cptdf~) /\ I) -- THIS IS A THIRD CHOICE term!! --SECOND CHOICE: V[ONE*Concept];-(cptdf;cptdf~) <= results in SQL with empty atoms => see test2 below in comments --FIRST CHOICE: -(V[ONE*Blob];cptdf~) <= results in:fatal (module RelBinGenSQL, Prototype v2.2.0.2100M (lib: Ampersand v2.2.0.578:579M)) A_Concept ONE may not be represented in SQL , "relations without MEANING": V[ONE*Relation];(-(decMean;decMean~) /\ I) -- -(V[ONE*Blob];decMean~) , "RULEs without MEANING": V[ONE*Rule];(-(meaning;meaning~) /\ I) -- -(V[ONE*Blob];meaning~) , "populated relations": V[ONE*Pair];decpopu~ , "unpopulated relations": V[ONE*Relation];(-(decpopu;decpopu~) /\ I) -- -(V[ONE*Pair];decpopu~) ---INCORRECT , "relations not in any RULE (provided that a RULE exists)": V[ONE*Rule];(I[Rule] /\ -I[PropertyRule]);-(formalExpression;relsInPlug;reldcl) +--INCORRECT , "relations not in any RULE (provided that a RULE exists)": V[ONE*Rule];(I[Rule] /\ -I[PropertyRule]);-(formalTerm;relsInPlug;reldcl) ] INTERFACE "Syntax error" FOR Student: I[ParseError] @@ -170,7 +170,7 @@ BOX ["PURPOSEs" :cptpurpose ,"more generic concepts" : genspc~;gengen \/ genspc~;gengen;genspc~;gengen \/ genspc~;gengen;genspc~;gengen;genspc~;gengen --TODO closure -- ,"comparable atoms":order;order~;cptos BOX ["atom":atomvalue, "of concept":cptos~] ,"used in relations": (decsgn;(src \/ tgt))~ - ,"used in RULEs": (relsgn;(src \/ tgt))~;(formalExpression;relsInPlug)~;(I[Rule] /\ -I[PropertyRule]) + ,"used in RULEs": (relsgn;(src \/ tgt))~;(formalTerm;relsInPlug)~;(I[Rule] /\ -I[PropertyRule]) ,"diagram" : cptpic ] INTERFACE "Atom"(cptos) FOR Student: I[Atom];atomvalue~ @@ -184,14 +184,14 @@ BOX ["PURPOSEs" :purpose ,"properties" :propertyRule;declaredthrough ,"from PATTERN" :ptdcs~ ,"POPULATION" :decpopu BOX ["source":left , "target":right] --select existing atoms only! - ,"used in RULEs": (formalExpression;relsInPlug;reldcl)~;(I[Rule] /\ -I[PropertyRule]) + ,"used in RULEs": (formalTerm;relsInPlug;reldcl)~;(I[Rule] /\ -I[PropertyRule]) ] INTERFACE "RULE" FOR Student: I[Rule] BOX ["PURPOSEs" :purpose ,"MEANING" :meaning ,"name" :rrnm - ,"assertion" :formalExpression - ,"uses":formalExpression;relsInPlug BOX ["relation":reldcl, "with properties": reldcl;propertyRule;declaredthrough, "source":relsgn;src, "target":relsgn;tgt] + ,"assertion" :formalTerm + ,"uses":formalTerm;relsInPlug BOX ["relation":reldcl, "with properties": reldcl;propertyRule;declaredthrough, "source":relsgn;src, "target":relsgn;tgt] ,"in PATTERN":ptrls~ ,"diagram" : rrpic ] diff --git a/AmpersandData/FormalAmpersand/ADLTool.adl b/AmpersandData/Semantics/ADLTool.adl similarity index 100% rename from AmpersandData/FormalAmpersand/ADLTool.adl rename to AmpersandData/Semantics/ADLTool.adl diff --git a/AmpersandData/FormalAmpersand/AST.xlsx b/AmpersandData/Semantics/AST.xlsx similarity index 100% rename from AmpersandData/FormalAmpersand/AST.xlsx rename to AmpersandData/Semantics/AST.xlsx diff --git a/AmpersandData/FormalAmpersand/Atoms.adl b/AmpersandData/Semantics/Atoms.adl similarity index 92% rename from AmpersandData/FormalAmpersand/Atoms.adl rename to AmpersandData/Semantics/Atoms.adl index c47e208866..019b4ce075 100644 --- a/AmpersandData/FormalAmpersand/Atoms.adl +++ b/AmpersandData/Semantics/Atoms.adl @@ -1,6 +1,12 @@ CONTEXT AST IN ENGLISH INCLUDE "Concepts.adl" +PATTERN Pairs + RELATION in[Pair*Relation] [UNI,TOT] + RELATION lAtom[Pair*Atom] [UNI,TOT] + RELATION rAtom[Pair*Atom] [UNI,TOT] +ENDPATTERN + PATTERN Atoms RULE "Identifiability of concepts": name;name~ |- I[Concept] VIOLATION (TXT "The name \"", SRC I, TXT "\" is already in use") diff --git a/AmpersandData/FormalAmpersand/Atoms.docadl b/AmpersandData/Semantics/Atoms.docadl similarity index 100% rename from AmpersandData/FormalAmpersand/Atoms.docadl rename to AmpersandData/Semantics/Atoms.docadl diff --git a/AmpersandData/Semantics/Atoms.xlsx b/AmpersandData/Semantics/Atoms.xlsx new file mode 100644 index 0000000000..aa746d1d53 Binary files /dev/null and b/AmpersandData/Semantics/Atoms.xlsx differ diff --git a/AmpersandData/Semantics/AtomsAsShouldBe.adl b/AmpersandData/Semantics/AtomsAsShouldBe.adl new file mode 100644 index 0000000000..6bdf627d17 --- /dev/null +++ b/AmpersandData/Semantics/AtomsAsShouldBe.adl @@ -0,0 +1,108 @@ +CONTEXT AST IN ENGLISH +INCLUDE "Concepts.adl" +INCLUDE "Atoms.xlsx" + +PATTERN Pairs + RELATION in[Pair*Relation] [UNI,TOT] + RELATION lAtom[Pair*Atom] [UNI,TOT] + RELATION rAtom[Pair*Atom] [UNI,TOT] +ENDPATTERN + +PATTERN "Compute sources, targets, and populations" + RELATION sources[Relation*Concept] -- meant for: sources = source;isaStar~ + RELATION targets[Relation*Concept] -- meant for: targets = target;isaStar~ + + ROLE ExecEngine MAINTAINS isaRelInsSrc, isaRelInsTgt, isaRelDelSrc, isaRelDelTgt + RULE isaRelInsSrc: source;isaStar~ |- sources + VIOLATION (TXT "{EX} InsPair;sources;Relation;", SRC I, TXT ";Concept;", TGT I) + RULE isaRelInsTgt: target;isaStar~ |- targets + VIOLATION (TXT "{EX} InsPair;targets;Relation;", SRC I, TXT ";Concept;", TGT I) + RULE isaRelDelSrc: sources |- source;isaStar~ + VIOLATION (TXT "{EX} DelPair;sources;Relation;", SRC I, TXT ";Concept;", TGT I) + RULE isaRelDelTgt: targets |- target;isaStar~ + VIOLATION (TXT "{EX} DelPair;targets;Relation;", SRC I, TXT ";Concept;", TGT I) + + RELATION pop[Atom*Concept] + MEANING "If a pop c, we say that atom a is in the population of concept c." + + PURPOSE RULE specialization + {+Specialization has the consequence that an atom is not necessarily an instance of one concept only. + If limes are citrus fruits, then every lime is not only lime but a citrus fruit as well. + +} + RULE specialization : pop;genspc~;gengen |- pop + MEANING "Every instance of a specialized concept is an instance of the generic concept too." + + ROLE ExecEngine MAINTAINS insPop, delPop + RULE insPop : lAtom~;in;source;isaStar \/ rAtom~;in;target;isaStar |- pop + VIOLATION (TXT "{EX} InsPair;pop;Atom;", SRC I, TXT ";Concept;", TGT I) + RULE delPop : pop |- lAtom~;in;source;isaStar \/ rAtom~;in;target;isaStar + VIOLATION (TXT "{EX} DelPair;pop;Atom;", SRC I, TXT ";Concept;", TGT I) +ENDPATTERN + +INTERFACE Overzicht : "_SESSION"[SESSION] +BOX + [ relations : V[SESSION*Relation] + BOX
+ [ relation : I[Relation] + , name : name + , source : source + , target : target + , "pair(s)" : in~ + , sources : sources + , targets : targets + ] + , concepts :V[SESSION*Concept] + BOX
+ [ id : I[Concept] + , name : name + , "isa" : isa +-- , "isa+" : isaPlus +-- , "isa*" : isaStar + , "isa~" : isa~ +-- , "isa+~" : isaPlus~ +-- , "isa*~" : isaStar~ + , atoms : pop~ cRud + ] + , pairs : V[SESSION*Pair] + BOX
+ [ Pair : I + , lAtom : lAtom + , rAtom : rAtom + , in : in[Pair*Relation] + , field : pair~ + ] + ] + +ROLE ExecEngine MAINTAINS InsConcept, DelConcept +RULE InsConcept : I[ConceptName] |- name~;I[Concept];name +VIOLATION (TXT "{EX} InsPair;name;Concept;", SRC I, TXT ";ConceptName;", SRC I) +RULE DelConcept : I[Concept] |- name;I[ConceptName];name~ +VIOLATION ( TXT "{EX} DelAtom;ConceptName;", SRC I + , TXT "{EX} DelAtom;Concept;", SRC I + ) + +--VIEW Atom : Atom(repr) -- When observing an atom, its representation is what you can see. +REPRESENT Atom TYPE ALPHANUMERIC +-- VIEW Concept : Concept(name) -- already in Concepts.adl +VIEW Pair : Pair(TXT "(",lAtom,TXT ",",rAtom,TXT ")") +-- VIEW Relation : Relation(name,TXT "[",source;name,TXT "*",target;name,TXT "]") -- already in Terms.adl + +INTERFACE ConceptWithSiblings(name[Concept*ConceptName],isa) : I[Concept] +BOX [ name : name + , generalizations : isa + , specializations : isa~ + ] + +INTERFACE Pair(lAtom,rAtom,in[Pair*Relation]) : I[Pair] +BOX [ "relation(s)" : in[Pair*Relation] + , lAtom : lAtom + , rAtom : rAtom + ] + +INTERFACE Relation(name[Relation*RelationName],source,target) : I[Relation] +BOX [ name : name + , source : source + , target : target + ] + +ENDCONTEXT \ No newline at end of file diff --git a/AmpersandData/FormalAmpersand/AtomsWithRepr.adl b/AmpersandData/Semantics/AtomsWithRepr.adl similarity index 100% rename from AmpersandData/FormalAmpersand/AtomsWithRepr.adl rename to AmpersandData/Semantics/AtomsWithRepr.adl diff --git a/AmpersandData/FormalAmpersand/Authorisation.adl b/AmpersandData/Semantics/Authorisation.adl similarity index 100% rename from AmpersandData/FormalAmpersand/Authorisation.adl rename to AmpersandData/Semantics/Authorisation.adl diff --git a/AmpersandData/FormalAmpersand/Contexts.xlsx b/AmpersandData/Semantics/Contexts.xlsx similarity index 100% rename from AmpersandData/FormalAmpersand/Contexts.xlsx rename to AmpersandData/Semantics/Contexts.xlsx diff --git a/AmpersandData/FormalAmpersand/ContextsTry.xlsx b/AmpersandData/Semantics/ContextsTry.xlsx similarity index 100% rename from AmpersandData/FormalAmpersand/ContextsTry.xlsx rename to AmpersandData/Semantics/ContextsTry.xlsx diff --git a/AmpersandData/Semantics/Dockerfile b/AmpersandData/Semantics/Dockerfile new file mode 100644 index 0000000000..441c721f2d --- /dev/null +++ b/AmpersandData/Semantics/Dockerfile @@ -0,0 +1,45 @@ +# This script is meant to build from the root directory of your RAP-repo. +# Ampersand compiler is also needed for RAP4 to compile student scripts + +FROM ampersandtarski/prototype-framework:v1.8.5 + +# Install docker, so students can run their prototypes +RUN apt-get update \ + && apt-get install -y \ + apt-transport-https \ + ca-certificates \ + curl \ + gnupg-agent \ + software-properties-common +RUN curl -fsSL https://download.docker.com/linux/debian/gpg | apt-key add - +RUN add-apt-repository "deb [arch=amd64] https://download.docker.com/linux/debian $(lsb_release -cs) stable" +# We only need the docker-cli because we connect to the docker deamon on the host machine using a volume bind to docker.sock +RUN apt-get update \ + && apt-get install -y docker-ce-cli + +# We use graphviz to create drawings in diagnosis and functional specifications. +# and we need epstopdf to create pdf files for images +RUN apt-get update && apt-get install -y graphviz + +# Copy Ampersand compiler +COPY --from=ampersandtarski/ampersand:local /bin/ampersand /usr/local/bin +RUN chmod +x /usr/local/bin/ampersand + +COPY . /usr/local/project/ + +# Generate prototype application from folder +RUN ampersand proto /usr/local/project/Interfaces.adl \ + --proto-dir /var/www \ + --verbose + +# Copy customizations into generated application +COPY customizations /var/www/ + +RUN chown -R www-data:www-data /var/www/data /var/www/log /var/www/generics \ + && cd /var/www \ + && composer install --prefer-dist --no-dev --profile --optimize-autoloader \ + && npm update \ + && npm audit fix \ + && npm install \ + && gulp build-ampersand \ + && gulp build-project diff --git a/AmpersandData/FormalAmpersand/DomainAnalysis.adl b/AmpersandData/Semantics/DomainAnalysis.adl similarity index 99% rename from AmpersandData/FormalAmpersand/DomainAnalysis.adl rename to AmpersandData/Semantics/DomainAnalysis.adl index d1fe16a27f..57ce1a7d65 100644 --- a/AmpersandData/FormalAmpersand/DomainAnalysis.adl +++ b/AmpersandData/Semantics/DomainAnalysis.adl @@ -59,7 +59,7 @@ ENDPATTERN PATTERN "Domain Analysis for Rules" -- This includes both equalities (e.g. r = s) and inequalities (e.g. r |- s) CONCEPT Rule "" - RELATION formalExpression[Rule*Term] [UNI] + RELATION formalTerm[Rule*Term] [UNI] VIEW Relation : Relation(name, TXT "[", source;name, TXT "*", target;name, TXT "]") CLASSIFY Equivalence ISA BinaryTerm diff --git a/AmpersandData/FormalAmpersand/Enforcements.adl b/AmpersandData/Semantics/Enforcements.adl similarity index 100% rename from AmpersandData/FormalAmpersand/Enforcements.adl rename to AmpersandData/Semantics/Enforcements.adl diff --git a/AmpersandData/Semantics/Events.adl b/AmpersandData/Semantics/Events.adl new file mode 100644 index 0000000000..bda92dfcc5 --- /dev/null +++ b/AmpersandData/Semantics/Events.adl @@ -0,0 +1,76 @@ +CONTEXT "Messaging" + +RELATION originatesFrom[Conjunct*Rule] [TOT] -- This rule is copied from FormalAmpersand + +-- The following stuff is not (yet) in FormalAmpersand +RELATION context[Session*DataSpace] [UNI,TOT] +RELATION context[Service*DataSpace] [UNI,TOT] +RELATION context[SatComputation*DataSpace] [UNI,TOT] +RELATION context[Action*DataSpace] [UNI,TOT] +RELATION compatible[DataSpace*MsgType] +RELATION inst[Message*MsgType] [UNI,TOT] +RELATION produced[Service*Message] [INJ,SUR] +RELATION produces[Service*Stream] +RELATION consumed[Service*Message] +RELATION consumes[Service*Stream] +RELATION log[Event*Stream] [UNI] +MEANING "Every event that occurs is logged on one specific stream." +RELATION on[Interface*Service] [UNI,TOT] +RELATION type[Widget*EventType] [UNI,TOT] +RELATION type[Stream*MsgType] [UNI,TOT] +RELATION in[Widget*Interface] [UNI,TOT] +RELATION reaction[EventType*CodeFragment] [UNI,TOT] +RELATION reaction[Rule*CodeFragment] [UNI,TOT] +RELATION exec[Action*CodeFragment] [UNI,TOT] +RELATION trig[Event*Conjunct] +RELATION trig[Violation*Action] [UNI] +RELATION conjunct[SatComputation*Conjunct] [UNI] +RELATION compBy[Violation*SatComputation] [UNI,TOT] +RELATION occured[Event*Session] [UNI,TOT] + +CLASSIFY Message ISA Event +PATTERN "Stream Type System" + PURPOSE RULE "Type checking of produced streams" + {+ We want statically typed streams. So, every stream has a type. The type checker must check for compatibility and generate appropriate error messages upon failure. + +} + RULE "Type checking of produced streams" : + context~;produces;type |- compatible + MEANING "The type of every stream must be compatible with the context of a service that produces it." + RULE "Type checking of consumed streams" : + context~;consumes;type |- compatible + MEANING "The type of every stream must be compatible with the context of a service that consumes it." + + PURPOSE RULE "Type checking of consumed messages" + {+ This relation allows the type checker to determine that there is precisely one match for every frame. + If not, the compiler must signal a mistake and refrain from generating code. + +} + RULE "Type checking of produced messages" : + produced;log |- produces + MEANING "A message can be produced only by a service that produces the MsgType of that message." + RULE "Type checking of consumed messages" : + consumed;log |- consumes + MEANING "A message can be consumed only by a service that consumes the MsgType of that message." +ENDPATTERN + +PATTERN "Evaluation of actions" + PURPOSE RULE "Evaluate whether a conjunct is satisfied" + {+ This rule tells when the exec-engine must kick in. +} + RULE "Evaluate whether a conjunct is satisfied" : + trig~;occured;context |- conjunct~;context + MEANING "A sat-computation is required if an event occurs that triggers (i.e. may violate) a conjunct." + + PURPOSE RULE "Evaluate which actions to take" + {+ This rule specifies which actions are triggered. +} + RULE "Evaluate which actions to take" : + compBy;conjunct |- trig;exec;reaction~;originatesFrom~ + MEANING "Every violation triggers the action specified by the rules in which the conjunct occurs." + + PURPOSE RULE "Take action on a widget event" + {+ This rule specifies which actions are triggered. +} + RULE "Take action on a widget event" : + reaction;exec~;context |- type~;in;on;I[Service];context + MEANING "An event that has the type of a widget causes an action in that context." +ENDPATTERN + + +ENDCONTEXT diff --git a/AmpersandData/FormalAmpersand/FSpec.adl b/AmpersandData/Semantics/FSpec.adl similarity index 100% rename from AmpersandData/FormalAmpersand/FSpec.adl rename to AmpersandData/Semantics/FSpec.adl diff --git a/AmpersandData/FormalAmpersand/IS.adl b/AmpersandData/Semantics/IS.adl similarity index 84% rename from AmpersandData/FormalAmpersand/IS.adl rename to AmpersandData/Semantics/IS.adl index e171c8b0d4..052f550a8d 100644 --- a/AmpersandData/FormalAmpersand/IS.adl +++ b/AmpersandData/Semantics/IS.adl @@ -5,14 +5,14 @@ INCLUDE "IS.pop" PATTERN "Information Systems" -RELATION characteristic[Rule*Expression] [UNI,TOT] PRAGMA "The characteristic expression of rule ``" "'' is " -MEANING "Every rule has a {\\em characteristic expression}, which is meant to remain true across changing states. We say that a rule is true whenever its characteristic expression can be evaluated to true." -RELATION exp[Query*Expression] [UNI,TOT] -MEANING "Each query evaluates a given expression in a given state, and produces a number of facts as a result." -RELATION signature[Expression*Expression] [UNI,TOT,TRN] -MEANING "Every expression has a signature (sometimes called type)." +RELATION characteristic[Rule*Term] [UNI,TOT] PRAGMA "The characteristic term of rule ``" "'' is " +MEANING "Every rule has a {\\em characteristic term}, which is meant to remain true across changing states. We say that a rule is true whenever its characteristic term can be evaluated to true." +RELATION exp[Query*Term] [UNI,TOT] +MEANING "Each query evaluates a given term in a given state, and produces a number of facts as a result." +RELATION signature[Term*Term] [UNI,TOT,TRN] +MEANING "Every term has a signature (sometimes called type)." RELATION state[Query*State] [UNI,TOT] -MEANING "Every query operates on a state, in which expressions can be evaluated." +MEANING "Every query operates on a state, in which terms can be evaluated." RELATION true[Query*Query] [PROP] MEANING "In order to say that a query has produced `true' as a result, we will call that query `true'." RELATION result[Query*Statement] @@ -24,16 +24,16 @@ MEANING "Each state except the initial state will have a predecessor. Two states RELATION equivalued[Query*Query] [RFX,TRN,ASY] MEANING "We shall use the word equivalued to indicate that executing two queries in the same state has produced identical results." -CLASSIFY Expression ISA Statement +CLASSIFY Term ISA Statement RULE "def equivalued" : equivalued = state;state~ /\ result<>result~ MEANING "Two queries are called equivalued if they produce exactly the same facts from the same state." RULE "def sat" : sat = state~;true;exp;characteristic~ -MEANING "For a rule $r$ to satisfy a state $s$ means: the query that executes the rule expression of rule $r$ yields true." +MEANING "For a rule $r$ to satisfy a state $s$ means: the query that executes the rule term of rule $r$ yields true." RULE "def true" : true = exp;signature;exp~;equivalued -MEANING "A query is true if it is equivalued with a query of the signature of its expression. I.e. its execution yields the same set of facts as does the signature executed on the same state." +MEANING "A query is true if it is equivalued with a query of the signature of its term. I.e. its execution yields the same set of facts as does the signature executed on the same state." IDENT query : Query(exp, state) diff --git a/AmpersandData/FormalAmpersand/IS.docadl b/AmpersandData/Semantics/IS.docadl similarity index 92% rename from AmpersandData/FormalAmpersand/IS.docadl rename to AmpersandData/Semantics/IS.docadl index ee38644387..260c004e6d 100644 --- a/AmpersandData/FormalAmpersand/IS.docadl +++ b/AmpersandData/Semantics/IS.docadl @@ -78,12 +78,12 @@ For our purposes, we work with the idea that truth requires a context.} in the r +} CONCEPT State "A state is the set of facts that populates an information system at a particular moment in time. The current state is the state of the system at the current moment in time." -PURPOSE CONCEPT Expression +PURPOSE CONCEPT Term {+If we want to talk to people, we use statements in natural language. If we want a computer to understand us, we use statements in a formal language. -The latter type of statement is called {\em expression}. +The latter type of statement is called {\em term}. +} -CONCEPT Expression "An expression is a statement in a formal language." +CONCEPT Term "An term is a statement in a formal language." PURPOSE CONCEPT Query {+Note that the word {\em statement} is used both in natural language and in formal language. @@ -95,14 +95,14 @@ Queries are meant to produce statements from the current state of an information +} CONCEPT Query "A query is a computation that yields a set of statements from a state." -PURPOSE RELATION characteristic[Rule*Expression] -{+In order to maintain rules, each rule is associated with one expression. That expression is called the {\em characteristic} expression of the rule. +PURPOSE RELATION characteristic[Rule*Term] +{+In order to maintain rules, each rule is associated with one term. That term is called the {\em characteristic} term of the rule. +} -PURPOSE RELATION exp[Query*Expression] -{+Queries exist for the purpose of evaluating an expression in a given context. +PURPOSE RELATION exp[Query*Term] +{+Queries exist for the purpose of evaluating an term in a given context. +} -PURPOSE RELATION signature[Expression*Expression] -{+For the purpose of defining truth, every expression has a signature. That signature itself is an expression too. +PURPOSE RELATION signature[Term*Term] +{+For the purpose of defining truth, every term has a signature. That signature itself is an term too. +} PURPOSE RELATION state[Query*State] {+When talking about the state on which the query has been executed, @@ -137,7 +137,7 @@ PURPOSE RULE "def sat" PURPOSE RULE "def true" {+In order to define the notion of truth formally, we must introduce a technical definition. -As the signature of an expression defines the truth, we call that expression true if its evaluation produces the identical result as the evaluation of its signature\footnote{This rule is explained further in the literature (add citation)}. +As the signature of an term defines the truth, we call that term true if its evaluation produces the identical result as the evaluation of its signature\footnote{This rule is explained further in the literature (add citation)}. +} --PURPOSE PATTERN "Documentation" @@ -169,7 +169,7 @@ That helps to get consensus about the correct wording of statements made from th PURPOSE RELATION meaning[Rule*NatLang] {+The meaning of a rule is described in natural language for two reasons. The first is to discuss the rule with its owner and stakeholders, because they must vouch for the correct wording of that rule. -The second is to verify the meaning with the expression of that rule, which is part of the formal review. +The second is to verify the meaning with the term of that rule, which is part of the formal review. +} PURPOSE RELATION purpose[Rule*NatLang] {+The purpose of a rule is described to document why it exists. diff --git a/AmpersandData/FormalAmpersand/IS.pop b/AmpersandData/Semantics/IS.pop similarity index 100% rename from AmpersandData/FormalAmpersand/IS.pop rename to AmpersandData/Semantics/IS.pop diff --git a/AmpersandData/FormalAmpersand/Interfaces_WIP.adl b/AmpersandData/Semantics/Interfaces_WIP.adl similarity index 84% rename from AmpersandData/FormalAmpersand/Interfaces_WIP.adl rename to AmpersandData/Semantics/Interfaces_WIP.adl index d22700d008..738cd1a571 100644 --- a/AmpersandData/FormalAmpersand/Interfaces_WIP.adl +++ b/AmpersandData/Semantics/Interfaces_WIP.adl @@ -7,7 +7,7 @@ CONTEXT "RAP" IN ENGLISH This file is the result of a working session on interfaces by Rieks and Michiel. It contains the conceptual model of the current Ampersand interface implementation - The conceptual model below has some overlap with Interfaces.adl, but has a total different view/approach on how to model interfaces + The conceptual model below has some overlap with Interfaces.adl, but has a totally different view/approach on how to model interfaces * Primairy difference is that: * Interfaces.adl distinguishes an Interface (root/entry) from an ObjectDef (recursive interface object definition) * We only have Interface(s) (= ObjectDef) and have a property 'isRoot' to specify it is an root/entry interface @@ -31,32 +31,33 @@ CONTEXT "RAP" IN ENGLISH RULE "An interface is public when it is a root interface that is not assigned to a role" : isPublic = isRoot-(for;for~) - RELATION for[Interface*Role] + RELATION for[Interface*Role] -- This is called ifcRoles[Interface*Role] in FormalAmpersand MEANING "The interface is assigned to a role and thereby only accessible for this/these role(s)" + -- The following rule would be superfluous if the interface and its recursive content are separated (as in Interfaces.adl) RULE "Only root interfaces can be assigned to a role" : I /\ for;for~ |- isRoot RELATION label[Interface*Txt] [UNI,TOT] MEANING "The textual representation of the interface as display in the user interface" - RELATION expr[Interface*Expression] [UNI,TOT] - MEANING "Specifies the interface expression" + RELATION expr[Interface*Term] [UNI,TOT] + MEANING "Specifies the interface term" RELATION view[Interface*View] [UNI] - MEANING "Specifies the view to be used for the target concept of the interface expression" + MEANING "Specifies the view to be used for the target concept of the interface term" -- CRUD specification RELATION crudC[Interface] [PROP] - MEANING "Specifies if create rights are given for the interface expression" + MEANING "Specifies if create rights are given for the interface term" RELATION crudR[Interface] [PROP] - MEANING "Specifies if read rights are given for the interface expression" + MEANING "Specifies if read rights are given for the interface term" RELATION crudU[Interface] [PROP] - MEANING "Specifies if update rights are given for the interface expression" + MEANING "Specifies if update rights are given for the interface term" RELATION crudD[Interface] [PROP] - MEANING "Specifies if delete rights are given for the interface expression" + MEANING "Specifies if delete rights are given for the interface term" RULE I[Interface] = I[LeafIfc] \/ I[RefIfc] \/ I[BoxInterface] @@ -76,7 +77,7 @@ CONTEXT "RAP" IN ENGLISH RELATION isLinkTo [RefIfc] [PROP] MEANING "Specifies if this interface links to the referred interface (i.e. in the UI the referred interface is not expanded)" - RULE "The target concept of a reference interface expression must have an object representation (i.e. not scalar)" : I[RefIfc];expr;tgt |-V;isObj + RULE "The target concept of a reference interface term must have an object representation (i.e. not scalar)" : I[RefIfc];expr;tgt |-V;isObj -- CRUD rights of reference interfaces must be the same as the CRUD right of the interface it refers to RULE refTo;crudC |- crudC @@ -100,19 +101,19 @@ CONTEXT "RAP" IN ENGLISH RELATION template[BoxIfc*BoxClass] [UNI,TOT] MEANING "A box interface has a certain template of how to display it in the UI" - RULE "The target concept of a box interface expression must have an object representation (i.e. not scalar)" : I[BoxIfc];expr;tgt |-V;isObj + RULE "The target concept of a box interface term must have an object representation (i.e. not scalar)" : I[BoxIfc];expr;tgt |-V;isObj --[BOXCLASS]--------------------------------------------------------------------------------------- CONCEPT BoxClass "" POPULATION BoxClass CONTAINS ["BOX", "FORM", "TABLE", "TABS"] --[EXPRESSION]------------------------------------------------------------------------------------- - RELATION isEditable[Expression] [PROP] - MEANING "Specifies if the expression is an editable expression (i.e. relation)" + RELATION isEditable[Term] [PROP] + MEANING "Specifies if the term is an editable term (i.e. relation)" - RELATION src[Expression*Concept] [UNI,TOT] + RELATION src[Term*Concept] [UNI,TOT] - RELATION tgt[Expression*Concept] [UNI,TOT] + RELATION tgt[Term*Concept] [UNI,TOT] --[CONCEPT]---------------------------------------------------------------------------------------- CONCEPT Concept "" diff --git a/AmpersandData/FormalAmpersand/Login.adl b/AmpersandData/Semantics/Login.adl similarity index 99% rename from AmpersandData/FormalAmpersand/Login.adl rename to AmpersandData/Semantics/Login.adl index cbb42c2e40..cbcd189cf4 100644 --- a/AmpersandData/FormalAmpersand/Login.adl +++ b/AmpersandData/Semantics/Login.adl @@ -19,7 +19,7 @@ CONCEPT Role "Een eigenschap waarmee kan worden bepaald welke functionaliteit to RULE 'SystemAdmin' |- I[Role] POPULATION Role CONTAINS [ "SystemAdmin" ] -RELATION name[Role*RoleName] [UNI,TOT] +RELATION name[Role*RoleName] [UNI] POPULATION name[Role*RoleName] CONTAINS [ ("SystemAdmin","SystemAdmin")] VIEW Role : Role(name) REPRESENT RoleName ALPHANUMERIC diff --git a/AmpersandData/FormalAmpersand/Login.xlsx b/AmpersandData/Semantics/Login.xlsx similarity index 100% rename from AmpersandData/FormalAmpersand/Login.xlsx rename to AmpersandData/Semantics/Login.xlsx diff --git a/AmpersandData/Semantics/Messages.adl b/AmpersandData/Semantics/Messages.adl new file mode 100644 index 0000000000..6708150ddf --- /dev/null +++ b/AmpersandData/Semantics/Messages.adl @@ -0,0 +1,146 @@ +{- +A message contains an aggragate of pairs in a hierarchical structure that resembles the interface structure. +Only, a message does not contain terms but only relations and flipped relations. + +The idea is to have a conceptual model that matches the messages in JSON. +Take for example the following message (code in JavaScript) + +yields the text '{"name":"city","atoms":["Amsterdam"]}' + +The JSON-message +{ "command" : "INSERT" +, "concept" : "Person" +, "rel" : [ { "name" : "lastName", "target" : "Text", "atoms" : ["John"] } + , { "name" : "age", "target" : "Age", "atoms" : [34] } + , { "name" : "address" + , "target" : "Address" + , "frames" : [ { "name" : "street", "atoms" : ["Albert Cuyplaan"] } + , { "name" : "zipCode", "atoms" : ["1012AB"] } + , { "name" : "city", "atoms" : ["Amsterdam"] } + ] + } + ] +, "relFlp" : [ { "name" : "member", "source" : "Company", "atoms" : ["ACME"] } +} +can be consumed by a service that has matching relations, e.g.: +```Ampersand4 +SERVICE "receiver" + RELATION member[Company*Person] + RELATION lastName[Person*Text] + RELATION age[Person*Age] + REPRESENT Age TYPE INTEGER +ENDSERVICE +``` +If a service cannot match one of the relations in the message, +Ampersand will block with a type error. +The matching process resembles type checking in the current Ampersand: +source and target fields in the JSON message may be omitted if +the type checker can resolve the type in the relation set of the +consuming service. + +The Haskell data structure looks like this: +```Haskell +data Message = + Message { command : Command + , concept : Concept + , rel, relFlp : [Frame] + } + +data Frame = -- A frame has a tree structure. Value are leaves and Comp are nodes. + Value { name : Identifier + , source, target : Maybe Concept + , value : Set Atom + } + | Comp { name : Identifier + , source, target : Maybe Concept + , rel, relFlp : [Frame] + } +``` +-} +CONTEXT "MESSAGING" + +PATTERN Atoms -- This pattern is copied from FormalAmpersand + RELATION name[Concept*Identifier] [UNI,TOT] + RELATION name[Relation*Identifier] [UNI,TOT] + RELATION source[Relation*Concept] [UNI,TOT] + RELATION target[Relation*Concept] [UNI,TOT] + + REPRESENT Identifier TYPE ALPHANUMERIC + + RULE "Identifiability of concepts": name;name~ |- I[Concept] + VIOLATION (TXT "The name \"", SRC I, TXT "\" is already in use") + + RELATION in[Pair*Relation] [UNI,TOT] + RELATION pop[Atom*Concept] + RELATION lAtom[Pair*Atom] [UNI,TOT] + RELATION rAtom[Pair*Atom] [UNI,TOT] +ENDPATTERN + +-- The following stuff is not (yet) in FormalAmpersand +RELATION context[Relation*Service] [UNI,TOT] +RELATION command[Message*Command] [UNI,TOT] +RELATION concept[Message*Concept] [UNI,TOT] +RELATION rel[Message*Frame] +RELATION relFlp[Message*Frame] +RELATION name[Frame*Identifier] [UNI,TOT] +RELATION source[Frame*Concept] [UNI] +RELATION target[Frame*Concept] [UNI] +RELATION value[Frame*Atom] +RELATION sub[Frame*Frame] + +PATTERN "Message Type System" + RELATION matchExists[Relation*Frame] + MEANING "Registers a match between relation and frame" + PURPOSE RULE "Definition of matchExists" + {+ To allow shorter JSON messages, a frame does not have to specify its source and target concepts. + In case this leads to ambiguity, the compiler must signal a mistake and refrain from generating code. + +} + RULE "Definition of matchExists" : + matchExists = name;name~ /\ -- names must match in all cases + source/source /\ -- if the frame has a source, it must match + target/target -- if the frame has a target, it must match + MEANING "There is a match between a frame and a relation if their name, source, and target match, insofar the frame has a source or target." + + RELATION uniqueMatch[Relation*Frame] + MEANING "A relation matches to a frame if the type checker says so." + PURPOSE RULE "Definition of uniqueMatch" + {+ This relation allows the type checker to determine that there is precisely one match for every frame. + If not, the compiler must signal a mistake and refrain from generating code. + +} + RULE "Definition of uniqueMatch" : + uniqueMatch = matchExists - -I;matchExists + MEANING "f is a unique match to r if there exists only one r for every f." + + RELATION acceptable[Service*Message] + MEANING "A service can only consume a message if it is acceptable to that service." + PURPOSE RULE "Definition of acceptable" + {+ If a message contains pairs that do not fit into one of the relations of a service or if it fits in multiple relations, that service cannot interpret this message. + This definition lets the type checker verify that all pairs will find "a home" inside the service. + +} + RULE "Definition of acceptable" : + acceptable = context~;uniqueMatch;(rel\/relFlp)~ + MEANING "A message is acceptable iff every frame in that message can be matched to one relation." +ENDPATTERN + +PATTERN "Allocation of atoms" + PURPOSE RULE rhsAtoms + {+ This rule describes which pairs are generated from a message. + The left-hand side atom is to be generated by the exec-engine (TBD)+} + RULE rhsAtoms : uniqueMatch;(rel~;rel/\I);value |- in~;rAtom + MEANING "The value of a frame (unflipped) is the right-hand side atom of a pair." + + PURPOSE RULE lhsAtoms + {+ This rule describes which pairs are generated from a message. + The right-hand side atom is to be generated by the exec-engine (TBD)+} + RULE lhsAtoms : uniqueMatch;(relFlp~;relFlp/\I);value |- in~;lAtom + MEANING "The value of a frame (flipped) is the left-hand side atom of a pair." +ENDPATTERN + +PATTERN "Streams" +ENDPATTERN + +ENDCONTEXT diff --git a/AmpersandData/FormalAmpersand/Modules.adl b/AmpersandData/Semantics/Modules.adl similarity index 100% rename from AmpersandData/FormalAmpersand/Modules.adl rename to AmpersandData/Semantics/Modules.adl diff --git a/AmpersandData/FormalAmpersand/Tables.adl b/AmpersandData/Semantics/Tables.adl similarity index 100% rename from AmpersandData/FormalAmpersand/Tables.adl rename to AmpersandData/Semantics/Tables.adl diff --git a/AmpersandData/FormalAmpersand/Tables.docadl b/AmpersandData/Semantics/Tables.docadl similarity index 100% rename from AmpersandData/FormalAmpersand/Tables.docadl rename to AmpersandData/Semantics/Tables.docadl diff --git a/AmpersandData/FormalAmpersand/Tables.xlsx b/AmpersandData/Semantics/Tables.xlsx similarity index 100% rename from AmpersandData/FormalAmpersand/Tables.xlsx rename to AmpersandData/Semantics/Tables.xlsx diff --git a/AmpersandData/FormalAmpersand/Expressions.xlsx b/AmpersandData/Semantics/Terms.xlsx similarity index 100% rename from AmpersandData/FormalAmpersand/Expressions.xlsx rename to AmpersandData/Semantics/Terms.xlsx diff --git a/AmpersandData/FormalAmpersand/TypeChecking.adl b/AmpersandData/Semantics/TypeChecking.adl similarity index 100% rename from AmpersandData/FormalAmpersand/TypeChecking.adl rename to AmpersandData/Semantics/TypeChecking.adl diff --git a/AmpersandData/FormalAmpersand/TypeChecking.docadl b/AmpersandData/Semantics/TypeChecking.docadl similarity index 100% rename from AmpersandData/FormalAmpersand/TypeChecking.docadl rename to AmpersandData/Semantics/TypeChecking.docadl diff --git a/AmpersandData/FormalAmpersand/Views.adl b/AmpersandData/Semantics/Views.adl similarity index 97% rename from AmpersandData/FormalAmpersand/Views.adl rename to AmpersandData/Semantics/Views.adl index 60528579f5..c2ee911480 100644 --- a/AmpersandData/FormalAmpersand/Views.adl +++ b/AmpersandData/Semantics/Views.adl @@ -8,6 +8,7 @@ PATTERN Views VIOLATION (TXT "{EX} DelAtom;View;", SRC I) -- all links in other relations in which the atom occurs are deleted as well. ROLE ExecEngine MAINTAINS "TOTdefault" +{- maintain a property to state whether a concept has a view. RELATION hasView[Concept*Concept] -- hasView = default[View*Concept]~;default[View*Concept]/\I ROLE ExecEngine MAINTAINS "ins hasView", "del hasView" RULE "ins hasView" : default[View*Concept]~;default[View*Concept]/\I |- hasView[Concept*Concept] @@ -16,6 +17,7 @@ PATTERN Views RULE "del hasView" : hasView[Concept*Concept] |- default[View*Concept]~;default[View*Concept]/\I MEANING "TODO: MEANING ONTBREEKT" VIOLATION (TXT "{EX}_; DelPair_;hasView_;Concept_;", SRC I, TXT "_;Concept_;", TGT I) +-} RELATION viewBy[Concept*Concept] -- viewBy[Concept*Concept] = isaStar;hasView[Concept*Concept] - isaPlus ROLE ExecEngine MAINTAINS "ins viewBy", "del viewBy" diff --git a/AmpersandData/FormalAmpersand/Views.docadl b/AmpersandData/Semantics/Views.docadl similarity index 100% rename from AmpersandData/FormalAmpersand/Views.docadl rename to AmpersandData/Semantics/Views.docadl diff --git a/AmpersandData/FormalAmpersand/Views.xlsx b/AmpersandData/Semantics/Views.xlsx similarity index 100% rename from AmpersandData/FormalAmpersand/Views.xlsx rename to AmpersandData/Semantics/Views.xlsx diff --git a/ArchitectureAndDesign/Syntax/Current Student version/ADL_V2.0.ebnf b/ArchitectureAndDesign/Syntax/Current Student version/ADL_V2.0.ebnf index 04423071e9..26e94b5704 100644 --- a/ArchitectureAndDesign/Syntax/Current Student version/ADL_V2.0.ebnf +++ b/ArchitectureAndDesign/Syntax/Current Student version/ADL_V2.0.ebnf @@ -1,6 +1,6 @@ ADL_V2 ::= ContextDef ContextDef ::= 'CONTEXT' Id IncludeStatement* LanguageRef? TextMarkup? - ( Meta | + ( MetaData | PatternDef | ProcessDef | RuleDef | @@ -17,7 +17,7 @@ ContextDef ::= 'CONTEXT' Id IncludeStatement* LanguageRef? TextMarkup? IncludeStatement ::= 'INCLUDE' FilePath LanguageRef ::= 'IN' ('DUTCH' | 'ENGLISH') TextMarkup ::= 'REST' | 'HTML' | 'LATEX' | 'MARKDOWN' -Meta ::= 'META' String String +MetaData ::= 'META' String String PatternDef ::= 'PATTERN' Id LanguageRef? ( RuleDef | RelationDef | diff --git a/ArchitectureAndDesign/Syntax/Current Student version/ui.xhtml b/ArchitectureAndDesign/Syntax/Current Student version/ui.xhtml index 067c42ee42..8b234028e1 100644 --- a/ArchitectureAndDesign/Syntax/Current Student version/ui.xhtml +++ b/ArchitectureAndDesign/Syntax/Current Student version/ui.xhtml @@ -292,10 +292,10 @@ TextMarkup - + - Meta + MetaData @@ -366,7 +366,7 @@ ContextDef - ::= 'CONTEXT' Id IncludeStatement* LanguageRef? TextMarkup? ( Meta | PatternDef | ProcessDef | RuleDef | RelationDef | ConceptDef | GenDef | KeyDef | InterfaceDef | Plug | Purpose | Population | Themes )* 'ENDCONTEXT' + ::= 'CONTEXT' Id IncludeStatement* LanguageRef? TextMarkup? ( MetaData | PatternDef | ProcessDef | RuleDef | RelationDef | ConceptDef | GenDef | KeyDef | InterfaceDef | Plug | Purpose | Population | Themes )* 'ENDCONTEXT' referenced by: @@ -547,7 +547,7 @@ Purpose RuleDef - Meta: + MetaData: - Meta ::= 'META' String String + MetaData ::= 'META' String String referenced by: diff --git a/ReleaseNotes.md b/ReleaseNotes.md index 0ca1d7d983..25c647dabc 100644 --- a/ReleaseNotes.md +++ b/ReleaseNotes.md @@ -1,5 +1,11 @@ # Release notes of Ampersand +## v4.3.0 ( 13 August 2021) + +* [Issue #1194](https://github.com/AmpersandTarski/Ampersand/issues/1194) Ampersand will output the options in debug mode. +* [Issue RAP #123](https://github.com/AmpersandTarski/RAP/issues/123) To enhance the Atlas in RAP to an acceptable minimal level, some changes in Ampersand are required. +* [Issue #1196](https://github.com/AmpersandTarski/Ampersand/issues/1196) Allow multiple files on the command line. The second to last files are handled as if they were INCLUDEd in the first one. + ## v4.2.0 ( 16 July 2021) * In the generated documentation, the Conceptual Analysis chapter has been revised to be readable by stakeholders with some knowledge of conceptual modeling. @@ -265,6 +271,8 @@ It has taken some time since the last release. This release has some major work * [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. diff --git a/Setup.hs b/Setup.hs index ac3c9e81b1..a3ca3dadad 100644 --- a/Setup.hs +++ b/Setup.hs @@ -33,7 +33,7 @@ generateHook pd lbi uh bf = do generateBuildInfoModule (T.pack . prettyShow . pkgVersion . package $ pd) generateStaticFileModule buildHook simpleUserHooks pd lbi uh bf -- start the build - + generateBuildInfoModule :: Text -> IO () -- | Generate a Haskell module that contains information that is available -- only during build time. @@ -188,7 +188,7 @@ generateStaticFileModule = do readAllStaticFiles = do pandocTemplatesFiles <- readStaticFiles PandocTemplates "." -- templates for several PANDOC output types formalAmpersandFiles <- readStaticFiles FormalAmpersand "." -- meta information about Ampersand - systemContextFiles <- readStaticFiles PrototypeContext "." -- Special system context for Ampersand + systemContextFiles <- readStaticFiles PrototypeContext "." -- Context for prototypes that Ampersand generates. return $ mkStaticFileModule $ pandocTemplatesFiles <> formalAmpersandFiles <> systemContextFiles readStaticFiles :: FileKind -> FilePath -> IO [(FileKind,Entry)] diff --git a/ampersand.cabal b/ampersand.cabal index db9f190f81..e3d34706ed 100644 --- a/ampersand.cabal +++ b/ampersand.cabal @@ -23,68 +23,28 @@ tested-with: extra-source-files: LICENSE ReleaseNotes.md - AmpersandData/FormalAmpersand/ADLTool.adl - AmpersandData/FormalAmpersand/admin_interfaces.ifc AmpersandData/FormalAmpersand/AST.adl AmpersandData/FormalAmpersand/AST.docadl - AmpersandData/FormalAmpersand/AST.ifc - AmpersandData/FormalAmpersand/AST.xlsx - AmpersandData/FormalAmpersand/Atoms.adl - AmpersandData/FormalAmpersand/Atoms.docadl - AmpersandData/FormalAmpersand/Atoms.ifc - AmpersandData/FormalAmpersand/Atoms.xlsx - AmpersandData/FormalAmpersand/AtomsAsShouldBe.adl - AmpersandData/FormalAmpersand/AtomsWithRepr.adl - AmpersandData/FormalAmpersand/Authorisation.adl AmpersandData/FormalAmpersand/Concepts.adl + AmpersandData/FormalAmpersand/Concepts.docadl AmpersandData/FormalAmpersand/Conjuncts.adl AmpersandData/FormalAmpersand/Conjuncts.docadl AmpersandData/FormalAmpersand/Contexts.adl AmpersandData/FormalAmpersand/Contexts.docadl - AmpersandData/FormalAmpersand/Contexts.ifc - AmpersandData/FormalAmpersand/Contexts.xlsx - AmpersandData/FormalAmpersand/ContextsTry.xlsx AmpersandData/FormalAmpersand/Documentation.adl - AmpersandData/FormalAmpersand/DomainAnalysis.adl - AmpersandData/FormalAmpersand/DomainAnalysis.ifc - AmpersandData/FormalAmpersand/Enforcements.adl - AmpersandData/FormalAmpersand/Expressions.adl - AmpersandData/FormalAmpersand/Expressions.docadl - AmpersandData/FormalAmpersand/Expressions.ifc - AmpersandData/FormalAmpersand/Expressions.xlsx AmpersandData/FormalAmpersand/FormalAmpersand.adl - AmpersandData/FormalAmpersand/FSpec.adl AmpersandData/FormalAmpersand/Generics.adl AmpersandData/FormalAmpersand/Interfaces.adl AmpersandData/FormalAmpersand/Interfaces.docadl - AmpersandData/FormalAmpersand/Interfaces_WIP.adl - AmpersandData/FormalAmpersand/IS.adl - AmpersandData/FormalAmpersand/IS.docadl - AmpersandData/FormalAmpersand/IS.ifc - AmpersandData/FormalAmpersand/IS.pop - AmpersandData/FormalAmpersand/Login.adl - AmpersandData/FormalAmpersand/Login.xlsx AmpersandData/FormalAmpersand/MinimalAST.xlsx - AmpersandData/FormalAmpersand/Modules.adl AmpersandData/FormalAmpersand/Patterns.adl AmpersandData/FormalAmpersand/Patterns.docadl AmpersandData/FormalAmpersand/README.txt AmpersandData/FormalAmpersand/Relations.adl AmpersandData/FormalAmpersand/Rules.adl AmpersandData/FormalAmpersand/Rules.docadl - AmpersandData/FormalAmpersand/Rules.ifc - AmpersandData/FormalAmpersand/student_AST_interfaces.ifc - AmpersandData/FormalAmpersand/Tables.adl - AmpersandData/FormalAmpersand/Tables.docadl - AmpersandData/FormalAmpersand/Tables.ifc - AmpersandData/FormalAmpersand/Tables.xlsx - AmpersandData/FormalAmpersand/TypeChecking.adl - AmpersandData/FormalAmpersand/TypeChecking.docadl - AmpersandData/FormalAmpersand/TypeChecking.ifc - AmpersandData/FormalAmpersand/Views.adl - AmpersandData/FormalAmpersand/Views.docadl - AmpersandData/FormalAmpersand/Views.ifc - AmpersandData/FormalAmpersand/Views.xlsx + AmpersandData/FormalAmpersand/Terms.adl + AmpersandData/FormalAmpersand/Terms.docadl AmpersandData/PrototypeContext/Interfaces.adl AmpersandData/PrototypeContext/Interfaces.ifc AmpersandData/PrototypeContext/Navbar.adl @@ -257,8 +217,6 @@ extra-source-files: testing/Travis/testcases/prototype/shouldFail/ParserOrTypecheckFailures/InterfaceRefCheck.adl testing/Travis/testcases/prototype/shouldFail/ParserOrTypecheckFailures/InterfaceTest1.adl testing/Travis/testcases/prototype/shouldFail/ParserOrTypecheckFailures/Issue142Fail.adl - testing/Travis/testcases/prototype/shouldFail/ParserOrTypecheckFailures/Issue142TooGeneric.adl - testing/Travis/testcases/prototype/shouldFail/ParserOrTypecheckFailures/Issue142TooGeneric.xlsx testing/Travis/testcases/prototype/shouldFail/ParserOrTypecheckFailures/Issue163.adl testing/Travis/testcases/prototype/shouldFail/ParserOrTypecheckFailures/Issue181.adl testing/Travis/testcases/prototype/shouldFail/ParserOrTypecheckFailures/Issue726.adl @@ -323,6 +281,8 @@ extra-source-files: testing/Travis/testcases/prototype/shouldSucceed/Issue1026.adl testing/Travis/testcases/prototype/shouldSucceed/Issue142.adl testing/Travis/testcases/prototype/shouldSucceed/Issue142.xlsx + testing/Travis/testcases/prototype/shouldSucceed/Issue142TooGeneric.adl + testing/Travis/testcases/prototype/shouldSucceed/Issue142TooGeneric.xlsx testing/Travis/testcases/prototype/shouldSucceed/Issue148.adl testing/Travis/testcases/prototype/shouldSucceed/Issue152.adl testing/Travis/testcases/prototype/shouldSucceed/Issue174.adl @@ -592,6 +552,7 @@ library src/ default-extensions: NoImplicitPrelude + OverloadedStrings ghc-options: -Wall -Wcompat -Widentities -optP-Wno-nonportable-include-path -Wredundant-constraints build-depends: HStringTemplate ==0.8.* @@ -654,6 +615,7 @@ executable ampPreProc app/AmpPreProc default-extensions: NoImplicitPrelude + OverloadedStrings ghc-options: -Wall -Wcompat -Widentities -optP-Wno-nonportable-include-path -Wredundant-constraints -threaded build-depends: HStringTemplate ==0.8.* @@ -719,6 +681,7 @@ executable ampersand app/Ampersand default-extensions: NoImplicitPrelude + OverloadedStrings ghc-options: -Wall -Wcompat -Widentities -optP-Wno-nonportable-include-path -Wredundant-constraints -threaded -fwrite-ide-info build-depends: Cabal ==3.2.1.0 @@ -784,6 +747,7 @@ test-suite ampersand-test app/Test default-extensions: NoImplicitPrelude + OverloadedStrings ghc-options: -Wall -Wcompat -Widentities -optP-Wno-nonportable-include-path -Wredundant-constraints -threaded build-depends: HStringTemplate ==0.8.* diff --git a/cabal.config b/cabal.config deleted file mode 100644 index 1219c12fd1..0000000000 --- a/cabal.config +++ /dev/null @@ -1,205 +0,0 @@ -Cabal 2.4.0.1 -Glob 0.10.1 -HStringTemplate 0.8.7 -HTTP 4000.3.15 -HsYAML 0.2.1.0 -JuicyPixels 3.3.5 -QuickCheck 2.13.2 -SHA 1.6.4.4 -SpreadsheetML 0.1 -StateVar 1.2.1 -adjunctions 4.4 -aeson 1.4.7.1 -aeson-pretty 0.8.8 -ansi-terminal 0.10.3 -ansi-wl-pprint 0.6.9 -array 0.5.3.0 -asn1-encoding 0.9.6 -asn1-parse 0.9.5 -asn1-types 0.3.4 -assoc 1.0.2 -async 2.2.2 -attoparsec 0.13.2.4 -base 4.12.0.0 -base-compat 0.11.2 -base-compat-batteries 0.11.2 -base-noprelude 4.12.0.0 -base-orphans 0.8.4 -base-unicode-symbols 0.2.4.2 -base16-bytestring 0.1.1.7 -base64-bytestring 1.0.0.3 -basement 0.0.11 -bifunctors 5.5.7 -binary 0.8.6.0 -binary-search 1.0.0.3 -blaze-builder 0.4.2.1 -blaze-html 0.9.1.2 -blaze-markup 0.8.2.7 -bytestring 0.10.8.2 -cabal-doctest 1.0.8 -call-stack 0.2.0 -case-insensitive 1.2.1.0 -cereal 0.5.8.1 -clock 0.8.2 -cmark-gfm 0.2.2 -cmdargs 0.10.20 -colour 2.3.5 -comonad 5.0.8 -conduit 1.3.4 -conduit-extra 1.3.5 -connection 0.3.1 -constraints 0.12 -containers 0.6.0.1 -contravariant 1.5.3 -cookie 0.4.5 -cryptonite 0.27 -data-accessor 0.2.3 -data-accessor-template 0.2.1.16 -data-accessor-transformers 0.2.1.7 -data-default 0.7.1.1 -data-default-class 0.1.2.0 -data-default-instances-containers 0.0.1 -data-default-instances-dlist 0.0.1 -data-default-instances-old-locale 0.0.1 -deepseq 1.4.4.0 -digest 0.0.1.2 -directory 1.3.3.0 -distributive 0.6.2.1 -dlist 0.8.0.8 -doclayout 0.3 -doctemplates 0.8.3 -emojis 0.1 -enclosed-exceptions 1.0.3 -errors 2.3.0 -exceptions 0.10.4 -extra 1.7.9 -fail 4.9.0.0 -fgl 5.7.0.3 -filepath 1.4.2.1 -free 5.1.3 -fsnotify 0.3.0.1 -generic-deriving 1.13.1 -ghc-boot-th 8.6.5 -ghc-prim 0.5.3 -gitrev 1.3.1 -graphviz 2999.20.1.0 -haddock-library 1.8.0 -hashable 1.2.7.0 -hinotify 0.4.1 -hourglass 0.2.12 -hsc2hs 0.68.7 -hslua 1.0.3.2 -hslua-module-system 0.2.2.1 -hslua-module-text 0.2.1 -http-client 0.6.4.1 -http-client-tls 0.3.5.3 -http-conduit 2.3.7.4 -http-types 0.12.3 -hxt 9.3.1.18 -hxt-charproperties 9.4.0.0 -hxt-regex-xmlschema 9.2.0.3 -hxt-unicode 9.0.2.4 -indexed-traversable 0.1.1 -integer-gmp 1.0.2.0 -integer-logarithms 1.0.3.1 -invariant 0.5.3 -ipynb 0.1.0.1 -jira-wiki-markup 1.1.4 -kan-extensions 5.2.1 -lens 4.18.1 -libyaml 0.1.2 -lifted-async 0.10.1.2 -lifted-base 0.2.3.12 -memory 0.15.0 -microlens 0.4.12.0 -microlens-mtl 0.2.0.1 -mime-types 0.1.0.9 -monad-control 1.0.2.3 -mono-traversable 1.0.15.1 -mtl 2.2.2 -mutable-containers 0.3.4 -network 3.1.2.1 -network-uri 2.6.3.0 -old-locale 1.0.0.7 -old-time 1.1.0.3 -open-browser 0.2.1.0 -optparse-applicative 0.15.1.0 -pandoc 2.9.2.1 -pandoc-crossref 0.3.6.2 -pandoc-types 1.20 -parallel 3.2.2.0 -parsec 3.1.13.0 -pem 0.2.4 -polyparse 1.13 -pretty 1.1.3.6 -primitive 0.7.1.0 -process 1.6.5.0 -profunctors 5.6 -quickcheck-instances 0.3.23 -random 1.1 -reflection 2.1.6 -regex-base 0.94.0.0 -regex-pcre-builtin 0.95.1.3.8.43 -resourcet 1.2.4.2 -rio 0.1.19.0 -roman-numerals 0.5.1.5 -rts 1.0 -safe 0.3.19 -scientific 0.3.6.2 -semigroupoids 5.3.4 -semigroups 0.19.1 -shelly 1.9.0 -simple-sql-parser 0.4.4 -skylighting 0.8.5 -skylighting-core 0.8.5 -socks 0.6.1 -split 0.2.3.4 -splitmix 0.0.5 -stm 2.5.0.0 -streaming-commons 0.2.2.1 -syb 0.7.2.1 -tagged 0.8.6.1 -tagsoup 0.14.8 -template-haskell 2.14.0.0 -temporary 1.3 -terminal-size 0.3.2.1 -texmath 0.12.1 -text 1.2.3.1 -text-conversions 0.3.1 -th-abstraction 0.3.2.0 -these 1.1.1.1 -time 1.8.0.2 -time-compat 1.9.5 -tls 1.5.4 -transformers 0.5.6.2 -transformers-base 0.4.5.2 -transformers-compat 0.6.6 -type-equality 1 -typed-process 0.2.6.0 -unicode-transforms 0.3.7.1 -unix 2.7.2.2 -unix-compat 0.5.3 -unliftio 0.2.14 -unliftio-core 0.2.0.1 -unordered-containers 0.2.13.0 -utf8-string 1.0.2 -utility-ht 0.0.15 -uuid-types 1.0.3 -vector 0.12.1.2 -vector-algorithms 0.8.0.4 -void 0.7.3 -wl-pprint 1.2.1 -wl-pprint-text 1.2.0.1 -x509 1.7.5 -x509-store 1.6.7 -x509-system 1.6.6 -x509-validation 1.6.11 -xeno 0.4.2 -xlsx 0.8.2 -xml 1.3.14 -xml-conduit 1.9.0.0 -xml-types 0.3.8 -yaml 0.11.5.0 -yaml-config 0.4.0 -zip-archive 0.4.1 -zlib 0.6.2.2 diff --git a/cabal.project.freeze b/cabal.project.freeze deleted file mode 100644 index 44693ee34a..0000000000 --- a/cabal.project.freeze +++ /dev/null @@ -1,278 +0,0 @@ -constraints: any.Cabal ==2.4.0.1, - any.Glob ==0.10.1, - any.HStringTemplate ==0.8.7, - any.HTTP ==4000.3.15, - HTTP -conduit10 -mtl1 +network-uri -warn-as-error -warp-tests, - any.HsYAML ==0.2.1.0, - HsYAML -exe, - any.JuicyPixels ==3.3.5, - JuicyPixels -mmap, - any.QuickCheck ==2.13.2, - QuickCheck +templatehaskell, - any.SHA ==1.6.4.4, - SHA -exe, - any.SpreadsheetML ==0.1, - any.StateVar ==1.2.1, - any.adjunctions ==4.4, - any.aeson ==1.4.7.1, - aeson -bytestring-builder -cffi -developer -fast, - any.aeson-pretty ==0.8.8, - aeson-pretty -lib-only, - ampersand -buildall, - any.ansi-terminal ==0.10.3, - ansi-terminal -example, - any.ansi-wl-pprint ==0.6.9, - ansi-wl-pprint -example, - any.array ==0.5.3.0, - any.asn1-encoding ==0.9.6, - any.asn1-parse ==0.9.5, - any.asn1-types ==0.3.4, - any.assoc ==1.0.2, - any.async ==2.2.2, - async -bench, - any.attoparsec ==0.13.2.4, - attoparsec -developer, - any.base ==4.12.0.0, - any.base-compat ==0.11.2, - any.base-compat-batteries ==0.11.2, - any.base-noprelude ==4.12.0.0, - any.base-orphans ==0.8.4, - any.base-unicode-symbols ==0.2.4.2, - base-unicode-symbols +base-4-8 -old-base, - any.base16-bytestring ==1.0.1.0, - any.base64-bytestring ==1.0.0.3, - any.basement ==0.0.11, - any.bifunctors ==5.5.7, - bifunctors +semigroups +tagged, - any.binary ==0.8.6.0, - any.binary-search ==1.0.0.3, - any.blaze-builder ==0.4.2.1, - any.blaze-html ==0.9.1.2, - any.blaze-markup ==0.8.2.7, - any.bytestring ==0.10.8.2, - any.cabal-doctest ==1.0.8, - any.call-stack ==0.2.0, - any.case-insensitive ==1.2.1.0, - any.cereal ==0.5.8.1, - cereal -bytestring-builder, - any.clock ==0.8.2, - clock -llvm, - any.cmark-gfm ==0.2.2, - cmark-gfm -pkgconfig, - any.cmdargs ==0.10.20, - cmdargs +quotation -testprog, - any.colour ==2.3.5, - any.comonad ==5.0.8, - comonad +containers +distributive +indexed-traversable, - any.conduit ==1.3.4, - any.conduit-extra ==1.3.5, - any.connection ==0.3.1, - any.constraints ==0.12, - any.containers ==0.6.0.1, - any.contravariant ==1.5.3, - contravariant +semigroups +statevar +tagged, - any.cookie ==0.4.5, - any.cryptonite ==0.27, - cryptonite -check_alignment +integer-gmp -old_toolchain_inliner +support_aesni +support_deepseq -support_pclmuldq +support_rdrand -support_sse +use_target_attributes, - any.data-accessor ==0.2.3, - data-accessor +category -monadfail +splitbase, - any.data-accessor-template ==0.2.1.16, - data-accessor-template -template_2_11 -template_2_4, - any.data-accessor-transformers ==0.2.1.7, - any.data-default ==0.7.1.1, - any.data-default-class ==0.1.2.0, - any.data-default-instances-containers ==0.0.1, - any.data-default-instances-dlist ==0.0.1, - any.data-default-instances-old-locale ==0.0.1, - any.deepseq ==1.4.4.0, - any.digest ==0.0.1.2, - digest -bytestring-in-base, - any.directory ==1.3.3.0, - any.distributive ==0.6.2.1, - distributive +semigroups +tagged, - any.dlist ==0.8.0.8, - any.doclayout ==0.3, - any.doctemplates ==0.8.3, - any.emojis ==0.1, - any.enclosed-exceptions ==1.0.3, - any.errors ==2.3.0, - any.exceptions ==0.10.4, - exceptions +transformers-0-4, - any.extra ==1.7.9, - any.fail ==4.9.0.0, - any.fgl ==5.7.0.3, - fgl +containers042, - any.filepath ==1.4.2.1, - any.free ==5.1.3, - any.fsnotify ==0.3.0.1, - any.generic-deriving ==1.13.1, - generic-deriving +base-4-9, - any.ghc-boot-th ==8.6.5, - any.ghc-prim ==0.5.3, - any.gitrev ==1.3.1, - any.graphviz ==2999.20.1.0, - graphviz -test-parsing, - any.haddock-library ==1.8.0, - any.hashable ==1.2.7.0, - hashable -examples +integer-gmp +sse2 -sse41, - any.hinotify ==0.4.1, - any.hourglass ==0.2.12, - any.hsc2hs ==0.68.7, - hsc2hs -in-ghc-tree, - any.hslua ==1.0.3.2, - hslua +allow-unsafe-gc -apicheck +export-dynamic -hardcode-reg-keys -lua_32bits -pkg-config -system-lua, - any.hslua-module-system ==0.2.2.1, - any.hslua-module-text ==0.2.1, - any.http-client ==0.6.4.1, - http-client +network-uri, - any.http-client-tls ==0.3.5.3, - any.http-conduit ==2.3.7.4, - http-conduit +aeson, - any.http-types ==0.12.3, - any.hxt ==9.3.1.18, - hxt -network-uri -profile, - any.hxt-charproperties ==9.4.0.0, - hxt-charproperties -profile, - any.hxt-regex-xmlschema ==9.2.0.3, - hxt-regex-xmlschema -profile, - any.hxt-unicode ==9.0.2.4, - any.indexed-traversable ==0.1.1, - any.integer-gmp ==1.0.2.0, - any.integer-logarithms ==1.0.3.1, - integer-logarithms -check-bounds +integer-gmp, - any.invariant ==0.5.3, - any.ipynb ==0.1.0.1, - any.jira-wiki-markup ==1.1.4, - any.kan-extensions ==5.2.1, - any.lens ==4.18.1, - lens -benchmark-uniplate -dump-splices +inlining -j -old-inline-pragmas -safe +test-doctests +test-hunit +test-properties +test-templates +trustworthy, - any.libyaml ==0.1.2, - libyaml -no-unicode -system-libyaml, - any.lifted-async ==0.10.1.2, - any.lifted-base ==0.2.3.12, - any.memory ==0.15.0, - memory +support_basement +support_bytestring +support_deepseq +support_foundation, - any.microlens ==0.4.12.0, - any.microlens-mtl ==0.2.0.1, - any.mime-types ==0.1.0.9, - any.monad-control ==1.0.2.3, - any.mono-traversable ==1.0.15.1, - any.mtl ==2.2.2, - any.mutable-containers ==0.3.4, - any.network ==3.1.2.1, - network -devel, - any.network-uri ==2.6.3.0, - any.old-locale ==1.0.0.7, - any.old-time ==1.1.0.3, - any.open-browser ==0.2.1.0, - any.optparse-applicative ==0.15.1.0, - any.pandoc ==2.9.2.1, - pandoc -embed_data_files -static -trypandoc, - any.pandoc-crossref ==0.3.6.2, - pandoc-crossref -enable_flaky_tests, - any.pandoc-types ==1.20, - any.parallel ==3.2.2.0, - any.parsec ==3.1.13.0, - any.pem ==0.2.4, - any.polyparse ==1.13, - any.pretty ==1.1.3.6, - any.primitive ==0.7.1.0, - any.process ==1.6.5.0, - any.profunctors ==5.6, - any.quickcheck-instances ==0.3.23, - quickcheck-instances -bytestring-builder, - any.random ==1.1, - any.reflection ==2.1.6, - reflection -slow +template-haskell, - any.regex-base ==0.94.0.0, - any.regex-pcre-builtin ==0.95.1.3.8.43, - any.resourcet ==1.2.4.2, - any.rio ==0.1.19.0, - any.roman-numerals ==0.5.1.5, - any.rts ==1.0, - any.safe ==0.3.19, - any.scientific ==0.3.6.2, - scientific -bytestring-builder -integer-simple, - any.semigroupoids ==5.3.4, - semigroupoids +comonad +containers +contravariant +distributive +doctests +tagged +unordered-containers, - any.semigroups ==0.19.1, - semigroups +binary +bytestring -bytestring-builder +containers +deepseq +hashable +tagged +template-haskell +text +transformers +unordered-containers, - any.shelly ==1.9.0, - shelly -build-examples -lifted, - any.simple-sql-parser ==0.4.4, - simple-sql-parser -sqlindent, - any.skylighting ==0.8.5, - skylighting -executable, - any.skylighting-core ==0.8.5, - skylighting-core -executable -system-pcre, - any.socks ==0.6.1, - any.split ==0.2.3.4, - any.splitmix ==0.0.5, - splitmix -optimised-mixer +random, - any.stm ==2.5.0.0, - any.streaming-commons ==0.2.2.1, - streaming-commons -use-bytestring-builder, - any.syb ==0.7.2.1, - any.tagged ==0.8.6.1, - tagged +deepseq +transformers, - any.tagsoup ==0.14.8, - any.template-haskell ==2.14.0.0, - any.temporary ==1.3, - any.terminal-size ==0.3.2.1, - any.texmath ==0.12.1, - texmath -executable +network-uri, - any.text ==1.2.3.1, - any.text-conversions ==0.3.1, - any.th-abstraction ==0.3.2.0, - any.these ==1.1.1.1, - these +assoc, - any.time ==1.8.0.2, - any.time-compat ==1.9.5, - time-compat -old-locale, - any.tls ==1.5.4, - tls +compat -hans +network, - any.transformers ==0.5.6.2, - any.transformers-base ==0.4.5.2, - transformers-base +orphaninstances, - any.transformers-compat ==0.6.6, - transformers-compat -five +five-three -four +generic-deriving +mtl -three -two, - any.type-equality ==1, - any.typed-process ==0.2.6.0, - any.unicode-transforms ==0.3.7.1, - unicode-transforms -bench-show -dev -has-icu -has-llvm, - any.unix ==2.7.2.2, - any.unix-compat ==0.5.3, - unix-compat -old-time, - any.unliftio ==0.2.14, - any.unliftio-core ==0.2.0.1, - any.unordered-containers ==0.2.13.0, - unordered-containers -debug, - any.utf8-string ==1.0.2, - any.utility-ht ==0.0.15, - any.uuid-types ==1.0.3, - any.vector ==0.12.1.2, - vector +boundschecks -internalchecks -unsafechecks -wall, - any.vector-algorithms ==0.8.0.4, - vector-algorithms +bench +boundschecks -internalchecks -llvm +properties -unsafechecks, - any.void ==0.7.3, - void -safe, - any.wl-pprint ==1.2.1, - any.wl-pprint-text ==1.2.0.1, - any.x509 ==1.7.5, - any.x509-store ==1.6.7, - any.x509-system ==1.6.6, - any.x509-validation ==1.6.11, - any.xeno ==0.4.2, - xeno -libxml2, - any.xlsx ==0.8.2, - xlsx -microlens, - any.xml ==1.3.14, - any.xml-conduit ==1.9.0.0, - any.xml-types ==0.3.8, - any.yaml ==0.11.5.0, - yaml +no-examples +no-exe, - any.yaml-config ==0.4.0, - any.zip-archive ==0.4.1, - zip-archive -executable, - any.zlib ==0.6.2.2, - zlib -bundled-c-zlib -non-blocking-ffi -pkg-config diff --git a/commands.md b/commands.md index 358b2ba98d..d4d58b9a8f 100644 --- a/commands.md +++ b/commands.md @@ -103,10 +103,10 @@ even more complex than it already was. * ***--help*** Now gives information about the level where it is called: * `ampersand --help` gives help about the commands and global options. * `ampersand --help` gives information about the command-specific options. - * We used to have the possibility to fiddle around with the formal ampersand metamodel. This - has been generalized, and we now have another metamodel as well, called PrototypeContext. The - latter is used during the generation of prototypes. This is still an experimental feature. - * ***--add-semantic-metamodel, --meta-tables*** Changed to `--build-recipe RECIPE`. + * We used to have FormalAmpersand together with an experimental feature called PrototypeContext to fiddle around with the metamodel. + PrototypeContext and FormalAmpersand lived alongside. Both had to be consistent with the meatgrinder. + Now, both are substituted by a single metamodel. The compiler generates it from the meatgrinder, so it matches the meatgrinder by definition. + * ***--add-semantic-metamodel, --meta-tables*** Changed to `--build-recipe RECIPE`. All relations, views, idents etc. from the specified metamodel will be available for use in your model. These artefacts do not have to be declared explicitly in your own model. @@ -154,7 +154,7 @@ even more complex than it already was. ## working with meta-models -We now have `recipes` to deal with metamodels such as Formal Ampersand and PrototypeContext. These recipes will be used based on the chose command. There might be a need to modify those recipes by the user. This still has to be seen. In any case, the following options will be removed: +We now have `recipes` to deal with metamodels such as Formal Ampersand and PrototypeContext. These recipes will be used based on the chose command. There might be a need to modify those recipes by the user. This still has to be seen. In any case, the following options have been removed: * ***--gen-as-rap-model*** Generate populations for use in RAP3. diff --git a/package.yaml b/package.yaml index 4637a509b8..2637c567a0 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: ampersand -version: 4.2.0 +version: 4.3.0 author: Stef Joosten maintainer: stef.joosten@ou.nl synopsis: Toolsuite for automated design of enterprise information systems. @@ -32,6 +32,7 @@ ghc-options: - -Wredundant-constraints default-extensions: - NoImplicitPrelude + - OverloadedStrings dependencies: - aeson == 1.5.6.0 - aeson-pretty == 0.8.* diff --git a/src/Ampersand/ADL1.hs b/src/Ampersand/ADL1.hs index ee9117522d..9344d332c3 100644 --- a/src/Ampersand/ADL1.hs +++ b/src/Ampersand/ADL1.hs @@ -13,7 +13,7 @@ import Ampersand.Core.ParseTree ( , P_Concept(..) , P_Sign(..) , P_Context(..), mergeContexts - , Meta(..) + , MetaData(..) , P_RoleRule(..) , P_Pattern(..) , PairView(..), PairViewSegment(..) @@ -41,7 +41,7 @@ import Ampersand.Core.AbstractSyntaxTree ( , Expression(..) , AClassify(..) , RuleOrigin(..) - , IdentityDef(..) + , IdentityRule(..) , IdentitySegment(..) , ViewDef(..) , ViewSegment(..) diff --git a/src/Ampersand/ADL1/Expression.hs b/src/Ampersand/ADL1/Expression.hs index 618bc22b6d..9d029a41c7 100644 --- a/src/Ampersand/ADL1/Expression.hs +++ b/src/Ampersand/ADL1/Expression.hs @@ -154,29 +154,15 @@ isFlipped _ = False isFitForCrudC :: Expression -> Bool isFitForCrudC expr = case expr of - EDcD{} -> True EFlp e -> isFitForCrudC e EBrk e -> isFitForCrudC e - EEps _ _ -> False - EDcI{} -> True -- TODO: set to False when functionality of +menu is adapted from I[Cpt] to V[SESSION*Cpt] expressions (see Issue #884) - EMp1{} -> False - EDcV{} -> True ECps( EEps _ _ , e ) -> isFitForCrudC e ECps( e , EEps _ _ ) -> isFitForCrudC e ECps( _ , _ ) -> True - EEqu{} -> True - EInc{} -> True - EIsc{} -> True - EUni{} -> True - EDif{} -> True - ELrs{} -> True - ERrs{} -> True - EDia{} -> True - ERad{} -> True - EPrd{} -> True - EKl0{} -> True - EKl1{} -> True - ECpl{} -> True + EEps _ _ -> False + EMp1{} -> False + _ -> True + -- EDcI{} -> True -- TODO: set to False when functionality of +menu is adapted from I[Cpt] to V[SESSION*Cpt] expressions (see Issue #884) -- | Function to determine that the expression -- could be used to read the population of its target concept isFitForCrudR :: Expression -> Bool @@ -189,27 +175,11 @@ isFitForCrudU expr = EDcD{} -> True EFlp e -> isFitForCrudU e EBrk e -> isFitForCrudU e - EEps _ _ -> False - EDcI{} -> False - EMp1{} -> False - EDcV{} -> False ECps ( EEps _ _ , e ) -> isFitForCrudU e ECps ( e , EEps _ _ ) -> isFitForCrudU e ECps ( e , EDcI{} ) -> isFitForCrudU e ECps ( _ , _ ) -> False - EEqu{} -> False - EInc{} -> False - EIsc{} -> False - EUni{} -> False - EDif{} -> False - ELrs{} -> False - ERrs{} -> False - EDia{} -> False - ERad{} -> False - EPrd{} -> False - EKl0{} -> False - EKl1{} -> False - ECpl{} -> False + _ -> False -- | Function to determine that the expression is simple, that it -- could be used to update the population of a relation isFitForCrudD :: Expression -> Bool @@ -250,45 +220,6 @@ insParentheses = insPar 0 insPar _ (EFlp e) = EFlp (insPar 10 e) insPar _ (ECpl e) = ECpl (insPar 10 e) insPar i (EBrk e) = insPar i e - insPar _ x@EDcD{} = x - insPar _ x@EDcI{} = x - insPar _ x@EEps{} = x - insPar _ x@EDcV{} = x - insPar _ x@EMp1{} = x + insPar _ x = x -- x@EDcD{} or EDcI{} or EEps{} or EDcV{} or EMp1{} foldr1 :: (Expression -> Expression -> Expression) -> NE.NonEmpty Expression -> Expression - foldr1 fun nonempty = foldr fun (NE.last nonempty) (NE.init nonempty) -{- - insPar 0 (r/\s/\t/\x/\y |- p) -= - wrap 0 0 (insPar 1 (r/\s/\t/\x/\y) |- insPar 1 p) -= - insPar 1 (r/\s/\t/\x/\y) |- insPar 1 p -= - wrap 1 2 (foldr1 f [insPar 3 e | e<-exprIsc2list (r/\s/\t/\x/\y) ]) |- p where f x y = EIsc (x,y) -= - foldr1 f [insPar 3 e | e<-exprIsc2list (r/\s/\t/\x/\y) ] |- p where f x y = EIsc (x,y) -= - foldr1 f [insPar 3 e | e<-[r,s,t,x,y] ] |- p where f x y = EIsc (x,y) -= - foldr1 f [insPar 3 r,insPar 3 s,insPar 3 t,insPar 3 x,insPar 3 y] |- p where f x y = EIsc (x,y) -= - foldr1 f [r,s,t,x,y] |- p where f x y = EIsc (x,y) -= - r/\s/\t/\x/\y |- p - - insPar 0 (r;s;t;x;y |- p) -= - wrap 0 0 (insPar 1 (r;s;t;x;y) |- insPar 1 p) -= - insPar 1 (r;s;t;x;y) |- insPar 1 p -= - wrap 1 8 (insPar 8 r ; insPar 8 (s;t;x;y)) |- p -= - r; insPar 8 (s;t;x;y) |- p -= - r; wrap 8 8 (insPar 8 s; insPar 8 (t;x;y)) |- p -= - r; insPar 8 s; insPar 8 (t;x;y) |- p -= - r; s; insPar 8 (t;x;y) |- p --} + foldr1 fun nonempty = foldr fun (NE.last nonempty) (NE.init nonempty) \ No newline at end of file diff --git a/src/Ampersand/ADL1/Lattices.hs b/src/Ampersand/ADL1/Lattices.hs index f5ca8a8a2b..beb21d2ade 100644 --- a/src/Ampersand/ADL1/Lattices.hs +++ b/src/Ampersand/ADL1/Lattices.hs @@ -10,7 +10,7 @@ After changing the data type, see @optimize1@, the structure allows you to perfo -} {-# LANGUAGE ApplicativeDo #-} {-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE OverloadedStrings #-} + module Ampersand.ADL1.Lattices ( findExact,findUpperbounds,optimize1 , Op1EqualitySystem,addEquality,emptySystem diff --git a/src/Ampersand/ADL1/P2A_Converters.hs b/src/Ampersand/ADL1/P2A_Converters.hs index 6a6cc68042..443210bdc8 100644 --- a/src/Ampersand/ADL1/P2A_Converters.hs +++ b/src/Ampersand/ADL1/P2A_Converters.hs @@ -1,7 +1,7 @@ {-# LANGUAGE TupleSections #-} {-# LANGUAGE ApplicativeDo #-} {-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE OverloadedStrings #-} + module Ampersand.ADL1.P2A_Converters ( pCtx2aCtx , pCpt2aCpt @@ -603,7 +603,7 @@ pCtx2aCtx env obj crud (e,sr) s = ( BxExpr ObjectDef { objnm = nm - , objpos = orig + , objPos = orig , objExpression = e , objcrud = crud , objmView = mView @@ -790,9 +790,9 @@ pCtx2aCtx env , ifcname = name pIfc , ifcRoles = ifc_Roles pIfc , ifcObj = o - , ifcControls = [] -- to be enriched in Adl2fSpec with rules to be checked + , ifcConjuncts = [] -- to be enriched in Adl2fSpec with rules to be checked , ifcPos = origin pIfc - , ifcPrp = ifc_Prp pIfc + , ifcPurpose = ifc_Prp pIfc } tt -> Errors . pure . mkInterfaceMustBeDefinedOnObject pIfc (target . objExpression $ o) $ tt @@ -862,7 +862,7 @@ pCtx2aCtx env } pIdentity2aIdentity :: ContextInfo -> Maybe Text -- name of pattern the rule is defined in (if any) - -> P_IdentDef -> Guarded IdentityDef + -> P_IdentDef -> Guarded IdentityRule pIdentity2aIdentity ci mPat pidt = case disambiguate cptMap (termPrimDisAmb cptMap (declDisambMap ci)) pidt of P_Id { ix_lbl = lbl @@ -1077,7 +1077,7 @@ pDecl2aDecl :: -> Lang -- The default language -> PandocFormat -- The default pandocFormat -> P_Relation -> Guarded Relation -pDecl2aDecl cptMap env defLanguage defFormat pd +pDecl2aDecl cptMap maybePatName defLanguage defFormat pd = let (prL:prM:prR:_) = dec_pragma pd <> ["", "", ""] dcl = Relation { decnm = dec_nm pd @@ -1090,7 +1090,7 @@ pDecl2aDecl cptMap env defLanguage defFormat pd , decMean = map (pMean2aMean defLanguage defFormat) (dec_Mean pd) , decfpos = origin pd , decusr = True - , decpat = env + , decpat = maybePatName , dechash = hash (dec_nm pd) `hashWithSalt` decSign } in checkEndoProps >> pure dcl diff --git a/src/Ampersand/ADL1/PrettyPrinters.hs b/src/Ampersand/ADL1/PrettyPrinters.hs index 01be178efd..00af0e1381 100644 --- a/src/Ampersand/ADL1/PrettyPrinters.hs +++ b/src/Ampersand/ADL1/PrettyPrinters.hs @@ -1,7 +1,7 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} + module Ampersand.ADL1.PrettyPrinters(Pretty(..),prettyPrint) where @@ -100,8 +100,8 @@ instance Pretty P_Context where <+\> perline pops <+\> text "ENDCONTEXT" -instance Pretty Meta where - pretty (Meta _ nm val) = +instance Pretty MetaData where + pretty (MetaData _ nm val) = text "META" <+> quote nm <+> quote val instance Pretty P_RoleRule where diff --git a/src/Ampersand/ADL1/Rule.hs b/src/Ampersand/ADL1/Rule.hs index 44e983a434..2791eae76f 100644 --- a/src/Ampersand/ADL1/Rule.hs +++ b/src/Ampersand/ADL1/Rule.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE OverloadedStrings #-} + module Ampersand.ADL1.Rule ( consequent, antecedent, hasantecedent , isPropertyRule, rulefromProp diff --git a/src/Ampersand/Basics/Auxiliaries.hs b/src/Ampersand/Basics/Auxiliaries.hs index 45f5488c47..3373c6c2f5 100644 --- a/src/Ampersand/Basics/Auxiliaries.hs +++ b/src/Ampersand/Basics/Auxiliaries.hs @@ -1,5 +1,5 @@ {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE OverloadedStrings #-} + module Ampersand.Basics.Auxiliaries ( eqClass,eqClassNE, eqCl,eqClNE, diff --git a/src/Ampersand/Basics/Exit.hs b/src/Ampersand/Basics/Exit.hs index 3bf1025899..51e8ebd8d1 100644 --- a/src/Ampersand/Basics/Exit.hs +++ b/src/Ampersand/Basics/Exit.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE OverloadedStrings #-} + {-# LANGUAGE ScopedTypeVariables #-} -- | This module contains a datastructure for exceptions that -- can be thrown by Ampersand. diff --git a/src/Ampersand/Basics/PandocExtended.hs b/src/Ampersand/Basics/PandocExtended.hs index 5b59137bc7..38e5b39355 100644 --- a/src/Ampersand/Basics/PandocExtended.hs +++ b/src/Ampersand/Basics/PandocExtended.hs @@ -1,5 +1,5 @@ {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE OverloadedStrings #-} + module Ampersand.Basics.PandocExtended ( PandocFormat(..) , Markup(..) diff --git a/src/Ampersand/Basics/Prelude.hs b/src/Ampersand/Basics/Prelude.hs index 102cfb5885..3b5fdd1aa3 100644 --- a/src/Ampersand/Basics/Prelude.hs +++ b/src/Ampersand/Basics/Prelude.hs @@ -1,5 +1,5 @@ {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE OverloadedStrings #-} + module Ampersand.Basics.Prelude ( module RIO , readUTF8File @@ -15,9 +15,11 @@ module Ampersand.Basics.Prelude , defaultFirstFalse , decodeUtf8 , foldl + , undefined )where import Prelude (reads,getChar) -- Needs to be fixed later. See https://haskell.fpcomplete.com/library/rio we'll explain why we need this in logging -import RIO hiding (zipWith,exitWith) +import RIO hiding (zipWith,exitWith,undefined) +import qualified RIO as WarnAbout (undefined) import qualified RIO.Text as T import System.IO (openTempFile) @@ -46,6 +48,11 @@ foldl :: Foldable t => (b -> a -> b) -> b -> t a -> b {-# WARNING foldl "Please do not use foldl. Use foldl' instead. It is more performant." #-} foldl = foldl' +-- Redefine undefined to ensure that it isn't accidentally used. +undefined :: a +{-# WARNING undefined "Undefined statement left in code. Why not use fatal?" #-} +undefined = WarnAbout.undefined + -- Functions copied from stack -- | Like @First Bool@, but the default is @True@. newtype FirstTrue = FirstTrue { getFirstTrue :: Maybe Bool } diff --git a/src/Ampersand/Basics/String.hs b/src/Ampersand/Basics/String.hs index 6f4a352cea..02a81feb73 100644 --- a/src/Ampersand/Basics/String.hs +++ b/src/Ampersand/Basics/String.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE OverloadedStrings #-} + -- | This module contains some common Text funcions module Ampersand.Basics.String ( unCap,upCap diff --git a/src/Ampersand/Basics/Unique.hs b/src/Ampersand/Basics/Unique.hs index 97fb1edd09..17b577500f 100644 --- a/src/Ampersand/Basics/Unique.hs +++ b/src/Ampersand/Basics/Unique.hs @@ -1,5 +1,5 @@ {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE OverloadedStrings #-} + {- The purpose of class Unique is to identify a Haskell object by means of a string. E.g. instance Unique Pattern where @@ -63,7 +63,7 @@ uniqueButNotTooLong txt = -- in a field that is normally 255 long. We store the -- prefix of the string but make sure we still have space -- left over for the hash. While theoretically this is a - -- crappy solution, in practice this will prove to be well + -- crappy solution, in practice this will prove to be good -- enough. diff --git a/src/Ampersand/Basics/Version.hs b/src/Ampersand/Basics/Version.hs index 902dcc963b..074441aeb6 100644 --- a/src/Ampersand/Basics/Version.hs +++ b/src/Ampersand/Basics/Version.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE OverloadedStrings #-} + -- | This module contains Version of Ampersand module Ampersand.Basics.Version ( VersionInfo(..) diff --git a/src/Ampersand/Classes/ConceptStructure.hs b/src/Ampersand/Classes/ConceptStructure.hs index 9416b4975b..eddc70b27b 100644 --- a/src/Ampersand/Classes/ConceptStructure.hs +++ b/src/Ampersand/Classes/ConceptStructure.hs @@ -1,5 +1,5 @@ {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedStrings #-} + module Ampersand.Classes.ConceptStructure (ConceptStructure(..)) where import Ampersand.ADL1 @@ -78,7 +78,7 @@ instance ConceptStructure A_Context where , (expressionsIn . multrules) ctx ] -instance ConceptStructure IdentityDef where +instance ConceptStructure IdentityRule where concs identity = Set.singleton (idCpt identity) `Set.union` (concs . fmap segment . identityAts $ identity) diff --git a/src/Ampersand/Classes/Relational.hs b/src/Ampersand/Classes/Relational.hs index 378b630c72..15b5f5892d 100644 --- a/src/Ampersand/Classes/Relational.hs +++ b/src/Ampersand/Classes/Relational.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE OverloadedStrings #-} + module Ampersand.Classes.Relational ( HasProps(..) , Relational(..) diff --git a/src/Ampersand/Classes/ViewPoint.hs b/src/Ampersand/Classes/ViewPoint.hs index 367db2768b..590c3054a2 100644 --- a/src/Ampersand/Classes/ViewPoint.hs +++ b/src/Ampersand/Classes/ViewPoint.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE OverloadedStrings #-} + module Ampersand.Classes.ViewPoint (Language(..)) where @@ -24,17 +24,17 @@ class Language a where multrules x = Set.fromList $ [rulefromProp p d |d<-Set.elems $ relsDefdIn x, p<-Set.elems (properties d)] identityRules :: a -> Rules -- all identity rules that are maintained within this viewpoint. - identityRules x = Set.unions . map rulesFromIdentity $ identities x + identityRules x = Set.fromList . map ruleFromIdentity $ identities x allRules :: a -> Rules allRules x = udefrules x `Set.union` multrules x `Set.union` identityRules x - identities :: a -> [IdentityDef] -- ^ all keys that are defined in a + identities :: a -> [IdentityRule] -- ^ all keys that are defined in a viewDefs :: a -> [ViewDef] -- ^ all views that are defined in a gens :: a -> [AClassify] -- ^ all generalizations that are valid within this viewpoint patterns :: a -> [Pattern] -- ^ all patterns that are used in this viewpoint -rulesFromIdentity :: IdentityDef -> Rules -rulesFromIdentity identity - = Set.singleton . mkKeyRule $ +ruleFromIdentity :: IdentityRule -> Rule +ruleFromIdentity identity + = mkKeyRule $ foldr (./\.) h t .|-. EDcI (idCpt identity) {- diamond e1 e2 = (flp e1 .\. e2) ./\. (e1 ./. flp e2) -} diff --git a/src/Ampersand/Commands/Daemon.hs b/src/Ampersand/Commands/Daemon.hs index 4fcbe7785c..878de10ebf 100644 --- a/src/Ampersand/Commands/Daemon.hs +++ b/src/Ampersand/Commands/Daemon.hs @@ -1,5 +1,5 @@ {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE OverloadedStrings #-} + {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} diff --git a/src/Ampersand/Commands/Devoutput.hs b/src/Ampersand/Commands/Devoutput.hs index 3a1e3f9b2d..259cdf2c07 100644 --- a/src/Ampersand/Commands/Devoutput.hs +++ b/src/Ampersand/Commands/Devoutput.hs @@ -1,7 +1,6 @@ -{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} + -- | Generate a prototype from a project. module Ampersand.Commands.Devoutput diff --git a/src/Ampersand/Commands/Documentation.hs b/src/Ampersand/Commands/Documentation.hs index 9f6f09a629..7dd1a1fa2a 100644 --- a/src/Ampersand/Commands/Documentation.hs +++ b/src/Ampersand/Commands/Documentation.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE OverloadedStrings #-} + module Ampersand.Commands.Documentation (doGenDocument) where @@ -27,5 +27,7 @@ doGenDocument fSpec = do genGraphics <- view genGraphicsL when (genGraphics && fspecFormat /=FPandoc) $ mapM_ writePicture (reverse thePictures) -- NOTE: reverse is used to have the datamodels generated first. This is not required, but it is handy. - writepandoc fSpec thePandoc + genText <- view genTextL + when genText $ + writepandoc fSpec thePandoc diff --git a/src/Ampersand/Commands/ExportAsADL.hs b/src/Ampersand/Commands/ExportAsADL.hs index a89bf62d1c..9ed1b84dd3 100644 --- a/src/Ampersand/Commands/ExportAsADL.hs +++ b/src/Ampersand/Commands/ExportAsADL.hs @@ -1,7 +1,6 @@ -{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} + -- | Clean a project. module Ampersand.Commands.ExportAsADL diff --git a/src/Ampersand/Commands/Init.hs b/src/Ampersand/Commands/Init.hs index 356619d9f4..574b048bea 100644 --- a/src/Ampersand/Commands/Init.hs +++ b/src/Ampersand/Commands/Init.hs @@ -1,7 +1,6 @@ -{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} + -- | Generate a configuration file for a new project. module Ampersand.Commands.Init diff --git a/src/Ampersand/Commands/Population.hs b/src/Ampersand/Commands/Population.hs index f28eaeedf4..50e41277b2 100644 --- a/src/Ampersand/Commands/Population.hs +++ b/src/Ampersand/Commands/Population.hs @@ -1,7 +1,6 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} + -- | Generate an .xlsx file containing the population from a project. module Ampersand.Commands.Population diff --git a/src/Ampersand/Commands/Proof.hs b/src/Ampersand/Commands/Proof.hs index e6da2645b9..e22d48ee68 100644 --- a/src/Ampersand/Commands/Proof.hs +++ b/src/Ampersand/Commands/Proof.hs @@ -1,7 +1,6 @@ -{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} + -- | Generate a proofs output document from a project. module Ampersand.Commands.Proof diff --git a/src/Ampersand/Commands/Proto.hs b/src/Ampersand/Commands/Proto.hs index 18eaa12cc6..ae8e39a604 100644 --- a/src/Ampersand/Commands/Proto.hs +++ b/src/Ampersand/Commands/Proto.hs @@ -1,7 +1,6 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} + -- | Generate a prototype from a project. module Ampersand.Commands.Proto @@ -13,13 +12,22 @@ module Ampersand.Commands.Proto import Ampersand.Basics import Ampersand.FSpec import Ampersand.Misc.HasClasses -import Ampersand.Prototype.GenFrontend (doGenFrontend, doGenBackend, copyCustomizations) +import Ampersand.Prototype.GenFrontend import Ampersand.Types.Config import qualified RIO.Text as T import System.Directory -- | Builds a prototype of the current project. --- -proto :: (Show env, HasRunner env, HasFSpecGenOpts env, HasDirCustomizations env, HasZwolleVersion env, HasProtoOpts env, HasDirPrototype env, HasGenerateFrontend env, HasGenerateBackend env) +proto :: ( Show env + , HasRunner env + , HasFSpecGenOpts env + , HasDirCustomizations env + , HasZwolleVersion env + , HasProtoOpts env + , HasDirPrototype env + , HasGenerateFrontend env + , HasGenerateBackend env + , HasGenerateMetamodel env + ) => FSpec -> RIO env () proto fSpec = do env <- ask @@ -27,14 +35,17 @@ proto fSpec = do logDebug "Generating prototype..." liftIO $ createDirectoryIfMissing True dirPrototype generateFrontend <- view generateFrontendL - generateBackend <- view generateBackendL if generateFrontend then do doGenFrontend fSpec else do logDebug " Skipping generating frontend files" + generateBackend <- view generateBackendL if generateBackend then do doGenBackend fSpec else do logDebug " Skipping generating backend files" + generateMetamodel <- view generateMetamodelL + if generateMetamodel + then do doGenMetaModel fSpec + else do logDebug " Skipping generating metamodel.adl" copyCustomizations dirPrototypeA <- liftIO $ makeAbsolute dirPrototype logInfo $ "Prototype files have been written to " <> display (T.pack dirPrototypeA) - diff --git a/src/Ampersand/Commands/Test.hs b/src/Ampersand/Commands/Test.hs index 29a62ed1de..eef8528d81 100644 --- a/src/Ampersand/Commands/Test.hs +++ b/src/Ampersand/Commands/Test.hs @@ -1,7 +1,6 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE NoImplicitPrelude #-} + -- | Generate a prototype from a project. module Ampersand.Commands.Test diff --git a/src/Ampersand/Commands/Uml.hs b/src/Ampersand/Commands/Uml.hs index 11e11fe80c..8c5f7e2208 100644 --- a/src/Ampersand/Commands/Uml.hs +++ b/src/Ampersand/Commands/Uml.hs @@ -1,7 +1,6 @@ -{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} + -- | Generate a UML output file from a project. module Ampersand.Commands.Uml diff --git a/src/Ampersand/Commands/Validate.hs b/src/Ampersand/Commands/Validate.hs index 34a4e3c12d..5cec1e4ba8 100644 --- a/src/Ampersand/Commands/Validate.hs +++ b/src/Ampersand/Commands/Validate.hs @@ -1,7 +1,6 @@ -{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} + -- | Generate a prototype from a project. module Ampersand.Commands.Validate diff --git a/src/Ampersand/Core/A2P_Converters.hs b/src/Ampersand/Core/A2P_Converters.hs index 9d623f148a..32a210bdfe 100644 --- a/src/Ampersand/Core/A2P_Converters.hs +++ b/src/Ampersand/Core/A2P_Converters.hs @@ -1,5 +1,5 @@ {-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE OverloadedStrings #-} + module Ampersand.Core.A2P_Converters ( aAtomValue2pAtomValue , aConcept2pConcept @@ -102,7 +102,7 @@ aRelation2pNamedRel dcl = PNamedRel , p_mbSign = Just . aSign2pSign $ decsgn dcl } -aIdentityDef2pIdentityDef :: IdentityDef -> P_IdentDf TermPrim -- P_IdentDef +aIdentityDef2pIdentityDef :: IdentityRule -> P_IdentDf TermPrim -- P_IdentDef aIdentityDef2pIdentityDef iDef = P_Id { pos = idPos iDef , ix_lbl = idLbl iDef @@ -148,7 +148,7 @@ aInterface2pInterface ifc = , ifc_Roles = ifcRoles ifc , ifc_Obj = aObjectDef2pObjectDef (BxExpr (ifcObj ifc)) , pos = origin ifc - , ifc_Prp = ifcPrp ifc + , ifc_Prp = ifcPurpose ifc } diff --git a/src/Ampersand/Core/AbstractSyntaxTree.hs b/src/Ampersand/Core/AbstractSyntaxTree.hs index e41f45f45e..2c1a777a2c 100644 --- a/src/Ampersand/Core/AbstractSyntaxTree.hs +++ b/src/Ampersand/Core/AbstractSyntaxTree.hs @@ -7,7 +7,7 @@ module Ampersand.Core.AbstractSyntaxTree ( A_Context(..) , Typology(..) - , Meta(..) + , MetaData(..) , Origin(..) , Pattern(..) , PairView(..) @@ -15,7 +15,7 @@ module Ampersand.Core.AbstractSyntaxTree ( , Rule(..), Rules , RuleOrigin(..) , Relation(..), Relations, showRel - , IdentityDef(..) + , IdentityRule(..) , IdentitySegment(..) , ViewDef(..) , ViewSegment(..) @@ -56,7 +56,7 @@ module Ampersand.Core.AbstractSyntaxTree ( ) where import Ampersand.Basics import Ampersand.Core.ParseTree - ( Meta(..) + ( MetaData(..) , Role(..) , P_Concept(..), mkPConcept, PClassify(specific,generics) , Origin(..) @@ -82,27 +82,27 @@ import qualified RIO.Text as T import RIO.Time data A_Context - = ACtx{ ctxnm :: Text -- ^ The name of this context - , ctxpos :: [Origin] -- ^ The origin of the context. A context can be a merge of a file including other files c.q. a list of Origin. - , ctxlang :: Lang -- ^ The default language used in this context. - , ctxmarkup :: PandocFormat -- ^ The default markup format for free text in this context. - , ctxpats :: [Pattern] -- ^ The patterns defined in this context - , ctxrs :: Rules -- ^ All user defined rules in this context, but outside patterns and outside processes - , ctxds :: Relations -- ^ The relations that are declared in this context, outside the scope of patterns - , ctxpopus :: [Population] -- ^ The user defined populations of relations defined in this context, including those from patterns and processes - , ctxcdsOutPats :: [AConceptDef] -- ^ The concept definitions defined outside the patterns of this context. - , ctxcds :: [AConceptDef] -- ^ The concept definitions defined in this context, including those from patterns and processes - , ctxks :: [IdentityDef] -- ^ The identity definitions defined in this context, outside the scope of patterns + = ACtx{ ctxnm :: Text -- ^ The name of this context + , ctxpos :: [Origin] -- ^ The origin of the context. A context can be a merge of a file including other files c.q. a list of Origin. + , ctxlang :: Lang -- ^ The default language used in this context. + , ctxmarkup :: PandocFormat -- ^ The default markup format for free text in this context. + , ctxpats :: [Pattern] -- ^ The patterns defined in this context + , ctxrs :: Rules -- ^ All user defined rules in this context, but outside patterns and outside processes + , ctxds :: Relations -- ^ The relations that are declared in this context, outside the scope of patterns + , ctxpopus :: [Population] -- ^ The user defined populations of relations defined in this context, including those from patterns and processes + , ctxcdsOutPats :: [AConceptDef] -- ^ The concept definitions defined outside the patterns of this context. + , ctxcds :: [AConceptDef] -- ^ The concept definitions defined in this context, including those from patterns + , ctxks :: [IdentityRule] -- ^ The identity definitions defined in this context, outside the scope of patterns , ctxrrules :: [A_RoleRule] , ctxreprs :: A_Concept -> TType - , ctxvs :: [ViewDef] -- ^ The view definitions defined in this context, outside the scope of patterns - , ctxgs :: [AClassify] -- ^ The specialization statements defined in this context, outside the scope of patterns - , ctxgenconcs :: [[A_Concept]] -- ^ A partitioning of all concepts: the union of all these concepts contains all atoms, and the concept-lists are mutually distinct in terms of atoms in one of the mentioned concepts - , ctxifcs :: [Interface] -- ^ The interfaces defined in this context - , ctxps :: [Purpose] -- ^ The purposes of objects defined in this context, outside the scope of patterns and processes - , ctxmetas :: [Meta] -- ^ used for Pandoc authors (and possibly other things) + , ctxvs :: [ViewDef] -- ^ The view definitions defined in this context, outside the scope of patterns + , ctxgs :: [AClassify] -- ^ The specialization statements defined in this context, outside the scope of patterns + , ctxgenconcs :: [[A_Concept]] -- ^ A partitioning of all concepts: the union of all these concepts contains all atoms, and the concept-lists are mutually distinct in terms of atoms in one of the mentioned concepts + , ctxifcs :: [Interface] -- ^ The interfaces defined in this context + , ctxps :: [Purpose] -- ^ The purposes of objects defined in this context, outside the scope of patterns and processes + , ctxmetas :: [MetaData] -- ^ used for Pandoc authors (and possibly other things) , ctxInfo :: ContextInfo - } deriving (Typeable) --deriving (Show) -- voor debugging + } deriving (Typeable) instance Show A_Context where show = T.unpack . name instance Eq A_Context where @@ -123,7 +123,7 @@ data Pattern , ptcds :: [AConceptDef] -- ^ The concept definitions that are declared in this pattern , ptrps :: [Representation] -- ^ The concept definitions that are declared in this pattern , ptups :: [Population] -- ^ The user defined populations in this pattern - , ptids :: [IdentityDef] -- ^ The identity definitions defined in this pattern + , ptids :: [IdentityRule] -- ^ The identity definitions defined in this pattern , ptvds :: [ViewDef] -- ^ The view definitions defined in this pattern , ptxps :: [Purpose] -- ^ The purposes of elements defined in this pattern } deriving (Typeable) -- Show for debugging purposes @@ -276,21 +276,21 @@ instance HasSignature Relation where instance Traced Relation where origin = decfpos -data IdentityDef = Id { idPos :: Origin -- ^ position of this definition in the text of the Ampersand source file (filename, line number and column number). +data IdentityRule = Id { idPos :: Origin -- ^ position of this definition in the text of the Ampersand source file (filename, line number and column number). , idLbl :: Text -- ^ the name (or label) of this Identity. The label has no meaning in the Compliant Service Layer, but is used in the generated user interface. It is not an empty string. , idCpt :: A_Concept -- ^ this expression describes the instances of this object, related to their context , idPat :: Maybe Text -- ^ if defined within a pattern, then the name of that pattern. , identityAts :: NE.NonEmpty IdentitySegment -- ^ the constituent attributes (i.e. name/expression pairs) of this identity. } deriving (Show) -instance Named IdentityDef where +instance Named IdentityRule where name = idLbl -instance Traced IdentityDef where +instance Traced IdentityRule where origin = idPos -instance Unique IdentityDef where +instance Unique IdentityRule where showUnique = name -instance Ord IdentityDef where +instance Ord IdentityRule where compare a b = name a `compare` name b -instance Eq IdentityDef where +instance Eq IdentityRule where a == b = compare a b == EQ newtype IdentitySegment = IdentityExp { segment :: ObjectDef @@ -376,9 +376,9 @@ data Interface = Ifc { ifcIsAPI :: Bool -- is this interface of type , ifcname :: Text -- all roles for which an interface is available (empty means: available for all roles) , ifcRoles :: [Role] -- all roles for which an interface is available (empty means: available for all roles) , ifcObj :: ObjectDef -- NOTE: this top-level ObjectDef is contains the interface itself (ie. name and expression) - , ifcControls :: [Conjunct] -- All conjuncts that must be evaluated after a transaction + , ifcConjuncts :: [Conjunct] -- All conjuncts that must be evaluated after a transaction , ifcPos :: Origin -- The position in the file (filename, line- and column number) - , ifcPrp :: Text -- The purpose of the interface + , ifcPurpose :: Text -- The purpose of the interface } deriving Show instance Eq Interface where @@ -445,7 +445,7 @@ instance Eq BoxTxt where a == b = compare a b == EQ data ObjectDef = ObjectDef { objnm :: Text -- ^ view name of the object definition. The label has no meaning in the Compliant Service Layer, but is used in the generated user interface if it is not an empty string. - , objpos :: Origin -- ^ position of this definition in the text of the Ampersand source file (filename, line number and column number) + , objPos :: Origin -- ^ position of this definition in the text of the Ampersand source file (filename, line number and column number) , objExpression :: Expression -- ^ this expression describes the instances of this object, related to their context. , objcrud :: Cruds -- ^ CRUD as defined by the user , objmView :: Maybe Text -- ^ The view that should be used for this object @@ -454,7 +454,7 @@ data ObjectDef = instance Named ObjectDef where name = objnm instance Traced ObjectDef where - origin = objpos + origin = objPos instance Unique ObjectDef where showUnique = tshow instance Ord ObjectDef where @@ -843,6 +843,8 @@ instance Eq A_Concept where -} +instance Unique AConceptDef where + showUnique = tshow . name instance Unique A_Concept where showUnique = tshow instance Hashable A_Concept where diff --git a/src/Ampersand/Core/ParseTree.hs b/src/Ampersand/Core/ParseTree.hs index 6f0935682a..c1021d0a06 100644 --- a/src/Ampersand/Core/ParseTree.hs +++ b/src/Ampersand/Core/ParseTree.hs @@ -4,7 +4,7 @@ {-# LANGUAGE OverloadedStrings#-} module Ampersand.Core.ParseTree ( P_Context(..), mergeContexts - , Meta(..) + , MetaData(..) , P_RoleRule(..) , Role(..) , P_Pattern(..) @@ -64,7 +64,7 @@ data P_Context , ctx_ifcs :: [P_Interface] -- ^ The interfaces defined in this context , ctx_ps :: [PPurpose] -- ^ The purposes defined in this context, outside the scope of patterns and processes , ctx_pops :: [P_Population] -- ^ The populations defined in this context (without patterns), from POPULATION statements as well as from Relation declarations - , ctx_metas :: [Meta] -- ^ generic meta information (name/value pairs) that can be used for experimenting without having to modify the adl syntax + , ctx_metas :: [MetaData] -- ^ generic meta information (name/value pairs) that can be used for experimenting without having to modify the adl syntax } deriving Show --for QuickCheck instance Eq P_Context where @@ -73,11 +73,11 @@ instance Named P_Context where name = ctx_nm -- for declaring name/value pairs with information that is built in to the adl syntax yet -data Meta = Meta { pos :: Origin +data MetaData = MetaData { pos :: Origin , mtName :: Text , mtVal :: Text } deriving (Show) -instance Traced Meta where +instance Traced MetaData where origin = pos -- | A RoleRule r means that a role called 'mRoles r' must maintain the process rule called 'mRules r' @@ -840,8 +840,8 @@ instance Ord PPurpose where --Required for merge of P_Contexts , tshow (origin b) ]) (maybeOrdering (origin a) (origin b)) - x -> x + instance Eq PPurpose where --Required for merge of P_Contexts a == b = compare a b == EQ @@ -898,7 +898,7 @@ data Prop = Uni -- ^ univalent | Trn -- ^ transitive | Rfx -- ^ reflexive | Irf -- ^ irreflexive - | Prop -- ^ PROP keyword, later replaced by [Sym, Asy] + | 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 diff --git a/src/Ampersand/Core/ShowAStruct.hs b/src/Ampersand/Core/ShowAStruct.hs index 18320f0bd6..499fdbab0f 100644 --- a/src/Ampersand/Core/ShowAStruct.hs +++ b/src/Ampersand/Core/ShowAStruct.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE OverloadedStrings #-} + module Ampersand.Core.ShowAStruct (AStruct(..)) where diff --git a/src/Ampersand/Daemon/Daemon.hs b/src/Ampersand/Daemon/Daemon.hs index ad60ba20fd..20a43f8762 100644 --- a/src/Ampersand/Daemon/Daemon.hs +++ b/src/Ampersand/Daemon/Daemon.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE OverloadedStrings #-} + -- | Library for spawning and working with Ghci sessions. -- _Acknoledgements_: This is mainly copied from Neil Mitchells ghcid. module Ampersand.Daemon.Daemon( diff --git a/src/Ampersand/Daemon/Parser.hs b/src/Ampersand/Daemon/Parser.hs index a0d9c6d8a1..67a922146f 100644 --- a/src/Ampersand/Daemon/Parser.hs +++ b/src/Ampersand/Daemon/Parser.hs @@ -1,5 +1,5 @@ {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedStrings #-} + -- | Reads a project and parses it module Ampersand.Daemon.Parser ( parseProject @@ -13,17 +13,17 @@ import Ampersand.Input.ADL1.CtxError import qualified RIO.NonEmpty as NE import Ampersand.FSpec.MetaModels import Ampersand.Types.Config -import Ampersand.Misc.HasClasses (HasRootFile(..),rootFileL, HasDaemonOpts(..), showWarningsL) +import Ampersand.Misc.HasClasses (HasRootFile(..),rootFileL, HasDaemonOpts(..), showWarningsL,Roots(..)) -- | parseProject will try to parse a file. If it succeeds, it will --- also parse all INCLUDED files transitive. Any of these parses could +-- also parse all INCLUDED files transitively. Any of these parses could -- fail. It will return a tuple containing the Loads and a list of -- the filepaths that are read. parseProject :: (HasDaemonOpts env, HasRunner env) => FilePath -> RIO env ([Load],[FilePath]) -parseProject rootAdl = local (set rootFileL (Just rootAdl)) $ do +parseProject rootAdl = local (set rootFileL (Roots [rootAdl])) $ do showWarnings <- view showWarningsL - (pc,gPctx) <- parseFileTransitive rootAdl + (pc,gPctx) <- parseFilesTransitive (Roots [rootAdl]) env <- ask let loadedFiles = map pcCanonical pc gActx = pCtx2Fspec env =<< gPctx diff --git a/src/Ampersand/Daemon/Wait.hs b/src/Ampersand/Daemon/Wait.hs index 7600e76af6..28c97dedb8 100644 --- a/src/Ampersand/Daemon/Wait.hs +++ b/src/Ampersand/Daemon/Wait.hs @@ -1,5 +1,5 @@ {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE OverloadedStrings #-} + -- | Use 'withWaiterPoll' or 'withWaiterNotify' to create a 'Waiter' object, -- then access it (single-threaded) by using 'waitFiles'. diff --git a/src/Ampersand/FSpec/Crud.hs b/src/Ampersand/FSpec/Crud.hs index 475b2757ff..1c674fe647 100644 --- a/src/Ampersand/FSpec/Crud.hs +++ b/src/Ampersand/FSpec/Crud.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE OverloadedStrings #-} + module Ampersand.FSpec.Crud (CrudInfo(..), getCrudObjectsForInterface, mkCrudInfo) where import Ampersand.Basics diff --git a/src/Ampersand/FSpec/FPA.hs b/src/Ampersand/FSpec/FPA.hs index 3f08b6e96f..f328f74b3e 100644 --- a/src/Ampersand/FSpec/FPA.hs +++ b/src/Ampersand/FSpec/FPA.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE OverloadedStrings #-} + module Ampersand.FSpec.FPA (FPA(..), FP(..), FPType(..), ShowLang(..), fpAnalyze, fpVal, fpaPlugInfo, fpaInterface) where -- fpaPlugInfo and fpaInterface are exported for legacy modules Statistics and FSpec2Excel diff --git a/src/Ampersand/FSpec/FSpec.hs b/src/Ampersand/FSpec/FSpec.hs index e5e2b820ef..91e92e90c0 100644 --- a/src/Ampersand/FSpec/FSpec.hs +++ b/src/Ampersand/FSpec/FSpec.hs @@ -1,6 +1,6 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedStrings #-} + {- | The intentions behind FSpec (SJ 30 dec 2008): Generation of functional designs is a core functionality of Ampersand. All items in a specification are generated into the following data structure, FSpec. @@ -10,7 +10,7 @@ All generators (such as the code generator, the proof generator, the atlas gener are merely different ways to show FSpec. -} module Ampersand.FSpec.FSpec - ( FSpec(..), concDefs, Atom(..), A_Pair(..) + ( FSpec(..), emptyFSpec, concDefs, Atom(..), APair(..) , Quad(..) , PlugSQL(..),plugAttributes , lookupCpt, getConceptTableFor @@ -81,7 +81,7 @@ data FSpec = FSpec { fsName :: Text , allConcepts :: A_Concepts -- ^ All concepts in the fSpec , cptTType :: A_Concept -> TType - , vIndices :: [IdentityDef] + , vIndices :: [IdentityRule] -- ^ All keys that apply in the entire FSpec , vviews :: [ViewDef] -- ^ All views that apply in the entire FSpec @@ -109,7 +109,7 @@ data FSpec = FSpec { fsName :: Text -- ^ All concept definitions defined throughout a context, including those inside patterns and processes , fSexpls :: Set.Set Purpose -- ^ All purposes that have been declared anywhere in the current specification, including the patterns and interfaces. - , metas :: [Meta] + , metas :: [MetaData] -- ^ All meta relations from the entire context , crudInfo :: CrudInfo -- ^ Information for CRUD matrices @@ -182,13 +182,13 @@ instance Unique Atom where [x] -> uniqueShowWithType x xs -> "["<>T.intercalate ", " (map uniqueShowWithType xs)<>"]" -data A_Pair = Pair { lnkDcl :: Relation - , lnkLeft :: Atom - , lnkRight :: Atom - } deriving (Typeable,Eq) -instance HasSignature A_Pair where +data APair = Pair { lnkDcl :: Relation + , lnkLeft :: Atom + , lnkRight :: Atom + } deriving (Typeable,Eq) +instance HasSignature APair where sign = sign . lnkDcl -instance Unique A_Pair where +instance Unique APair where showUnique x = showUnique (lnkDcl x) <> showUnique (lnkLeft x) <> showUnique (lnkRight x) @@ -238,6 +238,8 @@ instance Ord Quad where q `compare` q' = (qDcl q,qRule q) `compare` (qDcl q',qRule q') instance Eq Quad where a == b = compare a b == EQ +instance Unique Quad where + showUnique quad = "ONCHANGE "<>showRel (qDcl quad)<>" FIX "<>name (qRule quad) -- dnf2expr :: DnfClause -> Expression @@ -266,15 +268,15 @@ data PlugSQL -- <> [target r | r::A*B,isUni r, not(isTot r), not(isSur r)] -- kernel = A closure of concepts A,B for which there exists a r::A->B[INJ] -- (r=attExpr of kernel attribute holding instances of B, in practice r is I or a makeRelation(flipped relation)) - -- attribute relations = All concepts B, A in kernel for which there exists a r::A*B[UNI] and r not TOT and SUR + -- attribute relations = All concepts B, A in kernel for which there exists a r::A*B[UNI] and r not TOT and SUR -- (r=attExpr of attMor attribute, in practice r is a makeRelation(relation)) = TblSQL { sqlname :: Text - , attributes :: [SqlAttribute] -- ^ the first attribute is the concept table of the most general concept (e.g. Person) - -- then follow concept tables of specializations. Together with the first attribute this is called the "kernel" - -- the remaining attributes represent attributes. - , cLkpTbl :: [(A_Concept,SqlAttribute)] -- ^ lookup table that links all typology concepts to attributes in the plug - -- cLkpTbl is een lijst concepten die in deze plug opgeslagen zitten, en hoe je ze eruit kunt halen - , dLkpTbl :: [RelStore] + , attributes :: [SqlAttribute] -- ^ the first attribute is the concept table of the most general concept (e.g. Person) + -- then follow concept tables of specializations. Together with the first attribute this is called the "kernel" + -- the remaining attributes represent attributes. + , cLkpTbl :: [(A_Concept,SqlAttribute)] -- ^ lookup table that links all typology concepts to attributes in the plug + -- cLkpTbl is een lijst concepten die in deze plug opgeslagen zitten, en hoe je ze eruit kunt halen + , dLkpTbl :: [RelStore] } -- | stores one relation r in two ordered columns -- i.e. a tuple of SqlAttribute -> (source r,target r) with (attExpr=I/\r;r~, attExpr=r) @@ -316,13 +318,14 @@ lookupCpt fSpec cpt = [(plug,att) , c==cpt ] --- Convenience function that returns the name of the table that contains the concept table (or more accurately concept column) for c -getConceptTableFor :: FSpec -> A_Concept -> PlugSQL +-- getConceptTableFor yields the plug that contains all atoms of A_Concept c. Since there may be more of them, the first one is returned. +getConceptTableFor :: FSpec -> A_Concept -> PlugSQL -- this corresponds to sqlConceptPlug in SQL.hs getConceptTableFor fSpec c = case lookupCpt fSpec c of [] -> fatal $ "tableFor: No concept table for " <> name c (t,_):_ -> t -- in case there are more, we use the first one -- | Information about the source and target attributes of a relation in an sqlTable. The relation could be stored either flipped or not. +-- A RelStore is used to identify a relation within a persistent store. data RelStore = RelStore { rsDcl :: Relation @@ -414,3 +417,103 @@ violationsOfInvariants fSpec ] defOutputLang :: FSpec -> Lang defOutputLang = ctxlang . originalContext + +emptyFSpec :: FSpec +emptyFSpec = FSpec { fsName = "" + -- The name of the specification, taken from the Ampersand script + , originalContext = fatal "Don't ask for the original context in the empty FSpec." + -- the original context. (for showA) + , fspos = [] + -- The origin of the FSpec. An FSpec can be a merge of a file including other files c.q. a list of Origin. + , plugInfos = [] + -- All plugs (derived) + , interfaceS = [] + -- All interfaces defined in the Ampersand script + , interfaceG = [] + -- All interfaces derived from the basic ontology (the Lonneker interface) + , roleInterfaces = fatal "Don't ask for the role-interface constraints in the empty FSpec." + -- All interfaces defined in the Ampersand script, for use by a specific Role + , fDeriveProofs = mempty + -- The proofs in Pandoc format + , fRoleRuls = [] + -- the relation saying which roles maintain which rules. + , fMaintains = fatal "Don't ask for the maintainer roles in the empty FSpec." + , fRoles = [] + -- All roles mentioned in this context, numbered. + , fallRules = Set.empty + , vrules = Set.empty + -- All user defined rules that apply in the entire FSpec + , grules = Set.empty + -- All rules that are generated: multiplicity rules and identity rules + , invariants = Set.empty + -- All invariant rules + , signals = Set.empty + -- All signal rules + , allUsedDecls = Set.empty + -- All relations that are used in the fSpec + , vrels = Set.empty + -- All user defined and generated relations plus all defined and computed totals. + -- The generated relations are all generalizations and + -- one relation for each signal. + , allConcepts = Set.empty + -- All concepts in the fSpec + , cptTType = fatal "Don't ask for the concept-TType relation in the empty FSpec." + , vIndices = [] + -- All keys that apply in the entire FSpec + , vviews = [] + -- All views that apply in the entire FSpec + , getDefaultViewForConcept = fatal "Don't ask for the default views in the empty FSpec." + , getAllViewsForConcept = fatal "Don't ask for the views in the empty FSpec." + , lookupView = fatal "Don't ask for the lookupView in the empty FSpec." + -- Lookup view by id in fSpec. + , vgens = [] + -- All gens that apply in the entire FSpec + , allConjuncts = [] + -- All conjuncts generated (by ADL2FSpec) + , allConjsPerRule = [] + -- Maps each rule onto the conjuncts it consists of (note that a single conjunct may be part of several rules) + , allConjsPerDecl = [] + -- Maps each relation to the conjuncts it appears in + , allConjsPerConcept = [] + -- Maps each concept to the conjuncts it appears in (as source or target of a constituent relation) + , vquads = [] + -- All quads generated (by ADL2FSpec) + , fsisa = [] + -- generated: The data structure containing the generalization structure of concepts + , vpatterns = [] + -- All patterns taken from the Ampersand script + , conceptDefs = [] + -- All concept definitions defined throughout a context, including those inside patterns and processes + , fSexpls = Set.empty + -- All purposes that have been declared anywhere in the current specification, including the patterns and interfaces. + , metas = [] + -- All meta relations from the entire context + , crudInfo = fatal "Don't ask for crud information in the empty FSpec." + -- Information for CRUD matrices + , atomsInCptIncludingSmaller = fatal "Don't ask for atoms in the empty FSpec." + -- All user defined populations of an A_concept, INCLUDING the populations of smaller A_Concepts + , atomsBySmallestConcept = fatal "Don't ask for atoms in the empty FSpec." + -- All user defined populations of an A_Concept, where a population is NOT listed iff it also is in a smaller A_Concept. + , tableContents = fatal "Don't ask for table contents in the empty FSpec." + -- tableContents is meant to compute the contents of an entity table. + -- It yields a list of records. Values in the records may be absent, which is why Maybe is used rather than Text. + -- SJ 2016-05-06: Why is that? `tableContents` should represent a set of atoms, so `Maybe` should have no part in this. Why is Maybe necessary? + -- HJO 2016-09-05: Answer: Broad tables may contain rows where some of the attributes implement a relation that is UNI, but not TOT. In such case, + -- we may see empty attributes. (NULL values in database terminology) + -- 'tableContents fSpec plug' is used in `PHP.hs` for filling the database initially. + -- 'tableContents fSpec plug' is used in `Population2Xlsx.hs` for filling a spreadsheet. + , pairsInExpr = fatal "Don't ask for pairs from expressions in the empty FSpec." + , applyViolText = fatal "Don't ask for the function applyViolText in the empty FSpec." + , initialConjunctSignals = [] + -- All conjuncts that have process-rule violations. + , allViolations = [] + -- All invariant rules with violations. + , allExprs = Set.empty + -- All expressions in the fSpec + , fcontextInfo = fatal "Don't ask for the original context in the empty FSpec." + , ftypologies = [] + , typologyOf = fatal "Don't ask for typologies in the empty FSpec." + , largestConcept = fatal "Don't ask for the largest concept in the empty FSpec." + , specializationsOf = fatal "Don't ask for specializations in the empty FSpec." + , generalizationsOf = fatal "Don't ask for generalizations in the empty FSpec." + } diff --git a/src/Ampersand/FSpec/FSpecAux.hs b/src/Ampersand/FSpec/FSpecAux.hs index 215c7a03d6..38d5d87ab7 100644 --- a/src/Ampersand/FSpec/FSpecAux.hs +++ b/src/Ampersand/FSpec/FSpecAux.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE OverloadedStrings #-} + module Ampersand.FSpec.FSpecAux (getRelationTableInfo,getConceptTableInfo) where diff --git a/src/Ampersand/FSpec/GenerateUML.hs b/src/Ampersand/FSpec/GenerateUML.hs index 484a21f962..3d56a14b8e 100644 --- a/src/Ampersand/FSpec/GenerateUML.hs +++ b/src/Ampersand/FSpec/GenerateUML.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE OverloadedStrings #-} + module Ampersand.FSpec.GenerateUML (generateUML) where import Ampersand.Basics diff --git a/src/Ampersand/FSpec/MetaModels.hs b/src/Ampersand/FSpec/MetaModels.hs index 0dced071a6..0403b17661 100644 --- a/src/Ampersand/FSpec/MetaModels.hs +++ b/src/Ampersand/FSpec/MetaModels.hs @@ -1,10 +1,7 @@ {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE OverloadedStrings #-} + module Ampersand.FSpec.MetaModels ( MetaModel(..) - , mkGrindInfo - , GrindInfo - , grind , pCtx2Fspec ) @@ -15,15 +12,9 @@ import Ampersand.Basics import Ampersand.FSpec.FSpec import Ampersand.FSpec.ShowMeatGrinder import Ampersand.FSpec.ToFSpec.ADL2FSpec -import Ampersand.FSpec.Transformers import Ampersand.Input import Ampersand.Misc.HasClasses import qualified RIO.NonEmpty as NE -import qualified RIO.Text as T - -parser :: (HasLogFunc env, HasFSpecGenOpts env) => MetaModel -> RIO env (Guarded P_Context) -parser FormalAmpersand = parseFormalAmpersand -parser PrototypeContext = parsePrototypeContext pCtx2Fspec :: (HasFSpecGenOpts env) => env -> P_Context -> Guarded FSpec pCtx2Fspec env c = do @@ -38,34 +29,4 @@ pCtx2Fspec env c = do else case violationsOfInvariants fSpec of [] -> pure fSpec - h:tl -> (Errors . fmap (mkInvariantViolationsError (applyViolText fSpec))) (h NE.:| tl) - - -mkGrindInfo :: (HasFSpecGenOpts env, HasLogFunc env) => MetaModel -> RIO env GrindInfo -mkGrindInfo metamodel = do - env <- ask - build env <$> parser metamodel - where - build :: (HasFSpecGenOpts env) => - env -> Guarded P_Context -> GrindInfo - build env pCtx = GrindInfo - { metaModel = metamodel - , pModel = case pCtx of - Errors errs -> fatal $ showWithHeader - ("The ADL scripts of "<>name metamodel<>" cannot be parsed:") errs - Checked x [] -> x - Checked _ (h:tl) -> fatal $ showWithHeader - ("The ADL scripts of "<>name metamodel<>" are not free of warnings:") (h NE.:|tl) - , fModel = - case pCtx2Fspec env =<< pCtx of - Errors errs -> fatal $ showWithHeader - ("The ADL scripts of "<>name metamodel<>" cannot be parsed:") errs - Checked x [] -> x - Checked _ (h:tl) -> fatal $ showWithHeader - ("The ADL scripts of "<>name metamodel<>" are not free of warnings:") (h NE.:|tl) - , transformers = case metamodel of - FormalAmpersand -> transformersFormalAmpersand - PrototypeContext -> transformersPrototypeContext - } - where showWithHeader :: Show a => Text -> NE.NonEmpty a -> Text - showWithHeader txt xs = T.intercalate "\n" $ txt : (map tshow . NE.toList $ xs) + h:tl -> Errors (fmap (mkInvariantViolationsError (applyViolText fSpec)) (h NE.:| tl)) diff --git a/src/Ampersand/FSpec/Motivations.hs b/src/Ampersand/FSpec/Motivations.hs index 69e065cee3..b7852dcd17 100644 --- a/src/Ampersand/FSpec/Motivations.hs +++ b/src/Ampersand/FSpec/Motivations.hs @@ -1,6 +1,6 @@ --TODO -> Maybe this module is useful at more places than just func spec rendering. -- In that case it's not a Rendering module and it needs to be replaced -{-# LANGUAGE OverloadedStrings #-} + module Ampersand.FSpec.Motivations ( Motivated (purposesOf), HasMeaning(meaning,meanings)) diff --git a/src/Ampersand/FSpec/SQL.hs b/src/Ampersand/FSpec/SQL.hs index 982c41aaeb..9d9eba73ab 100644 --- a/src/Ampersand/FSpec/SQL.hs +++ b/src/Ampersand/FSpec/SQL.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE OverloadedStrings #-} + module Ampersand.FSpec.SQL ( SqlQuery(..) , placeHolderSQL @@ -127,7 +127,7 @@ selectExpr :: FSpec -- current context -- The other operators, EEqu ( = ), EInc ( |- ), ERad ( ! ), EPrd ( * ), ELrs ( / ), ERrs ( \ ), and EDia ( <> ), have been implemented in terms of the previous ones, -- in order to prevent mistakes in the code generator. It is possible that more efficient code may be generated in these cases. -- Special cases are treated up front, so they will overrule the more general cases. --- That allows more efficient code while retaining correctness and completeness as much as possible. +-- That allows more efficient code while retaining completeness. -- Code for the Kleene operators EKl0 ( * ) and EKl1 ( + ) is not done, because this cannot be expressed in SQL. -- These operators must be eliminated from the Expression before using selectExpr, or else you will get fatals. selectExpr fSpec expr @@ -140,10 +140,10 @@ selectExpr fSpec expr maybeSpecialCase :: FSpec -> Expression -> Maybe BinQueryExpr maybeSpecialCase fSpec expr = case expr of - EIsc (EDcI a , ECpl (ECps (EDcD r,EFlp (EDcD r')) )) + EIsc (EDcI a, ECpl (ECps (EDcD r,EFlp (EDcD r')) )) -- I[A] /\ -(r;r~) | r == r' -> Just . traceComment - [ "case: EIsc (EDcI a , ECpl (ECps (EDcD r,EFlp (EDcD r')) ))" + [ "case: EIsc (EDcI a, ECpl (ECps (EDcD r,EFlp (EDcD r')) ))" , " this is an optimized case for: "<>name r<>showSign r<>" [TOT]." ] $ @@ -164,8 +164,12 @@ maybeSpecialCase fSpec expr = , bseWhr = Just whereClause } | otherwise -> Nothing - EIsc (ECpl (ECps (EDcD r,EFlp (EDcD r')) ),EDcI a ) - -> maybeSpecialCase fSpec $ EIsc (EDcI a , ECpl (ECps (EDcD r,EFlp (EDcD r')) )) + EIsc (ECpl (ECps (EDcD r,EFlp (EDcD r')) ),EDcI a ) -- -(r;r~) /\ I[A] + | r == r' -> maybeSpecialCase fSpec $ EIsc (EDcI a, ECpl (ECps (EDcD r,EFlp (EDcD r')) )) + | otherwise -> Nothing + EDif (EDcI a, ECps (EDcD r,EFlp (EDcD r'))) -- I[A] - r;r~ + | r == r' -> maybeSpecialCase fSpec $ EIsc (EDcI a, ECpl (ECps (EDcD r,EFlp (EDcD r')) )) + | otherwise -> Nothing EIsc (expr1 , ECpl expr2) -> go False expr1 expr2 EIsc (ECpl expr1 , expr2) @@ -460,25 +464,28 @@ nonSpecialSelectExpr fSpec expr= } ECps{} -> - let es = exprCps2list expr - hes = NE.head es - tles = NE.tail es in - case tles of - []-> traceComment ["case: ECps{}"] $ selectExpr fSpec hes -- Even though this case cannot occur, it safeguards that there are two or more elements in exprCps2list expr in the remainder of this code. -{- We can treat the ECps expressions as poles-and-fences, with at least two fences. +{- We treat the ECps expressions as poles-and-fences, with at least two fences. + Imagine subexpressions as "fences". + The source and target of a "fence" are the "poles" between which that "fence" is mounted. + The "outer poles" correspond to the source and target of the entire expression. We start numbering the fences with 0. Each fence is connected to the previous fence with a pole. - the pole holds the constraints of the connection of the fence to the previous fence. Only pole 0 has no previous - fence, so ther are no constraints. - In general, at some pole i, the constraint is that fence(i-1).trg=fencei.src + the pole holds the constraints of the connection of the fence to the previous fence. + Only pole 0 has no previous fence, so there are no constraints. + In general, at some pole i, the constraint is that fence(i-1).trg=fence i.src However, there are exceptions for the expressions V and Mp1 (and possibly I??). - For V, we don not calculate V, and we also pose no restrictions at the pole. + For V, we do not calculate V, and we also pose no restrictions at the pole. For Mp1, we do not calculate Mp1, but we do pose a restriction at the pole. - Imagine subexpressions as "fences". The source and target of a "fence" are the "poles" between which that "fence" is mounted. - In this metaphor, we create the FROM-clause directly from the "fences", and the WHERE-clause from the "poles" between "fences". - The "outer poles" correspond to the source and target of the entire expression. + In "poles and fences" metaphor, we create the FROM-clause directly from the "fences". + We create the WHERE-clause from the "poles" between "fences". To prevent name conflicts in SQL, each calculated subexpression is aliased in SQL by a unique the fenceName. ". -} + let es = exprCps2list expr + hes = NE.head es + tles = NE.tail es in + case tles of + []-> traceComment ["case: ECps{}"] $ selectExpr fSpec hes -- Even though this case cannot occur, + -- it safeguards that there are two or more elements in exprCps2list expr in the remainder of this code. {- TODO: Check these assumptions: 1) We assume that: let exprCps2list = [e0, e1, ... , en], for all i: 0<=i< n the following is true: @@ -1061,20 +1068,14 @@ setDistinct bqe sqlConceptTable :: FSpec -> A_Concept -> TableRef sqlConceptTable fSpec a = TRSimple [sqlConcept fSpec a] --- sqlConcept gives the name of the plug that contains all atoms of A_Concept c. +-- sqlConcept gives the SQL-name of the plug that contains all atoms of A_Concept c. sqlConcept :: FSpec -> A_Concept -> Name -sqlConcept fSpec = QName . T.unpack . name . sqlConceptPlug fSpec --- sqlConcept yields the plug that contains all atoms of A_Concept c. Since there may be more of them, the first one is returned. -sqlConceptPlug :: FSpec -> A_Concept -> PlugSQL -sqlConceptPlug fSpec c - = case lookupCpt fSpec c of - [] -> fatal ("A_Concept \""<>tshow c<>"\" does not occur in fSpec.") - (plug,_):_ -> plug +sqlConcept fSpec = QName . T.unpack . name . getConceptTableFor fSpec sqlAttConcept :: FSpec -> A_Concept -> Name sqlAttConcept fSpec c | c==ONE = QName "ONE" | otherwise - = case [name f |f<-NE.toList $ plugAttributes (sqlConceptPlug fSpec c) + = case [name f |f<-NE.toList $ plugAttributes (getConceptTableFor fSpec c) , c'<-Set.elems $ concs f,c==c'] of [] -> fatal ("A_Concept \""<>tshow c<>"\" does not occur in its plug in fSpec \""<>name fSpec<>"\"") h:_ -> QName . T.unpack $ h diff --git a/src/Ampersand/FSpec/ShowHS.hs b/src/Ampersand/FSpec/ShowHS.hs index fb812c2f3f..f6c79b6838 100644 --- a/src/Ampersand/FSpec/ShowHS.hs +++ b/src/Ampersand/FSpec/ShowHS.hs @@ -1,6 +1,6 @@ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedStrings #-} + module Ampersand.FSpec.ShowHS (ShowHS(..),ShowHSName(..),fSpec2Haskell,haskellIdentifier) where @@ -16,7 +16,7 @@ import qualified RIO.NonEmpty as NE import qualified RIO.Set as Set import qualified RIO.Text as T import RIO.Time -import Text.Pandoc hiding (Meta) +import Text.Pandoc fSpec2Haskell :: (HasFSpecGenOpts env) => env -> UTCTime -> FSpec -> Text @@ -28,7 +28,7 @@ fSpec2Haskell env now fSpec , "where" , "" , "import Ampersand" - , "import Text.Pandoc hiding (Meta)" + , "import Text.Pandoc hiding (MetaData)" , "" , "main :: IO ()" , "main = do env <- getOptions" @@ -179,35 +179,43 @@ instance ShowHS Conjunct where instance ShowHSName FSpec where showHSName fSpec = haskellIdentifier ("fSpc_"<>name fSpec) +showRoleInterfaces :: FSpec -> Text +showRoleInterfaces fSpec + = case map fst (fRoles fSpec) of + [] -> "[]" + rs -> T.intercalate "," [ "("<>name r<>","<>name ifc<>")" | r<-rs, ifc<-roleInterfaces fSpec r] + instance ShowHS FSpec where showHS env indent fSpec = T.intercalate (indent <>" ") - [ "FSpec{ fsName = " <> tshow (name fSpec) - , wrap ", fspos = " indentA (showHS env) (fspos fSpec) - , wrap ", plugInfos = " indentA (\_->showHS env (indentA<>" ")) (plugInfos fSpec) - , ", interfaceS = interfaceS'" - , ", interfaceG = interfaceG'" - , ", fRoleRuls = " <>showHS env indentA (fRoleRuls fSpec) - , wrap ", fRoles = " indentA (showHS env) (map fst (fRoles fSpec)) - , wrap ", vrules = " indentA (const showHSName) (Set.elems $ vrules fSpec) - , wrap ", grules = " indentA (const showHSName) (Set.elems $ grules fSpec) - , wrap ", invariants = " indentA (const showHSName) (Set.elems $ invariants fSpec) - , wrap ", fallRules = " indentA (const showHSName) (Set.elems $ fallRules fSpec) - , wrap ", allUsedDecls = " indentA (const showHSName) (Set.elems $ allUsedDecls fSpec) - , wrap ", vrels = " indentA (const showHSName) (Set.elems $ vrels fSpec) - , wrap ", allConcepts = " indentA (const showHSName) (Set.elems $ allConcepts fSpec) - , wrap ", vIndices = " indentA (const showHSName) (vIndices fSpec) - , wrap ", vviews = " indentA (const showHSName) (vviews fSpec) - , wrap ", vgens = " indentA (showHS env) (vgens fSpec) - , wrap ", fsisa = " indentA (const showHSName) (fsisa fSpec) - , wrap ", allConjuncts = " indentA (const showHSName) (allConjuncts fSpec) - , wrap ", vquads = " indentA (const showHSName) (vquads fSpec) - , wrap ", vpatterns = " indentA (const showHSName) (vpatterns fSpec) - , wrap ", conceptDefs = " indentA (showHS env) (conceptDefs fSpec) - , wrap ", fSexpls = " indentA (showHS env) (Set.elems (fSexpls fSpec)) - , ", metas = allMetas" - , wrap ", allViolations = " indentA showViolatedRule (allViolations fSpec) - , wrap ", allExprs = " indentA (showHS env) (Set.elems (allExprs fSpec)) + [ "FSpec{ fsName = " <> tshow (name fSpec) + , ", originalContext = " <> tshow (name (originalContext fSpec)) + , wrap ", fspos = " indentA (showHS env) (fspos fSpec) + , wrap ", plugInfos = " indentA (\_->showHS env (indentA<>" ")) (plugInfos fSpec) + , ", interfaceS = interfaceS'" + , ", interfaceG = interfaceG'" + , ", roleInterfaces = "<>showRoleInterfaces fSpec + , ", fRoleRuls = " <>showHS env indentA (fRoleRuls fSpec) + , wrap ", fRoles = " indentA (showHS env) (map fst (fRoles fSpec)) + , wrap ", vrules = " indentA (const showHSName) (Set.elems $ vrules fSpec) + , wrap ", grules = " indentA (const showHSName) (Set.elems $ grules fSpec) + , wrap ", invariants = " indentA (const showHSName) (Set.elems $ invariants fSpec) + , wrap ", fallRules = " indentA (const showHSName) (Set.elems $ fallRules fSpec) + , wrap ", allUsedDecls = " indentA (const showHSName) (Set.elems $ allUsedDecls fSpec) + , wrap ", vrels = " indentA (const showHSName) (Set.elems $ vrels fSpec) + , wrap ", allConcepts = " indentA (const showHSName) (Set.elems $ allConcepts fSpec) + , wrap ", vIndices = " indentA (const showHSName) (vIndices fSpec) + , wrap ", vviews = " indentA (const showHSName) (vviews fSpec) + , wrap ", vgens = " indentA (showHS env) (vgens fSpec) + , wrap ", fsisa = " indentA (const showHSName) (fsisa fSpec) + , wrap ", allConjuncts = " indentA (const showHSName) (allConjuncts fSpec) + , wrap ", vquads = " indentA (const showHSName) (vquads fSpec) + , wrap ", vpatterns = " indentA (const showHSName) (vpatterns fSpec) + , wrap ", conceptDefs = " indentA (showHS env) (conceptDefs fSpec) + , wrap ", fSexpls = " indentA (showHS env) (Set.elems (fSexpls fSpec)) + , ", metas = allMetas" + , wrap ", allViolations = " indentA showViolatedRule (allViolations fSpec) + , wrap ", allExprs = " indentA (showHS env) (Set.elems (allExprs fSpec)) , "}" ] <> indent<>"where"<> @@ -283,7 +291,7 @@ instance ShowHS FSpec where T.concat [indent<>" "<>showHSName x<>indent<>" = "<>showHS env (indent<>" ") x <> indent<>" "<>showAtomsOfConcept x |x<-L.sortBy (comparing showHSName) (Set.toList $ allConcepts fSpec)]<>"\n" ) - where indentA = indent <>" " + where indentA = indent <>" " indentB = indent <>" " showAtomsOfConcept c = "-- atoms: [ "<> T.intercalate indentC strs<>"]" @@ -304,8 +312,8 @@ instance ShowHS FSpec where indent'<>" )" ] -instance ShowHS Meta where - showHS f i (Meta pos' nm val) = "Meta ("<>showHS f i pos' <> ") " <> " " <> tshow nm <> " " <> tshow val +instance ShowHS MetaData where + showHS f i (MetaData pos' nm val) = "MetaData ("<>showHS f i pos' <> ") " <> " " <> tshow nm <> " " <> tshow val instance ShowHSName PlugInfo where showHSName (InternalPlug p) = haskellIdentifier ("ipl_"<>name p)-- TODO @@ -434,10 +442,10 @@ instance ShowHS Rule where instance ShowHS Meaning where showHS env indent (Meaning x) = "Meaning " <> showHS env (indent<>" ") x -instance ShowHSName IdentityDef where +instance ShowHSName IdentityRule where showHSName identity = haskellIdentifier ("identity_"<>name identity) -instance ShowHS IdentityDef where +instance ShowHS IdentityRule where showHS env indent identity = "Id ("<>showHS env "" (idPos identity)<>") "<>tshow (idLbl identity)<>" ("<>showHSName (idCpt identity)<>")" <>indent<>" [ "<>T.intercalate (indent<>" , ") (NE.toList . fmap (showHS env indent) $ identityAts identity)<>indent<>" ]" @@ -522,9 +530,9 @@ instance ShowHS Interface where [ "Ifc { ifcname = " <> tshow(ifcname ifc) , " , ifcRoles = " <> tshow(ifcRoles ifc) , " , ifcObj"<>indent<>" = " <> showHS env (indent<>" ") (ifcObj ifc) - , wrap " , ifcControls = " (indent<>" ") (const showHSName) (ifcControls ifc) + , wrap " , ifcConjuncts = " (indent<>" ") (const showHSName) (ifcConjuncts ifc) , " , ifcPos = " <> showHS env "" (ifcPos ifc) - , " , ifcPrp = " <> tshow(ifcPrp ifc) + , " , ifcPurpose = " <> tshow(ifcPurpose ifc) ]<>indent<>" }" instance ShowHS BoxItem where showHS env indent obj = diff --git a/src/Ampersand/FSpec/ShowMeatGrinder.hs b/src/Ampersand/FSpec/ShowMeatGrinder.hs index ed73ceb113..af13f5f6d9 100644 --- a/src/Ampersand/FSpec/ShowMeatGrinder.hs +++ b/src/Ampersand/FSpec/ShowMeatGrinder.hs @@ -1,158 +1,104 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE DuplicateRecordFields#-} -{-# LANGUAGE OverloadedStrings #-} + {-# LANGUAGE ScopedTypeVariables #-} module Ampersand.FSpec.ShowMeatGrinder - ( grind - , GrindInfo(..) + ( grind + , metaModel , MetaModel(..) ) where import Ampersand.ADL1 import Ampersand.Basics -import Ampersand.Core.A2P_Converters +import Ampersand.Core.ParseTree +-- import Ampersand.Core.A2P_Converters import Ampersand.FSpec.FSpec import Ampersand.FSpec.Transformers -import qualified RIO.Set as Set +-- import qualified RIO.Set as Set import qualified RIO.Text as T data MetaModel = FormalAmpersand | PrototypeContext deriving (Eq, Ord, Enum, Bounded, Show) instance Named MetaModel where name FormalAmpersand = "Formal Ampersand" - name PrototypeContext = "System context" + name PrototypeContext = "Prototype context" -data GrindInfo = GrindInfo - { metaModel :: MetaModel - , pModel :: P_Context - , fModel :: FSpec - , transformers :: FSpec -> [Transformer] - } +-- | This produces the metamodel of either +-- "FormalAmpersand" or "PrototypeContext" as defined by their transformers. +metaModel :: MetaModel -> P_Context +metaModel mmLabel = + PCtx{ ctx_nm = "MetaModel"<>T.pack (show mmLabel) + , ctx_pos = [] + , ctx_lang = Nothing + , ctx_markup = Nothing + , ctx_pats = [] + , ctx_rs = [] + , ctx_ds = map metarelation (transformers emptyFSpec) + , ctx_cs = [] + , ctx_ks = [] + , ctx_rrules = [] + , ctx_reprs = [] + , ctx_vs = [] + , ctx_gs = [] + , ctx_ifcs = [] + , ctx_ps = [] + , ctx_pops = [] + , ctx_metas = [] + } + where + transformers = case mmLabel of + FormalAmpersand -> transformersFormalAmpersand + PrototypeContext -> transformersPrototypeContext --- | The 'grind' function creates a P_Context that contains the population for every --- relation in the metamodel for which the GrindInfo is given. --- The population is defined by the given FSpec, which usually is the FSpec of the user. -grind :: GrindInfo -> FSpec -> P_Context -grind grindInfo userFspec = +-- | The 'grind' function lifts a model to the population of a metamodel. +-- The model is "ground" with respect to a metamodel defined in transformersFormalAmpersand, +-- The result is delivered as a P_Context, so it can be merged with other Ampersand results. +grind :: (FSpec -> [Transformer]) -> FSpec -> P_Context +grind transformers userFspec = PCtx{ ctx_nm = "Grinded_"<>name userFspec , ctx_pos = [] , ctx_lang = Nothing , ctx_markup = Nothing , ctx_pats = [] , ctx_rs = [] - , ctx_ds = map aRelation2pRelation . Set.toList . instances . fModel $ grindInfo + , ctx_ds = map metarelation filtered , ctx_cs = [] , ctx_ks = [] , ctx_rrules = [] , ctx_reprs = [] , ctx_vs = [] - , ctx_gs = map aClassify2pClassify . Set.toList . instances . fModel $ grindInfo + , ctx_gs = [] , ctx_ifcs = [] , ctx_ps = [] - , ctx_pops = populationFromPop <$> metaPops2 + , ctx_pops = map transformer2pop filtered , ctx_metas = [] } where - metaPops2 :: [Pop] - metaPops2 = concatMap (Set.toList . grindedPops grindInfo userFspec) - . Set.toList . instances . fModel $ grindInfo - populationFromPop :: Pop -> P_Population - populationFromPop pop = - P_RelPopu { p_src = Just $ aCpt2pCpt (source rel) - , p_tgt = Just $ aCpt2pCpt (target rel) - , pos = orig - , p_nmdr = PNamedRel - { pos = orig - , p_nrnm = name rel - , p_mbSign = Just . aSign2pSign . sign $ rel - } - , p_popps = map convertPair . Set.toList . popPairs $ pop - } - where rel = popRelation pop - orig = MeatGrinder - convertPair :: (PopAtom,PopAtom) -> PAtomPair - convertPair (a,b) = - PPair { pos = orig - , ppLeft = pAtom2AtomValue a - , ppRight = pAtom2AtomValue b - } - - pAtom2AtomValue :: PopAtom -> PAtomValue - pAtom2AtomValue atm = - case atm of - DirtyId str -> ScriptString orig str - PopAlphaNumeric str -> ScriptString orig str - PopInt i -> ScriptInt orig i - -data Pop = Pop { popPairs :: Set.Set (PopAtom,PopAtom) - , popRelation :: Relation - } + filtered :: [Transformer] + filtered = filter (not.null.tPairs) . transformers $ userFspec -grindedPops :: GrindInfo -> FSpec -> Relation -> Set.Set Pop -grindedPops grindInfo userFspec rel = - case filter (isForRel rel) (transformers grindInfo userFspec) of - [] -> fatal . T.unlines $ - ["Every relation in "<>name (metaModel grindInfo)<>" must have a transformer in Transformers.hs" - ," However, the following relations have none:" - ] <> map (" "<>) viols - where - viols = map showRelOrigin - . Set.toList - . Set.filter hasNoTransformer - . instances . fModel $ grindInfo - [t] -> Set.singleton . transformer2Pop $ t - ts -> fatal . T.unlines $ - ["Every relation in "<>name (metaModel grindInfo)<>" must have a transformer in Transformers.hs" - ," However there are "<>tshow (length ts)<>" transformers for relation: " - ," "<>showRelOrigin rel - ] - where - showRelOrigin :: Relation -> Text - showRelOrigin r = showRel r<>" ( "<>tshow (origin r)<>" )." - hasNoTransformer :: Relation -> Bool - hasNoTransformer d = not (any (isForRel d) (transformers grindInfo userFspec)) - transformer2Pop :: Transformer -> Pop - transformer2Pop (Transformer relName src tgt popPairs') - | not ( all (ttypeOf (source rel) . fst) (Set.toList popPairs') ) = - fatal . T.unlines $ - [ "The TType of the population produced by the meatgrinder must" - , " match the TType of the concept as specified in "<>name (metaModel grindInfo)<>"." - , " The population of the relation `" <> relName <>"["<> src <>" * "<> tgt <>"]` " - , " violates this rule for concept `"<> src <>"`. In "<>name (metaModel grindInfo)<>" " - , " the TType of this concept is "<>(tshow . cptTType (fModel grindInfo) $ source rel)<>"." - ] - | not ( all (ttypeOf (target rel) . snd) (Set.toList popPairs') ) = - fatal . T.unlines $ - [ "The TType of the population produced by the meatgrinder must" - , " match the TType of the concept as specified in "<>name (metaModel grindInfo)<>"." - , " The population of the relation `"<> relName <>"["<> src <>" * "<> tgt <>"]` " - , " violates this rule for concept `"<> tgt <>"`. In "<>name (metaModel grindInfo)<>" " - , " the TType of this concept is "<>(tshow . cptTType (fModel grindInfo) $ target rel)<>"." - ] - | otherwise = Pop { popRelation = rel - , popPairs = popPairs' - } - where ttypeOf :: A_Concept -> (PopAtom -> Bool) - ttypeOf cpt = - case cptTType (fModel grindInfo) cpt of - Object -> isDirtyId - Alphanumeric -> isTextual - BigAlphanumeric -> isTextual - HugeAlphanumeric -> isTextual - tt -> fatal $ "No test available yet. "<>tshow tt<>" encountered for the first time in "<>name (metaModel grindInfo)<>"" - isDirtyId pa = case pa of - DirtyId{} -> True - _ -> False - isTextual pa = case pa of - PopAlphaNumeric{} -> True - _ -> False - - - -isForRel :: Relation -> Transformer -> Bool -isForRel rel (Transformer n s t _ ) = - (name rel == n) - && (name (source rel) == s) - && (name (target rel) == t) - +metarelation :: Transformer -> P_Relation +metarelation tr = + P_Relation { dec_nm = tRel tr + , dec_sign = P_Sign (mkPConcept (tSrc tr)) + (mkPConcept (tTrg tr)) + , dec_prps = mults tr + , dec_pragma = [] + , dec_Mean = [] + , pos = OriginUnknown + } + +transformer2pop :: Transformer -> P_Population +transformer2pop tr = + P_RelPopu { p_src = Nothing + , p_tgt = Nothing + , pos = OriginUnknown -- TODO trace to origin + , p_nmdr = PNamedRel + { pos = OriginUnknown -- TODO trace to origin + , p_nrnm = tRel tr + , p_mbSign = Just (P_Sign (mkPConcept (tSrc tr)) + (mkPConcept (tTrg tr))) + } + , p_popps = tPairs tr + } \ No newline at end of file diff --git a/src/Ampersand/FSpec/ToFSpec/ADL2FSpec.hs b/src/Ampersand/FSpec/ToFSpec/ADL2FSpec.hs index b2fe8567e8..9b0571d30e 100644 --- a/src/Ampersand/FSpec/ToFSpec/ADL2FSpec.hs +++ b/src/Ampersand/FSpec/ToFSpec/ADL2FSpec.hs @@ -1,5 +1,5 @@ {-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE OverloadedStrings #-} + module Ampersand.FSpec.ToFSpec.ADL2FSpec ( makeFSpec ) where @@ -56,7 +56,7 @@ makeFSpec env context , allConjsPerConcept = fSpecAllConjsPerConcept , vquads = allQuads , allUsedDecls = bindedRelationsIn context - , vrels = calculatedDecls + , vrels = relsDefdInContext , allConcepts = fSpecAllConcepts , cptTType = representationOf contextinfo , fsisa = L.nub . concatMap genericAndSpecifics . gens $ context @@ -70,7 +70,7 @@ makeFSpec env context , conceptDefs = ctxcds context , fSexpls = Set.fromList $ ctxps context <> concatMap ptxps (patterns context) , metas = ctxmetas context - , crudInfo = mkCrudInfo fSpecAllConcepts calculatedDecls fSpecAllInterfaces + , crudInfo = mkCrudInfo fSpecAllConcepts relsDefdInContext fSpecAllInterfaces , atomsInCptIncludingSmaller = atomValuesOf contextinfo initialpopsDefinedInScript --TODO: Write in a nicer way, like `atomsBySmallestConcept` , atomsBySmallestConcept = \cpt -> Set.map apLeft . pairsinexpr @@ -148,7 +148,7 @@ makeFSpec env context where enrichIfc :: Interface -> Interface enrichIfc ifc - = ifc{ ifcControls = makeIfcControls Set.empty allConjs + = ifc{ ifcConjuncts = makeifcConjuncts Set.empty allConjs } fSpecRoleInterfaces :: Role -> [Interface] fSpecRoleInterfaces role' = filter (forThisRole role') fSpecAllInterfaces @@ -182,6 +182,8 @@ makeFSpec env context smaller :: A_Concept -> [A_Concept] smaller cpt = L.nub $ cpt : smallerConcepts (gens context) cpt allQuads = quadsOfRules env allrules + relsDefdInContext :: Relations + relsDefdInContext = relsDefdIn context allrules = Set.map setIsSignal (allRules context) where setIsSignal r = r{isSignal = (not.null) (maintainersOf r)} @@ -196,29 +198,6 @@ makeFSpec env context UserDefined -> True Multiplicity -> False Identity -> False - calcProps :: Relation -> Relation - calcProps d = d{decprps_calc = Just calculated} - where calculated = decprps d `Set.union` (if d `elem` totals then Set.singleton Tot else Set.empty) - `Set.union` (if d `elem` surjectives then Set.singleton Sur else Set.empty) - calculatedDecls :: Relations - calculatedDecls = Set.map calcProps (relsDefdIn context) - -- determine relations that are total (as many as possible, but not necessarily all) - totals = [ d | EDcD d <- totsurs ] - surjectives = [ d | EFlp (EDcD d) <- totsurs ] - totsurs :: [Expression] - totsurs = [] --- = L.nub [rel | q<- filter (isIdent . EDcD . qDcl) -- FIXME: This cannot be correct. This filter will block everything! --- . filter (not . isSignal . qRule) --- $ allQuads -- all quads for invariant rules --- , dnf<- concatMap rc_dnfClauses . qConjuncts $ q --- , let antc = conjNF env (foldr (./\.) (EDcV (sign (NE.head (antcs dnf)))) (antcs dnf)) --- , isRfx antc -- We now know that I is a subset of the antecedent of this dnf clause. --- , cons<- case conss dnf of --- [] -> [] --- h:tl -> NE.toList $ fmap exprCps2list (h NE.:| tl) --- -- let I |- r;s;t be an invariant rule, then r and s and t~ and s~ are all total. --- , rel<-NE.init cons<>[flp r | r<-NE.tail cons] --- ] -- Lookup view by id in fSpec. lookupView' :: Text -> ViewDef lookupView' viewId = @@ -255,7 +234,7 @@ makeFSpec env context -------------- allplugs = genPlugs -- all generated plugs genPlugs = [InternalPlug (rename p (qlfname (name p))) - | p <- uniqueNames [] (makeGeneratedSqlPlugs env context calcProps) + | p <- uniqueNames [] (makeGeneratedSqlPlugs env context) ] qlfname x = if T.null ns then x else "ns"<>ns<>x where ns = view namespaceL env @@ -311,14 +290,14 @@ makeFSpec env context Set.filter isTot toconsider `Set.union` (Set.map flp . Set.filter (not.isTot) . Set.filter isSur $ toconsider) - where toconsider = Set.map EDcD calculatedDecls + where toconsider = Set.map EDcD relsDefdInContext -- Step 2: select and arrange all relations to obtain a set dRels of injective relations -- to ensure deletability of entities (signal relations are excluded) dRels = Set.elems $ Set.filter isInj toconsider `Set.union` (Set.map flp . Set.filter (not.isInj) . Set.filter isUni $ toconsider) - where toconsider = Set.map EDcD calculatedDecls + where toconsider = Set.map EDcD relsDefdInContext -- Step 3: compute longest sequences of total expressions and longest sequences of injective expressions. maxTotPaths,maxInjPaths :: [NE.NonEmpty Expression] maxTotPaths = map (NE.:|[]) cRels -- note: instead of computing the longest sequence, we take sequences of length 1, the function clos1 below is too slow! @@ -344,7 +323,7 @@ makeFSpec env context recur es = [ ObjectDef { objnm = showA t - , objpos = orig + , objPos = orig , objExpression = t , objcrud = fatal "No default crud in generated interface" , objmView = Nothing @@ -382,16 +361,16 @@ makeFSpec env context , ifcObj = let orig = Origin "generated object: step 4a - default theme" in ObjectDef { objnm = name c - , objpos = orig + , objPos = orig , objExpression = EDcI c , objcrud = fatal "No default crud in generated interface" , objmView = Nothing , objmsub = Just . Box orig c (simpleBoxHeader orig) . map BxExpr $ NE.toList objattributes } - , ifcControls = makeIfcControls params allConjs + , ifcConjuncts = makeifcConjuncts params allConjs , ifcPos = Origin "generated interface: step 4a - default theme" - , ifcPrp = "Interface " <>name c<>" has been generated by Ampersand." + , ifcPurpose = "Interface " <>name c<>" has been generated by Ampersand." , ifcRoles = [] } | (c, objattributes) <- mapMaybe f $ eqCl (source . NE.head) plugPaths @@ -405,15 +384,15 @@ makeFSpec env context , ifcObj = let orig = Origin "generated object: step 4b" in ObjectDef { objnm = nm - , objpos = orig + , objPos = orig , objExpression = EDcI ONE , objcrud = fatal "No default crud in generated interface" , objmView = Nothing , objmsub = Just . Box orig ONE (simpleBoxHeader orig) $ [BxExpr att] } - , ifcControls = ifcControls ifcc + , ifcConjuncts = ifcConjuncts ifcc , ifcPos = ifcPos ifcc - , ifcPrp = ifcPrp ifcc + , ifcPurpose = ifcPurpose ifcc , ifcRoles = [] } | ifcc<-step4a @@ -426,7 +405,7 @@ makeFSpec env context h:_ -> h att = ObjectDef { objnm = name c - , objpos = Origin "generated attribute object: step 4b" + , objPos = Origin "generated attribute object: step 4b" , objExpression = EDcV (Sign ONE c) , objcrud = fatal "No default crud in generated interface." , objmView = Nothing @@ -437,8 +416,8 @@ makeFSpec env context --END: making interfaces ---------------------- -makeIfcControls :: Relations -> [Conjunct] -> [Conjunct] -makeIfcControls params allConjs +makeifcConjuncts :: Relations -> [Conjunct] -> [Conjunct] +makeifcConjuncts params allConjs = [ conj | conj<-allConjs , (not.null) (Set.map EDcD params `Set.intersection` primsMentionedIn (rc_conjunct conj)) @@ -499,7 +478,7 @@ tblcontents ci ps plug [ "There is an attempt to populate multiple values into " , " the row of table `"<>name plug<>"`, where id = "<>tshow(showValADL a)<>":" , " Values to be inserted in field `"<>name att<>"` are: "<>tshow (map (showValADL . apRight) ps') - ] --this has happend before due to: + ] --this has happened before due to: -- when using --dev flag -- , when there are violations -- , when you have INCLUDE \"MinimalAST.xlsx\" in formalampersand.) diff --git a/src/Ampersand/FSpec/ToFSpec/ADL2Plug.hs b/src/Ampersand/FSpec/ToFSpec/ADL2Plug.hs index 87a9a0d579..91923b8909 100644 --- a/src/Ampersand/FSpec/ToFSpec/ADL2Plug.hs +++ b/src/Ampersand/FSpec/ToFSpec/ADL2Plug.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE OverloadedStrings #-} + module Ampersand.FSpec.ToFSpec.ADL2Plug (makeGeneratedSqlPlugs ,typologies @@ -29,18 +29,15 @@ attributesOfConcept fSpec c makeGeneratedSqlPlugs :: (HasFSpecGenOpts env) => env -> A_Context - -> (Relation -> Relation) -- Function to add calculated properties to a relation -> [PlugSQL] -- | Sql plugs database tables. A database table contains the administration of a set of concepts and relations. -- if the set conains no concepts, a linktable is created. -makeGeneratedSqlPlugs env context calcProps = conceptTables <> linkTables +makeGeneratedSqlPlugs env context = conceptTables <> linkTables where repr = representationOf (ctxInfo context) conceptTables = map makeConceptTable conceptTableParts linkTables = map makeLinkTable linkTableParts - calculatedDecls :: Relations - calculatedDecls = Set.map calcProps . relsDefdIn $ context - (conceptTableParts, linkTableParts) = dist calculatedDecls (typologies context) + (conceptTableParts, linkTableParts) = dist (relsDefdIn context) (typologies context) makeConceptTable :: (Typology, [Relation]) -> PlugSQL makeConceptTable (typ , dcls) = TblSQL @@ -71,7 +68,6 @@ makeGeneratedSqlPlugs env context calcProps = conceptTables <> linkTables then tryInsert x (n+1) names else (x,nm):names - tableKey = tyroot typ conceptLookuptable :: [(A_Concept,SqlAttribute)] conceptLookuptable = [(cpt,cptAttrib cpt) | cpt <-cpts] @@ -158,35 +154,35 @@ makeGeneratedSqlPlugs env context calcProps = conceptTables <> linkTables , rsSrcAtt = if isStoredFlipped dcl then trgAtt else srcAtt , rsTrgAtt = if isStoredFlipped dcl then srcAtt else trgAtt } - --the expr for the source of r - srcExpr + --the expr for the domain of r + domExpr | isTot bindedExp = EDcI (source bindedExp) | isSur bindedExp = EDcI (target bindedExp) | otherwise = EDcI (source bindedExp) ./\. (bindedExp .:. flp bindedExp) - --the expr for the target of r - trgExpr + --the expr for the codomain of r + codExpr | not (isTot bindedExp) && isSur bindedExp = flp bindedExp | otherwise = bindedExp - srcAtt = Att { attName = T.concat["Src" | isEndo dcl]<>(unquote . name . source) trgExpr - , attExpr = srcExpr - , attType = repr . source $ srcExpr - , attUse = if suitableAsKey . repr . source $ srcExpr - then ForeignKey (target srcExpr) + srcAtt = Att { attName = T.concat["Src" | isEndo dcl]<>(unquote . name . source) codExpr + , attExpr = domExpr + , attType = repr (source domExpr) + , attUse = if suitableAsKey . repr . source $ domExpr + then ForeignKey (source domExpr) else PlainAttr - , attNull = False -- false for link tables. This was 'isTot trgExpr' (was this a mistake?) + , attNull = False -- false for link tables. This was 'isTot codExpr' (was this a mistake?) , attDBNull = False - , attUniq = isUni trgExpr + , attUniq = isUni codExpr , attFlipped = isStoredFlipped dcl } - trgAtt = Att { attName = T.concat["Tgt" | isEndo dcl]<>(unquote . name . target) trgExpr - , attExpr = trgExpr - , attType = repr . target $ trgExpr - , attUse = if suitableAsKey . repr . target $ trgExpr - then ForeignKey (target trgExpr) + trgAtt = Att { attName = T.concat["Tgt" | isEndo dcl]<>(unquote . name . target) codExpr + , attExpr = codExpr + , attType = repr (target domExpr) + , attUse = if suitableAsKey . repr . target $ codExpr + then ForeignKey (target codExpr) else PlainAttr - , attNull = isSur trgExpr + , attNull = isSur codExpr , attDBNull = False -- false for link tables - , attUniq = isInj trgExpr + , attUniq = isInj codExpr , attFlipped = isStoredFlipped dcl } @@ -215,27 +211,20 @@ makeGeneratedSqlPlugs env context calcProps = conceptTables <> linkTables isStoredFlipped = snd . wayToStore env -- | this function tells how a given relation is to be stored. If stored --- in a concept table, it returns that concept. It allways returns a boolean --- telling wether or not the relation is stored flipped. +-- in a concept table, it returns that concept. It returns a boolean +-- that tells wether or not the relation is stored flipped. wayToStore :: (HasFSpecGenOpts env) => env -> Relation -> (Maybe A_Concept,Bool) -wayToStore env dcl = - if view sqlBinTablesL env - then (Nothing, False) - else case (isInj d, isUni d) of - (True , False ) -> inConceptTableFlipped - (_ , True ) -> inConceptTablePlain - (False , False ) -> inLinkTable --Will become a link-table +wayToStore env dcl + | view sqlBinTablesL env = (Nothing, False) -- binary tables only + | isUni (EDcD dcl) = (Just $ source d, False) -- to concept table, plain + | isInj (EDcD dcl) = (Just $ target d, True) -- to concept table, flipped + | otherwise = (Nothing, not (isTot d) && isSur d) -- to link-table + -- The order of columns in a linked table could + -- potentially speed up queries, in cases where + -- the relation is TOT or SUR. In that case there + -- should be no need to look in the concept table, + -- for all atoms are in the first colum of the link table where d = EDcD dcl - inConceptTablePlain = (Just $ source d,False) - inConceptTableFlipped = (Just $ target d, True) - inLinkTable = ( Nothing - , -- The order of columns in a linked table could - -- potentially speed up queries, in cases where - -- the relation is TOT or SUR. In that case there - -- should be no need to look in the concept table, - -- for all atoms are in the first colum of the link table - not (isTot d) && isSur d - ) unquote :: Text -> Text unquote str = @@ -264,10 +253,6 @@ suitableAsKey st = Object -> True TypeOfOne -> fatal "ONE has no key at all. does it?" - - - - typologies :: A_Context -> [Typology] typologies context = (multiKernels . ctxInfo $ context) <> diff --git a/src/Ampersand/FSpec/ToFSpec/CreateFspec.hs b/src/Ampersand/FSpec/ToFSpec/CreateFspec.hs index 8d92c92c69..f5c1af9656 100644 --- a/src/Ampersand/FSpec/ToFSpec/CreateFspec.hs +++ b/src/Ampersand/FSpec/ToFSpec/CreateFspec.hs @@ -1,295 +1,86 @@ {-# LANGUAGE DisambiguateRecordFields #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE OverloadedStrings #-} + module Ampersand.FSpec.ToFSpec.CreateFspec - ( BuildRecipe - , BuildStep(Grind,EncloseInConstraints) - , StartContext(..) - , MetaModel(..) + ( Recipe(..) +-- , BuildStep(Grind) +-- , StartContext(..) +-- , MetaModel(..) , createFspec - , script - , merge - , andThen +-- , script +-- , merge +-- , andThen ) where import Ampersand.ADL1 import Ampersand.Basics -import Ampersand.Core.ParseTree -import Ampersand.Core.ShowPStruct -- Just for debugging purposes import Ampersand.FSpec.FSpec import Ampersand.FSpec.MetaModels +import Ampersand.FSpec.Transformers import Ampersand.FSpec.ShowMeatGrinder import Ampersand.Input import Ampersand.Misc.HasClasses -import qualified RIO.List as L -import qualified RIO.Map as Map -import qualified RIO.NonEmpty as NE -import qualified RIO.Set as Set --- | create an FSpec, based on the provided command-line options. --- Without the command-line switch "--meta-tables", --- Ampersand compiles its script (userP_Ctx) straightforwardly in first order relation algebra. --- This is useful for simple scripts and the compilation process is easy to understand. --- --- With "--meta-tables" switched on, Ampersand does more. --- This switch is useful for higher order Ampersand, --- in which the user can work with the rules, relations and concepts of the model inside the model. --- Besides the user script, userP_Ctx, Ampersand creates its own metamodel, rapP_Ctx, which is generated from "AST.adl" --- This metamodel is populated with the result of grinding userP_Ctx, being populationPctx. --- Grinding means to analyse the script down to the binary relations that constitute the metamodel. --- The combination of model and populated metamodel results in the Guarded FSpec, --- which is the result of createFSpec. - -createFspec :: (HasFSpecGenOpts env, HasLogFunc env) => - BuildRecipe -> RIO env (Guarded FSpec) -createFspec recipe = do - env <- ask - metaModelsMap :: Map MetaModel GrindInfo <- do - let fun :: (HasLogFunc env, HasFSpecGenOpts env) => MetaModel -> RIO env (MetaModel , GrindInfo) - fun m = (,) m <$> mkGrindInfo m - Map.fromList <$> sequence (fun <$> Set.toList (metaModelsIn recipe)) - parsedUserScript :: Guarded P_Context <- do - rootFile <- fromMaybe (fatal "No script was given!") <$> view rootFileL - snd <$> parseFileTransitive rootFile -- the P_Context of the user's sourceFile - let cooked :: Guarded P_Context - cooked = cook env recipe metaModelsMap parsedUserScript - return (pCtx2Fspec env =<< cooked) - -class MetaModelContainer a where - metaModelsIn :: a -> Set MetaModel --- | A recipe to build an FSpec defines the way that FSpec should be constructed. --- It consists of a initial P_Context and list of follow-up steps. -data BuildRecipe = BuildRecipe StartContext [BuildStep] -instance MetaModelContainer BuildRecipe where - metaModelsIn (BuildRecipe x y) = metaModelsIn x `Set.union` metaModelsIn y --- | The initial context to use in a recipe. It is either the user's script or --- the script from a given MetaModel. -data StartContext = UserScript | MetaScript MetaModel -instance MetaModelContainer StartContext where - metaModelsIn UserScript = mempty - metaModelsIn (MetaScript m) = Set.singleton m --- | A buildstep describes a conversion to a given context. -data BuildStep = - Grind MetaModel -- ^ Grind the given P_Context using the given MetaModel. The resulting P_Context - -- contains all relations from the Metamodel. Those relations are populated using the - -- original P_Context. - | MergeWith BuildRecipe -- ^ Merge the given P_Context with the P_Context that is the result of - -- applying the BuildRecipe. - | EncloseInConstraints -- ^ Apply the encloseInConstraints function to the given P_Context. -instance MetaModelContainer BuildStep where - metaModelsIn (Grind m) = Set.singleton m - metaModelsIn (MergeWith x) = metaModelsIn x - metaModelsIn EncloseInConstraints = mempty -instance MetaModelContainer a => MetaModelContainer [a] where - metaModelsIn = Set.unions . fmap metaModelsIn - --- | A simple recipe that builds from a script -script :: StartContext -> BuildRecipe -script x = BuildRecipe x [] --- | Merge two recipes together -merge :: BuildRecipe -> BuildRecipe -> BuildRecipe -merge a b = a `andThen` MergeWith b +-- | creating an FSpec is based on command-line options. +-- It follows a recipe for translating a P_Context (the parsed user script) into an FSpec (the type-checked and enriched result). +-- Ampersand parses its script (userScript) and adds semantics to it, depending on the recipe. +-- Currently, two semantic interpretations are available: FormalAmpersand and PrototypeContext. +-- (There may be more in the future.) +-- There are two relevant operations to take notice of to understand this code: +-- * mergeContexts :: P_Context -> P_Context -> P_Context +-- To merge two contexts means to take the union of the respective sets in the context. +-- mergeContexts behaves almost like a union operator. +-- Its result is a P_Context because the result must be typechecked as a whole. +-- * grind transformers :: FSpec -> P_Context +-- Grinding means to analyse the script down to the binary relations that constitute the metamodel. +-- It assembles these relations to form a valid P_Context. --- | Add an additional step after the steps of a recipe -andThen :: BuildRecipe -> BuildStep -> BuildRecipe -andThen (BuildRecipe start steps) step = BuildRecipe start (steps<>[step]) +-- Explanation Grind: +-- The "Grind" option is used for RAP because the "grinded" user script lands in the RAP-database. +-- The function pCtx2Fspec checks the user script for type errors, yielding 'userFspc'. +-- Grinding provides a minimal metamodel, which is devoid of empty relations. --- | This functions does the work in the kitchen: use the recipe to return a --- P_Context from which the FSpec can be built. --- Note that we do not want this function to run in the RIO monad, for we want it to --- be pure. Information that would otherwise have to be read as a side effect is now --- given as parameter, like the original user's P_Context, and a map that can be used --- to obtain GrindInfo for metamodels. -cook :: (HasFSpecGenOpts env) => - env -- ^ The environment - -> BuildRecipe -- ^ Instructions for the man in the kitchen - -> Map MetaModel GrindInfo -- ^ A map containing all GrindInfo that could be required - -> Guarded P_Context -- ^ The original user's P_Context, Guarded because it might have errors - -> Guarded P_Context -cook env (BuildRecipe start steps) grindInfoMap userScript = - doSteps =<< - (case start of - UserScript -> userScript - MetaScript mm -> pure . pModel $ gInfo mm) - where - doSteps :: P_Context -> Guarded P_Context - doSteps pCtx = foldM nextStep pCtx steps - where - nextStep :: P_Context -> BuildStep -> Guarded P_Context - nextStep ctx step = - case step of - EncloseInConstraints -> pure $ encloseInConstraints ctx - Grind mm -> grind (gInfo mm) <$> pCtx2Fspec env ctx - MergeWith recipe -> mergeContexts ctx <$> cook env recipe grindInfoMap userScript - gInfo :: MetaModel -> GrindInfo - gInfo mm = case Map.lookup mm grindInfoMap of - Just x -> x - Nothing -> fatal $ "metaModel `"<>tshow mm<>"`was not found!" - - --- | To analyse spreadsheets means to enrich the context with the relations that are defined in the spreadsheet. --- The function encloseInConstraints does not populate existing relations. --- Instead it invents relations from a given population, which typically comes from a spreadsheet. --- This is different from the normal behaviour, which checks whether the spreadsheets comply with the Ampersand-script. --- This function is called only with option 'dataAnalysis' on. -encloseInConstraints :: P_Context -> P_Context -encloseInConstraints pCtx = enrichedContext - where - --The result of encloseInConstraints is a P_Context enriched with the relations in genericRelations - --The population is reorganized in genericPopulations to accommodate the particular ISA-graph. - enrichedContext :: P_Context - enrichedContext - = pCtx{ ctx_ds = mergeRels (genericRelations<>declaredRelations) - , ctx_pops = genericPopulations - } - declaredRelations :: [P_Relation] -- relations declared in the user's script - popRelations :: [P_Relation] -- relations that are "annotated" by the user in Excel-sheets. - -- popRelations are derived from P_Populations only. - declaredRelations = mergeRels (ctx_ds pCtx<>concatMap pt_dcs (ctx_pats pCtx)) - -- | To derive relations from populations, we derive the signature from the population's signature directly. - -- Multiplicity properties are added to constrain the population without introducing violations. - popRelations - = [ computeProps rel - | pop@P_RelPopu{p_src = src, p_tgt = tgt}<-ctx_pops pCtx<>[pop |pat<-ctx_pats pCtx, pop<-pt_pop pat] - , Just src'<-[src], Just tgt'<-[tgt] - , rel<-[ P_Relation{ dec_nm = name pop - , dec_sign = P_Sign src' tgt' - , dec_prps = mempty - , dec_pragma = mempty - , dec_Mean = mempty - , pos = origin pop - }] - , signatur rel `notElem` map signatur declaredRelations - ] - where - computeProps :: P_Relation -> P_Relation - computeProps rel - = rel{dec_prps = Set.fromList ([ Uni | isUni popR]<>[ Tot | isTot ]<>[ Inj | isInj popR ]<>[ Sur | isSur ])} - where - sgn = dec_sign rel - s = pSrc sgn; t = pTgt sgn - popu :: P_Concept -> Set.Set PAtomValue - popu c = (Set.fromList . concatMap p_popas) [ pop | pop@P_CptPopu{}<-pops, name c==name pop ] - popR :: Set.Set PAtomPair - popR = (Set.fromList . concatMap p_popps ) - [pop - | pop@P_RelPopu {p_src = src, p_tgt = tgt} <- pops - , name rel == name pop - , Just src' <- [src] - , src' == s - , Just tgt' <- [tgt] - , tgt' == t - ] - domR = Set.fromList . map ppLeft . Set.toList $ popR - codR = Set.fromList . map ppRight . Set.toList $ popR - equal f (a,b) = f a == f b - isUni :: Set.Set PAtomPair -> Bool - isUni x = null . Set.filter (not . equal ppRight) . Set.filter (equal ppLeft) $ cartesianProduct x x - isTot = popu s `Set.isSubsetOf` domR - isInj :: Set.Set PAtomPair -> Bool - isInj x = null . Set.filter (not . equal ppLeft) . Set.filter (equal ppRight) $ cartesianProduct x x - isSur = popu t `Set.isSubsetOf` codR - cartesianProduct :: -- Should be implemented as Set.cartesianProduct, but isn't. See https://github.com/commercialhaskell/rio/issues/177 - (Ord a, Ord b) => Set a -> Set b -> Set (a, b) - cartesianProduct xs ys = Set.fromList $ liftA2 (,) (toList xs) (toList ys) - genericRelations :: [P_Relation] -- generalization of popRelations due to CLASSIFY statements - genericPopulations :: [P_Population] -- generalization of popRelations due to CLASSIFY statements - -- | To derive relations from populations, we derive the signature from the population's signature directly. - -- Multiplicity properties are added to constrain the population without introducing violations. - (genericRelations, genericPopulations) - = recur [] popRelations pops invGen - where - recur :: [P_Concept]->[P_Relation]->[P_Population]->[(P_Concept,Set.Set P_Concept)]->([P_Relation], [P_Population]) - recur seen unseenrels unseenpops ((g,specs):invGens) - = if g `elem` seen then fatal ("Concept "<>name g<>" has caused a cycle error.") else - recur (g:seen) (genericRels<>remainder) (genericPops<>remainPop) invGens - where - sameNameTargetRels :: [NE.NonEmpty P_Relation] - sameNameTargetRels = eqCl (\r->(name r,targt r)) unseenrels - genericRels :: [P_Relation] - remainingRels :: [[P_Relation]] - (genericRels, remainingRels) - = 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]) - } -- 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 - ) - | sRel<-sameNameTargetRels - , specs `Set.isSubsetOf` (Set.fromList . NE.toList $ fmap sourc sRel) - , headrel<-[NE.head sRel] - ] - remainder :: [P_Relation] - remainder - = concat (remainingRels<>fmap NE.toList - [ sRel | sRel<-sameNameTargetRels - , not (specs `Set.isSubsetOf` (Set.fromList . NE.toList $ fmap sourc sRel))] - ) - sameNameTargetPops :: [NE.NonEmpty P_Population] - sameNameTargetPops = eqCl (\r->(name r,tgtPop r)) unseenpops - genericPops :: [P_Population] - remainingPops :: [[P_Population]] - (genericPops, remainingPops) - = L.unzip - [ ( headPop{p_src=Just g} -- the generic relation that summarizes sRel - -- , [ pop| pop<-sPop, srcPop pop `elem` specs ] -- the specific (and therefore obsolete) populations - , [ pop| pop<-NE.toList sPop, srcPop pop `notElem` specs ] -- the remaining relations - ) - | sPop<-sameNameTargetPops - , specs `Set.isSubsetOf` (Set.fromList . NE.toList $ fmap srcPop sPop) - , headPop@P_RelPopu{}<-[NE.head sPop] -- Restrict to @P_RelPopu{} because field name p_src is being used - ] - remainPop :: [P_Population] - remainPop - = concat (remainingPops<>fmap NE.toList - [ sPop | sPop<-sameNameTargetPops - , not (specs `Set.isSubsetOf` (Set.fromList . NE.toList $ fmap srcPop sPop))] - ) - recur _ rels popus [] = (rels,popus) - srcPop, tgtPop :: P_Population -> P_Concept -- get the source concept of a P_Population. - srcPop pop@P_CptPopu{} = PCpt (name pop) - srcPop pop@P_RelPopu{p_src = src} = case src of Just s -> s; _ -> fatal ("srcPop ("<>showP pop<>") is mistaken.") - tgtPop pop@P_CptPopu{} = PCpt (name pop) - tgtPop pop@P_RelPopu{p_tgt = tgt} = case tgt of Just t -> t; _ -> fatal ("tgtPop ("<>showP pop<>") is mistaken.") - - sourc, targt :: P_Relation -> P_Concept -- get the source concept of a P_Relation. - sourc = pSrc . dec_sign - targt = pTgt . dec_sign - invGen :: [(P_Concept,Set.Set P_Concept)] -- each pair contains a concept with all of its specializations - invGen = [ (fst (NE.head cl), Set.fromList spcs) - | cl<-eqCl fst [ (g,specific gen) | gen<-ctx_gs pCtx, g<-NE.toList (generics gen)] - , g<-[fst (NE.head cl)], spcs<-[[snd c | c<-NE.toList cl, snd c/=g]], not (null spcs) - ] - signatur :: P_Relation -> (Text, P_Sign) - signatur rel =(name rel, dec_sign rel) - concepts = L.nub $ - [ PCpt (name pop) | pop@P_CptPopu{}<-ctx_pops pCtx] <> - [ src' | P_RelPopu{p_src = src}<-ctx_pops pCtx, Just src'<-[src]] <> - [ tgt' | P_RelPopu{p_tgt = tgt}<-ctx_pops pCtx, Just tgt'<-[tgt]] <> - map sourc declaredRelations<> map targt declaredRelations<> - concat [specific gen: NE.toList (generics gen)| gen<-ctx_gs pCtx] - pops = computeConceptPopulations (ctx_pops pCtx<>[p |pat<-ctx_pats pCtx, p<-pt_pop pat]) -- All populations defined in this context, from POPULATION statements as well as from Relation declarations. - computeConceptPopulations :: [P_Population] -> [P_Population] - computeConceptPopulations pps -- I feel this computation should be done in P2A_Converters.hs, so every A_structure has compliant populations. - = [ P_CptPopu{pos = OriginUnknown, p_cpt = c, p_popas = L.nub $ - [ atom | cpt@P_CptPopu{}<-pps, PCpt (name cpt) == c, atom<-p_popas cpt]<> - [ ppLeft pair - | pop@P_RelPopu{p_src = src}<-pps, Just src'<-[src], src' == c - , pair<-p_popps pop]<> - [ ppRight pair - | pop@P_RelPopu{p_tgt = tgt}<-pps, Just tgt'<-[tgt], tgt' == c - , pair<-p_popps pop]} - | c<-concepts - ] <> - [ rpop{p_popps=concatMap p_popps cl} - | cl<-eqCl (\pop->(name pop,p_src pop,p_tgt pop)) [ pop | pop@P_RelPopu{}<-pps], rpop<-[NE.head cl] - ] - --- specializations :: P_Concept -> [P_Concept] --- specializations cpt = nub $ cpt: [ specific gen | gen<-ctx_gs pCtx, cpt `elem` generics gen ] --- generalizations :: P_Concept -> [P_Concept] --- generalizations cpt = nub $ cpt: [ g | gen<-ctx_gs pCtx, g<-NE.toList (generics gen), cpt==specific gen ] +-- Explanation RAP +-- The entire FormalAmpersand metamodel is called 'faScript' in the code below. +-- It is merged into the result so the RAP-database can hold the grinded results of any valid Ampersand script. +-- The metamodel FormalAmpersand is also incorporated in the database, so +-- RAP can populate this metamodel with grinded user scripts for showing an Atlas. +-- It also incorporates PrototypeContext because RAP is a running application. +-- Explanation Prototype +-- The "Prototype" option is used to generate prototypes. It combines the user script +-- with some navigation elements from the prototype context. +-- That is why 'one' is the combination of the user script and the metamodel of the prototype context. +-- The compiler typechecks the combination because a user might inadvertedly use concepts from the prototype context. +-- In that case he is in for a suprise, but at least the system does not land on its back. +createFspec :: (HasFSpecGenOpts env, HasLogFunc env) => + RIO env (Guarded FSpec) +createFspec = + do env <- ask + let recipe = view recipeL env + userScript <- do + rootFiles <- view rootFileL + snd <$> parseFilesTransitive rootFiles -- the P_Context of the user's sourceFile + formalAmpersandScript <- parseFormalAmpersand + prototypeContextScript <- parsePrototypeContext + let pContext + = case recipe of + Standard -> userScript + Grind -> do userScr <- userScript + userFspc <- pCtx2Fspec env userScr + return (grind transformersFormalAmpersand userFspc) + Prototype -> do userPCtx <- userScript + let one = userPCtx `mergeContexts` metaModel PrototypeContext + oneFspec <- pCtx2Fspec env one -- this is done to typecheck the combination + let two = grind transformersPrototypeContext oneFspec + pcScript <- prototypeContextScript + return (one `mergeContexts` two `mergeContexts` pcScript) + RAP -> do rapPCtx <- userScript + faScript <- formalAmpersandScript + let one = rapPCtx `mergeContexts` metaModel PrototypeContext `mergeContexts` faScript + oneFspec <- pCtx2Fspec env one -- this is done to typecheck the combination + let two = grind transformersPrototypeContext oneFspec + pcScript <- prototypeContextScript + return (one `mergeContexts` two `mergeContexts` pcScript) + return (pCtx2Fspec env =<< pContext) diff --git a/src/Ampersand/FSpec/ToFSpec/NormalForms.hs b/src/Ampersand/FSpec/ToFSpec/NormalForms.hs index deca041801..92d92ea3e9 100644 --- a/src/Ampersand/FSpec/ToFSpec/NormalForms.hs +++ b/src/Ampersand/FSpec/ToFSpec/NormalForms.hs @@ -1,5 +1,5 @@ {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedStrings #-} + module Ampersand.FSpec.ToFSpec.NormalForms ( conjNF , cfProof diff --git a/src/Ampersand/FSpec/ToFSpec/Populated.hs b/src/Ampersand/FSpec/ToFSpec/Populated.hs index e5274b41d9..5e53dea48c 100644 --- a/src/Ampersand/FSpec/ToFSpec/Populated.hs +++ b/src/Ampersand/FSpec/ToFSpec/Populated.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE OverloadedStrings #-} + module Ampersand.FSpec.ToFSpec.Populated (fullContents,atomValuesOf , smallerConcepts, largerConcepts, sortSpecific2Generic diff --git a/src/Ampersand/FSpec/Transformers.hs b/src/Ampersand/FSpec/Transformers.hs index 98404a6ded..94704ba599 100644 --- a/src/Ampersand/FSpec/Transformers.hs +++ b/src/Ampersand/FSpec/Transformers.hs @@ -1,8 +1,8 @@ {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedStrings #-} + {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE UndecidableInstances #-} -module Ampersand.FSpec.Transformers +module Ampersand.FSpec.Transformers ( transformersFormalAmpersand , transformersPrototypeContext , Transformer(..) @@ -18,27 +18,29 @@ import Ampersand.FSpec.FSpec import Ampersand.FSpec.Motivations import qualified RIO.NonEmpty as NE import qualified RIO.Set as Set +import qualified RIO.Text as T import qualified Text.Pandoc.Shared as P -- | The function that retrieves the population of -- some relation of Formal Ampersand of a given -- ampersand script. -data Transformer = Transformer +data Transformer = Transformer { tRel :: Text -- name of relation , tSrc :: Text -- name of source , tTrg :: Text -- name of target - , tPairs :: Set.Set (PopAtom,PopAtom)-- the population of this relation from the user's script. + , mults :: Props -- multiplicity constraints + , tPairs :: [PAtomPair]-- the population of this relation from the user's script. } -- | This datatype reflects the nature of an atom. It is use to construct --- the atom. -data PopAtom = +-- the atom. +data PopAtom = DirtyId Text -- ^ Any Text. must be: -- * unique in the scope of the entire fspec -- * storable in a 255 database field | PopAlphaNumeric Text -- ^ Intended to be observable by users. Not a 'dirty id'. - | PopInt Integer + | PopInt Integer deriving (Eq,Ord) instance Show PopAtom where show x @@ -48,844 +50,873 @@ instance Show PopAtom where PopInt i -> show i dirtyId :: Unique a => a -> PopAtom -dirtyId = DirtyId . idWithType +dirtyId = DirtyId . idWithoutType -- Function for PrototypeContext transformers. These atoms don't need to have a type prefix -dirtyIdWithoutType :: Unique a => a -> PopAtom -dirtyIdWithoutType = DirtyId . idWithoutType +toTransformer :: (Text, Text, Text, Props, [ (PopAtom,PopAtom)] ) -> Transformer +toTransformer (rel,src,tgt,multiplicities,tuples) + = Transformer rel src tgt multiplicities tuples' + where + tuples' :: [PAtomPair] + tuples' = map popAtomPair2PAtomPair tuples + popAtomPair2PAtomPair (a,b) + = PPair MeatGrinder (pAtom2AtomValue a) (pAtom2AtomValue b) + pAtom2AtomValue :: PopAtom -> PAtomValue + pAtom2AtomValue atm = + case atm of + DirtyId str -> ScriptString MeatGrinder str + PopAlphaNumeric str -> ScriptString MeatGrinder str + PopInt i -> ScriptInt MeatGrinder i -toTransformer :: (Text, Text, Text, Set.Set (PopAtom,PopAtom) ) -> Transformer -toTransformer (rel,src,tgt,tuples) = Transformer rel src tgt tuples -- | The list of all transformers, one for each and every relation in Formal Ampersand. transformersFormalAmpersand :: FSpec -> [Transformer] transformersFormalAmpersand fSpec = map toTransformer [ - ("allConjuncts" , "Context" , "Conjunct" - , Set.fromList $ - [(dirtyId ctx, dirtyId conj ) - | ctx::A_Context <- instanceList fSpec - , conj::Conjunct <- instanceList fSpec +{- +-} +-- RELATION acdcpt[ConceptDef*Text] [UNI] -- ^ The name of the concept for which this is the definition. If there is no such concept, the conceptdefinition is ignored. + ("acdcpt" , "ConceptDef" , "ConceptName" + , Set.fromList [Uni] + , [ (dirtyId cdf, PopAlphaNumeric . tshow . acdcpt $ cdf) + | cdf::AConceptDef <- instanceList fSpec + ] + ) +-- RELATION acddef2[ConceptDef*Meaning] [UNI] -- ^ The textual definition of this concept. + ,("acddef2" , "ConceptDef" , "Meaning" + , Set.fromList [Uni] + , [ (dirtyId cdf, dirtyId mean) + | cdf::AConceptDef <- instanceList fSpec + , mean::Meaning <- acdmean cdf + ] + ) +-- RELATION acdfrom[ConceptDef*Pattern] [UNI] -- ^ The name of the pattern or context in which this concept definition was made + ,("acdfrom" , "ConceptDef" , "Pattern" + , Set.fromList [Uni] + , [ (dirtyId cdf, dirtyId pat) + | pat::Pattern <- instanceList fSpec + , cdf::AConceptDef <- ptcds pat + ] + ) +-- RELATION acdmean[ConceptDef*Meaning] [UNI] -- ^ User-specified meanings, possibly more than one, for multiple languages. + ,("acdmean" , "ConceptDef" , "Meaning" + , Set.empty + , [ (dirtyId cdf, dirtyId mean) + | cdf::AConceptDef <- instanceList fSpec + , mean::Meaning <- acdmean cdf + ] + ) +-- RELATION acdpos[ConceptDef*Origin] [UNI] -- ^ The position of this definition in the text of the Ampersand source (filename, line number and column number). + ,("acdpos" , "ConceptDef" , "Origin" + , Set.fromList [Uni] + , [ (dirtyId cdf, PopAlphaNumeric . tshow . origin $ cdf) + | cdf::AConceptDef <- instanceList fSpec ] ) - ,("allRoles" , "Context" , "Role" - , Set.fromList $ - [(dirtyId ctx, dirtyId rol ) + ,("allConjuncts" , "Context" , "Conjunct" + , Set.fromList [Inj] + , [ (dirtyId ctx, dirtyId conj) | ctx::A_Context <- instanceList fSpec - , rol::Role <- instanceList fSpec + , conj::Conjunct <- instanceList fSpec ] ) - ,("allRules" , "Context" , "Rule" - , Set.fromList $ - [(dirtyId ctx, dirtyId rul) + ,("allRoles" , "Context" , "Role" + , Set.fromList [Inj] + , [ (dirtyId ctx, dirtyId rol) | ctx::A_Context <- instanceList fSpec - , rul::Rule <- Set.elems $ allRules ctx + , rol::Role <- instanceList fSpec ] ) - ,("allRules" , "Pattern" , "Rule" - , Set.fromList $ - [(dirtyId pat, dirtyId rul) + ,("allRules" , "Pattern" , "Rule" + , Set.fromList [{-Inj-}] + , [ (dirtyId pat, dirtyId rul) | pat::Pattern <- instanceList fSpec , rul::Rule <- Set.elems $ allRules pat ] ) - ,("arg" , "UnaryTerm" , "Expression" - , Set.fromList $ - [(dirtyId expr, dirtyId x) + ,("allRules" , "Rule" , "Context" + , Set.fromList [Uni {-,Sur-}] + , [ (dirtyId rul, dirtyId ctx) + | ctx::A_Context <- instanceList fSpec + , rul::Rule <- Set.elems $ allRules ctx + ] + ) + ,("arg" , "UnaryTerm" , "Term" + , Set.fromList [Uni,Tot] + , [ (dirtyId expr, dirtyId x) | expr::Expression <- instanceList fSpec , Just x <- [arg expr] ] ) ,("asMarkdown" , "Markup" , "Text" - , Set.fromList - [(dirtyId mrk,(PopAlphaNumeric . P.stringify . amPandoc) mrk) + , Set.fromList [Uni,Tot] + , [ (dirtyId mrk,(PopAlphaNumeric . P.stringify . amPandoc) mrk) | mrk::Markup <- instanceList fSpec ] ) - ,("attIn" , "Attribute" , "ObjectDef" - , Set.empty --TODO - ) - ,("attObj" , "Attribute" , "ObjectDef" - , Set.empty --TODO - ) ,("bind" , "BindedRelation" , "Relation" - , Set.fromList $ - [(dirtyId expr, dirtyId x) + , Set.fromList [Uni,Tot] + , [ (dirtyId expr, dirtyId x) | expr::Expression <- instanceList fSpec , Just x <- [bindedRel expr] ] ) - ,("changes" , "Act" , "Relation" - , Set.empty --TODO - ) - ,("concepts" , "Pattern" , "Concept" - , Set.fromList $ - [(dirtyId pat, dirtyId cpt) + ,("concepts" , "Pattern" , "Concept" + , Set.empty + , [ (dirtyId pat, dirtyId cpt) | pat::Pattern <- instanceList fSpec , cpt::A_Concept <- Set.elems $ concs pat ] ) - ,("conjunct" , "Conjunct" , "Expression" - , Set.fromList $ - [(dirtyId conj, dirtyId (rc_conjunct conj)) + ,("rc_conjunct" , "Conjunct" , "Term" + , Set.fromList [Uni,Tot] + , [ (dirtyId conj, dirtyId (rc_conjunct conj)) | conj::Conjunct <- instanceList fSpec ] ) - ,("context" , "Concept" , "Context" - , Set.fromList $ - [(dirtyId cpt, dirtyId ctx) - | ctx::A_Context <- instanceList fSpec - , cpt::A_Concept <- instanceList fSpec + ,("context" , "Concept" , "Context" + , Set.fromList [Uni] + , [ (dirtyId cpt, dirtyId ctx) + | ctx::A_Context <- instanceList fSpec + , cpt::A_Concept <- Set.toList . concs $ ctx + ] + ) + ,("context" , "Interface" , "Context" + , Set.fromList [Uni,Tot] + , [ (dirtyId ifc,dirtyId ctx) + | ctx::A_Context <- instanceList fSpec + , ifc::Interface <- ctxifcs ctx ] ) - ,("context" , "IdentityDef" , "Context" - , Set.fromList $ - [(dirtyId idf, dirtyId ctx) - | ctx::A_Context <- instanceList fSpec - , idf::IdentityDef <- instanceList fSpec + ,("context" , "Isa" , "Context" + , Set.fromList [Uni,Tot] + , [ (dirtyId isa, dirtyId ctx) + | ctx::A_Context <- instanceList fSpec + , isa@Isa{} <- instanceList fSpec + ] + ) + ,("context" , "IsE" , "Context" + , Set.fromList [Uni,Tot] + , [ (dirtyId ise, dirtyId ctx) + | ctx::A_Context <- instanceList fSpec + , ise@IsE{} <- instanceList fSpec ] ) - ,("context" , "Pattern" , "Context" - , Set.fromList $ - [(dirtyId pat, dirtyId ctx) + ,("context" , "Pattern" , "Context" + , Set.fromList [Uni,Tot] + , [ (dirtyId pat, dirtyId ctx) | ctx::A_Context <- instanceList fSpec , pat::Pattern <- instanceList fSpec ] ) - ,("context" , "Population" , "Context" - , Set.fromList $ - [(dirtyId pop, dirtyId ctx) + ,("context" , "Population" , "Context" + , Set.fromList [Uni,Tot] + , [ (dirtyId pop, dirtyId ctx) | ctx::A_Context <- instanceList fSpec , pop::Population <- instanceList fSpec ] ) - ,("context" , "Relation" , "Context" - , Set.fromList $ - [(dirtyId rel, dirtyId ctx) + ,("ctxcds" , "ConceptDef" , "Context" + , Set.fromList [Uni,Tot] + , [ (dirtyId cdf, dirtyId ctx) | ctx::A_Context <- instanceList fSpec - , rel::Relation <- instanceList fSpec + , cdf::AConceptDef <- instanceList fSpec ] ) - ,("ctxds" , "Relation" , "Context" - , Set.fromList $ - [(dirtyId rel, dirtyId ctx) + ,("relsDefdIn" , "Relation" , "Context" + , Set.fromList [Uni,Tot] + , [ (dirtyId rel, dirtyId ctx) | ctx::A_Context <- instanceList fSpec - , rel::Relation <- Set.elems $ ctxds ctx + , rel::Relation <- Set.elems $ relsDefdIn ctx ] ) - ,("ctxrs" , "Rule" , "Context" - , Set.fromList $ - [(dirtyId rul, dirtyId ctx) + ,("ctxds" , "Relation" , "Context" + , Set.fromList [Uni] + , [ (dirtyId rel, dirtyId ctx) | ctx::A_Context <- instanceList fSpec - , rul::Rule <- Set.elems $ ctxrs ctx + , rel::Relation <- Set.elems $ ctxds ctx ] ) - ,("declaredIn" , "Relation" , "Context" - , Set.fromList $ - [(dirtyId rel, dirtyId ctx) + ,("ctxrs" , "Rule" , "Context" + , Set.fromList [Uni] + , [ (dirtyId rul, dirtyId ctx) | ctx::A_Context <- instanceList fSpec - , rel::Relation <- Set.elems $ relsDefdIn ctx + , rul::Rule <- Set.elems . ctxrs $ ctx ] ) - ,("declaredIn" , "Relation" , "Pattern" - , Set.fromList $ - [(dirtyId rel, dirtyId pat) + ,("declaredIn" , "Relation" , "Pattern" + , Set.empty + , [ (dirtyId rel, dirtyId pat) | pat::Pattern <- instanceList fSpec , rel::Relation <- Set.elems $ relsDefdIn pat ] ) - ,("declaredthrough" , "PropertyRule" , "Property" - , Set.fromList $ - [(dirtyId rul, PopAlphaNumeric . tshow $ prop) - | rul::Rule <- instanceList fSpec - , Just(prop,_) <- [rrdcl rul] - ] - ) - ,("decMean" , "Relation" , "Meaning" - , Set.fromList $ - [(dirtyId rel, dirtyId mean) + ,("decMean" , "Relation" , "Meaning" + , Set.empty + , [ (dirtyId rel, dirtyId mean) | rel::Relation <- instanceList fSpec , mean::Meaning <- decMean rel ] ) - ,("decprL" , "Relation" , "String" - , Set.fromList $ - [(dirtyId rel, (PopAlphaNumeric . decprL) rel) + ,("decprL" , "Relation" , "String" + , Set.fromList [Uni] + , [ (dirtyId rel, (PopAlphaNumeric . decprL) rel) | rel::Relation <- instanceList fSpec + , (not . T.null . decprL) rel ] ) - ,("decprM" , "Relation" , "String" - , Set.fromList $ - [(dirtyId rel, (PopAlphaNumeric . decprM) rel) + ,("decprM" , "Relation" , "String" + , Set.fromList [Uni] + , [ (dirtyId rel, (PopAlphaNumeric . decprM) rel) | rel::Relation <- instanceList fSpec + , (not . T.null . decprM) rel ] ) - ,("decprR" , "Relation" , "String" - , Set.fromList $ - [(dirtyId rel, (PopAlphaNumeric . decprR) rel) + ,("decprR" , "Relation" , "String" + , Set.fromList [Uni] + , [ (dirtyId rel, (PopAlphaNumeric . decprR) rel) | rel::Relation <- instanceList fSpec + , (not . T.null . decprR) rel ] ) - ,("default" , "View" , "Concept" - , Set.empty --TODO - ) - ,("delta" , "Act" , "Pair" - , Set.empty --TODO - ) ,("expSQL" , "PairViewSegment" , "MySQLQuery" - , Set.empty --TODO + , Set.empty + , [] --TODO ) - ,("expTgt" , "PairViewSegment" , "Concept" - , Set.empty --TODO + ,("expTgt" , "PairViewSegment" , "Concept" + , Set.empty + , [] --TODO ) - ,("first" , "BinaryTerm" , "Expression" - , Set.fromList $ - [(dirtyId expr, dirtyId x) + ,("fieldIn" , "FieldDef" , "ObjectDef" + , Set.fromList [Uni,Tot] + , [ (dirtyId fld, dirtyId obj) + | obj::ObjectDef <- instanceList fSpec + , fld <- fields obj + ] + ) + ,("first" , "BinaryTerm" , "Term" + , Set.fromList [Uni,Tot] + , [ (dirtyId expr, dirtyId x) | expr::Expression <- instanceList fSpec , Just x <- [first expr] ] ) - ,("formalExpression" , "Rule" , "Expression" - , Set.fromList $ - [(dirtyId rul, dirtyId (formalExpression rul)) + ,("formalTerm" , "Rule" , "Term" + , Set.fromList [Uni] + , [ (dirtyId rul, dirtyId (formalExpression rul)) | rul::Rule <- instanceList fSpec ] ) - ,("gengen" , "Isa" , "Concept" - , Set.fromList $ - [ ( dirtyId isa, dirtyId (gengen isa)) + ,("gengen" , "Isa" , "Concept" + , Set.fromList [Uni,Tot] + , [ ( dirtyId isa, dirtyId (gengen isa)) | isa@Isa{} <- instanceList fSpec ] ) - ,("gengen" , "IsE" , "Concept" - , Set.fromList $ - [ ( dirtyId ise, dirtyId cpt) + ,("gengen" , "IsE" , "Concept" + , Set.fromList [Tot] + , [ ( dirtyId ise, dirtyId cpt) | ise@IsE{} <- instanceList fSpec , cpt <- NE.toList $ genrhs ise] ) - ,("gens" , "Context" , "Isa" - , Set.fromList $ - [(dirtyId ctx, dirtyId isa) - | ctx::A_Context <- instanceList fSpec - , isa@Isa{} <- instanceList fSpec - ] - ) - ,("gens" , "Context" , "IsE" - , Set.fromList $ - [ ( dirtyId ctx, dirtyId ise) - | ctx::A_Context <- instanceList fSpec - , ise@IsE{} <- instanceList fSpec - ] - ) - ,("genspc" , "IsE" , "Concept" - , Set.fromList $ - [ ( dirtyId ise, dirtyId (genspc ise)) + ,("genspc" , "IsE" , "Concept" + , Set.fromList [Uni,Tot] + , [ ( dirtyId ise, dirtyId (genspc ise)) | ise@IsE{} <- instanceList fSpec ] ) - ,("genspc" , "Isa" , "Concept" - , Set.fromList $ - [ ( dirtyId isa, dirtyId (genspc isa)) + ,("genspc" , "Isa" , "Concept" + , Set.fromList [Uni,Tot] + , [ ( dirtyId isa, dirtyId (genspc isa)) | isa@Isa{} <- instanceList fSpec ] ) - ,("getExpressionRelation" , "Expression" , "Relation" - , Set.empty --TODO - ) - ,("hasView" , "Concept" , "Concept" - , Set.empty --TODO - ) - ,("identityRules" , "Rule" , "Context" - , Set.fromList $ - [(dirtyId rul, dirtyId ctx) + ,("identityRules" , "Rule" , "Context" + , Set.fromList [Uni] + , [ (dirtyId rul, dirtyId ctx) | ctx::A_Context <- instanceList fSpec , rul <- Set.elems $ identityRules ctx ] ) - ,("identityRules" , "Rule" , "Pattern" - , Set.fromList $ - [(dirtyId rul, dirtyId pat) + ,("identityRules" , "Rule" , "Pattern" + , Set.fromList [Uni] + , [ (dirtyId rul, dirtyId pat) | pat::Pattern <- instanceList fSpec , rul <- Set.elems $ identityRules pat ] ) - ,("ifcClass" , "Interface" , "String" - , Set.empty --TODO - ) - ,("ifcControls" , "Interface" , "Conjunct" - , Set.fromList $ - [(dirtyId ifc, dirtyId conj) + ,("ifcConjuncts" , "Interface" , "Conjunct" + , Set.empty + , [ (dirtyId ifc, dirtyId conj) | ifc::Interface <- instanceList fSpec - , conj <- ifcControls ifc + , conj <- ifcConjuncts ifc ] ) ,("ifcInputs" , "Interface" , "Relation" - , Set.empty --TODO + , Set.empty + , [] --TODO ) ,("ifcObj" , "Interface" , "ObjectDef" - , Set.fromList $ - [(dirtyId ifc, dirtyId (ifcObj ifc)) + , Set.fromList [Uni,Tot] + , [ (dirtyId ifc, dirtyId (ifcObj ifc)) | ifc::Interface <- instanceList fSpec ] ) ,("ifcOutputs" , "Interface" , "Relation" - , Set.empty --TODO + , Set.empty + , [] --TODO ) - ,("ifcPos" , "Interface" , "Origin" - , Set.fromList $ - [(dirtyId ifc, PopAlphaNumeric . tshow . ifcPos $ ifc) + ,("ifcPos" , "Interface" , "Origin" + , Set.fromList [Uni] + , [ (dirtyId ifc, PopAlphaNumeric . tshow . origin $ ifc) | ifc::Interface <- instanceList fSpec + , origin ifc `notElem` [OriginUnknown, MeatGrinder] ] ) - ,("ifcPrp" , "Interface" , "String" - , Set.empty --TODO - ) - ,("ifcQuads" , "Interface" , "Quad" - , Set.empty --TODO - ) - ,("ifcRoles" , "Interface" , "Role" - , Set.empty --TODO - ) - ,("in" , "Pair" , "Expression" - , Set.empty --TODO - ) - ,("inQ" , "Quad" , "Act" - , Set.empty --TODO - ) - ,("inst" , "Object" , "ObjectDef" - , Set.empty --TODO - ) - ,("inst" , "Transaction" , "Interface" - , Set.empty --TODO - ) - ,("interfaces" , "Context" , "Interface" - , Set.fromList $ - [(dirtyId ctx,dirtyId ifc) - | ctx::A_Context <- instanceList fSpec - , ifc::Interface <- instanceList fSpec + ,("ifcPurpose" , "Interface" , "Purpose" + , Set.empty + , [ (dirtyId ifc, dirtyId purp) + | ifc::Interface <- instanceList fSpec + , purp <- purposes fSpec ifc ] ) - ,("interfaces" , "Role" , "Interface" - , Set.fromList $ - [(dirtyId rol,dirtyId ifc) + ,("ifcRoles" , "Interface" , "Role" + , Set.empty + , [ (dirtyId ifc,dirtyId rol) | ifc <- instanceList fSpec , rol <- ifcRoles ifc - ] + ] + ) + , ("isAPI" , "Interface" , "Interface" + , Set.fromList [Asy,Sym] + , [ (dirtyId ifc, dirtyId ifc) + | ifc::Interface <- instanceList fSpec + , ifcIsAPI ifc + ] ) - ,("isa" , "Concept" , "Concept" - , Set.fromList - [ ( dirtyId gCpt, dirtyId (genspc ise)) +-- the following transformer can be calculated by the Exec Engine. So it can be removed here if so desired. + , ("isPublic" , "Interface" , "Interface" + , Set.fromList [Asy,Sym] + , [ (dirtyId ifc, dirtyId ifc) + | ifc::Interface <- instanceList fSpec + , null (ifcRoles ifc) + ] + ) + ,("isa" , "Concept" , "Concept" + , Set.empty + , [ ( dirtyId gCpt, dirtyId (genspc ise)) | ise@IsE{} <- instanceList fSpec , gCpt <- NE.toList $ genrhs ise - ] `Set.union` - Set.fromList - [ ( dirtyId (genspc isa), dirtyId (genspc isa)) + ] ++ + [ ( dirtyId (genspc isa), dirtyId (genspc isa)) | isa@Isa{} <- instanceList fSpec ] ) - ,("isaCopy" , "Concept" , "Concept" - , Set.empty --TODO - ) - ,("isaPlus" , "Concept" , "Concept" - , Set.empty --TODO - ) - ,("isaRfx" , "Concept" , "Concept" - , Set.empty --TODO - ) - ,("isaRfxCopy" , "Concept" , "Concept" - , Set.empty --TODO - ) - ,("isaRfxPlus" , "Concept" , "Concept" - , Set.empty --TODO - ) - ,("isaRfxStar" , "Concept" , "Concept" - , Set.empty --TODO - ) - ,("isaStar" , "Concept" , "Concept" - , Set.empty --TODO + ,("label" , "FieldDef" , "FieldName" + , Set.fromList [Uni,Tot] + , [ (dirtyId fld, PopAlphaNumeric (name obj)) + | obj::ObjectDef <- instanceList fSpec + , fld <- fields obj + ] ) ,("language" , "Context" , "Language" - , Set.fromList - [(dirtyId ctx,(PopAlphaNumeric . tshow . ctxlang) ctx) + , Set.empty + , [ (dirtyId ctx,(PopAlphaNumeric . tshow . ctxlang) ctx) | ctx::A_Context <- instanceList fSpec ] ) ,("language" , "Markup" , "Language" - , Set.fromList - [(dirtyId mrk,(PopAlphaNumeric . tshow . amLang) mrk) + , Set.empty + , [ (dirtyId mrk,(PopAlphaNumeric . tshow . amLang) mrk) | mrk::Markup <- instanceList fSpec ] ) - ,("left" , "Pair" , "Atom" - , Set.empty --This goes too deep. Keep it empty. - ) - ,("maintains" , "Role" , "Rule" - , Set.fromList - [(dirtyId rol, dirtyId rul) - | (rol,rul) <- fRoleRuls fSpec + ,("maintains" , "Role" , "Rule" + , Set.empty + , [ (dirtyId rol, dirtyId rul) + | (rol,rul) <- fRoleRuls fSpec ] ) ,("markup" , "Meaning" , "Markup" - , Set.fromList - [ (dirtyId mean, dirtyId . ameaMrk $ mean) + , Set.fromList [Uni,Tot] + , [ (dirtyId mean, dirtyId . ameaMrk $ mean) | mean::Meaning <- Set.toList . meaningInstances $ fSpec ] ) ,("markup" , "Purpose" , "Markup" - , Set.fromList - [(dirtyId purp, dirtyId . explMarkup $ purp) + , Set.fromList [Uni,Tot] + , [ (dirtyId purp, dirtyId . explMarkup $ purp) | purp::Purpose <- Set.toList . purposeInstances $ fSpec ] ) - ,("meaning" , "Rule" , "Meaning" - , Set.fromList $ - [(dirtyId rul, dirtyId mean) + ,("meaning" , "Rule" , "Meaning" + , Set.empty + , [ (dirtyId rul, dirtyId mean) | rul::Rule <- instanceList fSpec , mean::Meaning <- rrmean rul ] ) - ,("message" , "Rule" , "Message" - , Set.empty --TODO + ,("message" , "Rule" , "Message" + , Set.empty + , [] --TODO ) - ,("multrules" , "Rule" , "Context" - , Set.fromList - [(dirtyId rul, dirtyId ctx) + ,("multrules" , "Rule" , "Context" + , Set.empty + , [ (dirtyId rul, dirtyId ctx) | ctx::A_Context <- instanceList fSpec , rul <- Set.elems $ multrules ctx ] ) - ,("multrules" , "Rule" , "Pattern" - , Set.fromList - [(dirtyId rul, dirtyId pat) + ,("multrules" , "Rule" , "Pattern" + , Set.empty + , [ (dirtyId rul, dirtyId pat) | pat::Pattern <- instanceList fSpec - , rul <- Set.elems $ multrules pat + , rul <- Set.elems $ multrules pat ] ) ,("name" , "Concept" , "ConceptName" - , Set.fromList - [(dirtyId cpt,(PopAlphaNumeric . name) cpt) + , Set.fromList [Uni] + , [ (dirtyId cpt, (PopAlphaNumeric . name) cpt) | cpt::A_Concept <- instanceList fSpec ] ) ,("name" , "Context" , "ContextName" - , Set.fromList - [(dirtyId ctx,(PopAlphaNumeric . name) ctx) + , Set.fromList [Uni,Tot] + , [ (dirtyId ctx, (PopAlphaNumeric . name) ctx) | ctx::A_Context <- instanceList fSpec ] ) - ,("name" , "Interface" , "InterfaceName" - , Set.fromList - [(dirtyId ifc,(PopAlphaNumeric . name) ifc) + ,("name" , "Interface" , "InterfaceName" + , Set.fromList [Uni,Tot] + , [ (dirtyId ifc, (PopAlphaNumeric . name) ifc) | ifc::Interface <- instanceList fSpec ] ) - ,("name" , "ObjectDef" , "ObjectName" - , Set.fromList - [(dirtyId obj, (PopAlphaNumeric . name) obj) + ,("name" , "ObjectDef" , "ObjectName" + , Set.fromList [Uni,Tot] + , [ (dirtyId obj, (PopAlphaNumeric . name) obj) | obj::ObjectDef <- instanceList fSpec ] ) ,("name" , "Pattern" , "PatternName" - , Set.fromList - [(dirtyId pat,(PopAlphaNumeric . name) pat) + , Set.fromList [Uni,Tot] + , [ (dirtyId pat,(PopAlphaNumeric . name) pat) | pat::Pattern <- instanceList fSpec ] ) ,("name" , "Relation" , "RelationName" - , Set.fromList - [(dirtyId rel,(PopAlphaNumeric . name) rel) + , Set.fromList [Uni,Tot] + , [ (dirtyId rel,(PopAlphaNumeric . name) rel) | rel::Relation <- instanceList fSpec ] ) ,("name" , "Role" , "RoleName" - , Set.fromList - [(dirtyId rol,(PopAlphaNumeric . name) rol) + , Set.fromList [Uni] + , [ (dirtyId rol,(PopAlphaNumeric . name) rol) | rol::Role <- instanceList fSpec ] ) ,("name" , "Rule" , "RuleName" - , Set.fromList - [(dirtyId rul,(PopAlphaNumeric . name) rul) + , Set.fromList [Uni,Tot] + , [ (dirtyId rul,(PopAlphaNumeric . name) rul) | rul::Rule <- instanceList fSpec ] ) - ,("objExpression" , "ObjectDef" , "Expression" - , Set.fromList - [(dirtyId obj, dirtyId (objExpression obj)) - | obj::ObjectDef <- instanceList fSpec + ,("name" , "ViewDef" , "ViewDefName" + , Set.fromList [Uni,Tot] + , [ (dirtyId vd, PopAlphaNumeric . tshow . name $ vd) + | vd::ViewDef <- instanceList fSpec ] ) - ,("objmView" , "ObjectDef" , "View" - , Set.empty --TODO + ,("objView" , "ObjectDef" , "View" + , Set.empty + , [ (dirtyId obj, PopAlphaNumeric vw) + | obj::ObjectDef <- instanceList fSpec + , Just vw <- [objmView obj] + ] ) - ,("objpos" , "ObjectDef" , "Origin" - , Set.fromList - [(dirtyId obj, PopAlphaNumeric . tshow . origin $ obj) + ,("objpos" , "ObjectDef" , "Origin" + , Set.fromList [Uni] + , [ (dirtyId obj, PopAlphaNumeric . tshow . origin $ obj) | obj::ObjectDef <- instanceList fSpec + , origin obj `notElem` [OriginUnknown, MeatGrinder] ] ) ,("operator" , "BinaryTerm" , "Operator" - , Set.fromList - [(dirtyId expr, PopAlphaNumeric . tshow $ op) + , Set.fromList [Uni,Tot] + , [ (dirtyId expr, PopAlphaNumeric . tshow $ op) | expr::Expression <- instanceList fSpec , Just op <- [binOp expr] ] ) ,("operator" , "UnaryTerm" , "Operator" - , Set.fromList - [(dirtyId expr, PopAlphaNumeric . tshow $ op) + , Set.fromList [Uni,Tot] + , [ (dirtyId expr, PopAlphaNumeric . tshow $ op) | expr::Expression <- instanceList fSpec , Just op <- [unaryOp expr] ] ) - ,("origin" , "Rule" , "Origin" - , Set.fromList - [(dirtyId rul, (PopAlphaNumeric . tshow . origin) rul) + ,("origin" , "Rule" , "Origin" + , Set.fromList [Uni] + , [ (dirtyId rul, PopAlphaNumeric . tshow . origin $ rul) | rul::Rule <- instanceList fSpec + , origin rul `notElem` [OriginUnknown, MeatGrinder] ] ) - ,("originatesFrom" , "Conjunct" , "Rule" - , Set.fromList - [(dirtyId conj, dirtyId rul) - | conj::Conjunct <- instanceList fSpec - , rul <- NE.toList $ rc_orgRules conj - ] - ) - ,("outQ" , "Quad" , "Act" - , Set.empty --TODO - ) ,("pairView" , "Rule" , "PairView" - , Set.empty --TODO + , Set.empty + , [] --TODO ) ,("prop" , "Relation" , "Property" - , Set.fromList - [(dirtyId rel, PopAlphaNumeric . tshow $ prop) + , Set.empty + , [ (dirtyId rel, PopAlphaNumeric . tshow $ prop) | rel::Relation <- instanceList fSpec , prop <- Set.elems $ decprps rel ] ) - ,("propertyRule" , "Relation" , "PropertyRule" - , Set.fromList - [(dirtyId rel, dirtyId rul) - | rul::Rule <- instanceList fSpec - , Just(_,rel) <- [rrdcl rul] - ] - ) - ,("purpose" , "Concept" , "Purpose" - , Set.fromList - [(dirtyId cpt, dirtyId purp) + ,("purpose" , "Concept" , "Purpose" + , Set.empty + , [ (dirtyId cpt, dirtyId purp) | cpt::A_Concept <- instanceList fSpec , purp <- purposes fSpec cpt ] ) - ,("purpose" , "Context" , "Purpose" - , Set.fromList - [(dirtyId ctx, dirtyId purp) + ,("purpose" , "Context" , "Purpose" + , Set.empty + , [ (dirtyId ctx, dirtyId purp) | ctx::A_Context <- instanceList fSpec , purp <- purposes fSpec ctx ] ) - ,("purpose" , "Identity" , "Purpose" - , Set.fromList - [(dirtyId idn, dirtyId purp) - | idn::IdentityDef <- instanceList fSpec + ,("purpose" , "IdentityRule" , "Purpose" + , Set.empty + , [ (dirtyId idn, dirtyId purp) + | idn::IdentityRule <- instanceList fSpec , purp <- purposes fSpec idn ] ) - ,("purpose" , "Interface" , "Purpose" - , Set.fromList - [(dirtyId ifc, dirtyId purp) + ,("purpose" , "Interface" , "Purpose" + , Set.empty + , [ (dirtyId ifc, dirtyId purp) | ifc::Interface <- instanceList fSpec , purp <- purposes fSpec ifc ] ) - ,("purpose" , "Pattern" , "Purpose" - , Set.fromList - [(dirtyId pat, dirtyId purp) + ,("purpose" , "Pattern" , "Purpose" + , Set.empty + , [ (dirtyId pat, dirtyId purp) | pat::Pattern <- instanceList fSpec , purp <- purposes fSpec pat ] ) - ,("purpose" , "Relation" , "Purpose" - , Set.fromList - [(dirtyId rel, dirtyId purp) + ,("purpose" , "Relation" , "Purpose" + , Set.empty + , [ (dirtyId rel, dirtyId purp) | rel::Relation <- instanceList fSpec , purp <- purposes fSpec rel ] ) - ,("purpose" , "Rule" , "Purpose" - , Set.fromList - [(dirtyId rul, dirtyId purp) + ,("purpose" , "Rule" , "Purpose" + , Set.empty + , [ (dirtyId rul, dirtyId purp) | rul::Rule <- instanceList fSpec , purp <- purposes fSpec rul ] ) - ,("purpose" , "View" , "Purpose" - , Set.fromList - [(dirtyId vw, dirtyId purp) + ,("purpose" , "View" , "Purpose" + , Set.empty + , [ (dirtyId vw, dirtyId purp) | vw::ViewDef <- instanceList fSpec , purp <- purposes fSpec vw ] ) + ,("qConjuncts" , "Quad" , "Conjunct" + , Set.empty + , [ (dirtyId quad, dirtyId conj) + | quad <- vquads fSpec + , conj <- NE.toList (qConjuncts quad) + ] --TODO + ) + ,("qDcl" , "Quad" , "Relation" + , Set.fromList [Uni,Tot] + , [ (dirtyId quad, dirtyId (qDcl quad)) + | quad <- vquads fSpec + ] --TODO + ) + ,("qRule" , "Quad" , "Rule" + , Set.fromList [Uni,Tot] + , [ (dirtyId quad, dirtyId (qRule quad)) + | quad <- vquads fSpec + ] --TODO + ) + ,("rc_orgRules" , "Conjunct" , "Rule" + , Set.empty + , [ (dirtyId conj, dirtyId rul) + | conj::Conjunct <- instanceList fSpec + , rul <- NE.toList $ rc_orgRules conj + ] + ) ,("relsDefdIn" , "Pattern" , "Relation" - , Set.fromList - [(dirtyId pat, dirtyId rel) + , Set.empty + , [ (dirtyId pat, dirtyId rel) | pat::Pattern <- instanceList fSpec , rel <- Set.elems $ relsDefdIn pat ] ) - ,("right" , "Pair" , "Atom" - , Set.empty --This goes too deep. Keep it empty. - ) - ,("second" , "BinaryTerm" , "Expression" - , Set.fromList - [(dirtyId expr, dirtyId x) + ,("second" , "BinaryTerm" , "Term" + , Set.fromList [Uni,Tot] + , [ (dirtyId expr, dirtyId x) | expr::Expression <- instanceList fSpec , Just x <- [second expr] ] ) - ,("segment" , "PairView" , "PairViewSegment" - , Set.empty --TODO + ,("segment" , "PairView" , "PairViewSegment" + , Set.empty + , [] --TODO ) ,("segmentType" , "PairViewSegment" , "PairViewSegmentType" - , Set.empty --TODO + , Set.empty + , [] --TODO ) - ,("sequenceNr" , "PairViewSegment" , "Int" - , Set.empty --TODO + ,("sequenceNr" , "PairViewSegment" , "Int" + , Set.empty + , [] --TODO ) - ,("sessAtom" , "SESSION" , "Atom" - , Set.empty --This goes too deep. Keep it empty. + ,("sessAtom" , "SESSION" , "Atom" + , Set.empty + , [] -- This goes too deep. Keep it empty. ) ,("sessIfc" , "SESSION" , "Interface" - , Set.empty --TODO + , Set.empty + , [] --TODO ) - ,("sessionRole" , "SESSION" , "Role" - , Set.empty --TODO + ,("sessionRole" , "SESSION" , "Role" + , Set.empty + , [] --TODO ) - ,("showADL" , "Expression" , "ShowADL" - , Set.fromList - [(dirtyId expr, PopAlphaNumeric (showA expr)) + ,("showADL" , "Term" , "ShowADL" + , Set.fromList [Uni,Tot] + , [ (dirtyId expr, PopAlphaNumeric (showA expr)) | expr::Expression <- instanceList fSpec ] ) - ,("sign" , "Expression" , "Signature" - , Set.fromList - [(dirtyId expr, dirtyId (sign expr)) + ,("sign" , "Term" , "Signature" + , Set.fromList [Uni,Tot] + , [ (dirtyId expr, dirtyId (sign expr)) | expr::Expression <- instanceList fSpec ] ) ,("sign" , "Relation" , "Signature" - , Set.fromList - [(dirtyId rel, dirtyId (sign rel)) + , Set.fromList [Uni,Tot] + , [ (dirtyId rel, dirtyId (sign rel)) | rel::Relation <- instanceList fSpec ] ) ,("singleton" , "Singleton" , "AtomValue" - , Set.fromList - [(dirtyId expr, dirtyId x) + , Set.fromList [Uni,Tot] + , [ (dirtyId expr, dirtyId x) | expr::Expression <- instanceList fSpec , Just x <- [singleton expr] ] ) - ,("source" , "Relation" , "Concept" - , Set.fromList - [(dirtyId rel, dirtyId (source rel)) + ,("source" , "Relation" , "Concept" + , Set.fromList [Uni,Tot] + , [ (dirtyId rel, dirtyId (source rel)) | rel::Relation <- instanceList fSpec ] ) - ,("src" , "Signature" , "Concept" - , Set.fromList - [(dirtyId sgn, dirtyId (source sgn)) + ,("src" , "Signature" , "Concept" + , Set.fromList [Uni,Tot] + , [ (dirtyId sgn, dirtyId (source sgn)) | sgn::Signature <- instanceList fSpec ] ) ,("srcOrTgt" , "PairViewSegment" , "SourceOrTarget" - , Set.empty --TODO + , Set.fromList [Uni,Tot] + , [] --TODO ) - ,("target" , "Relation" , "Concept" - , Set.fromList - [(dirtyId rel, dirtyId (target rel)) + ,("target" , "Relation" , "Concept" + , Set.fromList [Uni,Tot] + , [ (dirtyId rel, dirtyId (target rel)) | rel::Relation <- instanceList fSpec ] ) - ,("text" , "PairViewSegment" , "String" - , Set.empty --TODO + ,("text" , "PairViewSegment" , "String" + , Set.fromList [Uni,Tot] + , [] --TODO ) - ,("tgt" , "Signature" , "Concept" - , Set.fromList - [(dirtyId sgn, dirtyId (target sgn)) + ,("tgt" , "Signature" , "Concept" + , Set.fromList [Uni,Tot] + , [ (dirtyId sgn, dirtyId (target sgn)) | sgn::Signature <- instanceList fSpec ] ) - ,("transactionObject" , "Transaction" , "Object" - , Set.empty --TODO - ) - ,("ttype" , "Concept" , "TType" - , Set.fromList - [(dirtyId cpt, (PopAlphaNumeric . tshow . cptTType fSpec) cpt) + ,("ttype" , "Concept" , "TType" + , Set.fromList [Uni] + , [ (dirtyId cpt, PopAlphaNumeric . tshow . cptTType fSpec $ cpt) | cpt::A_Concept <- instanceList fSpec ] ) - ,("udefrules" , "Rule" , "Context" - , Set.fromList - [(dirtyId rul, dirtyId ctx) + ,("udefrules" , "Rule" , "Context" + , Set.fromList [Uni] + , [ (dirtyId rul, dirtyId ctx) | ctx::A_Context <- instanceList fSpec , rul <- Set.elems $ udefrules ctx ] ) - ,("udefrules" , "Rule" , "Pattern" - , Set.fromList - [(dirtyId rul, dirtyId pat) + ,("udefrules" , "Rule" , "Pattern" + , Set.fromList [Uni] + , [ (dirtyId rul, dirtyId pat) | pat::Pattern <- instanceList fSpec , rul <- Set.elems $ udefrules pat ] ) ,("urlEncodedName" , "Concept" , "EncodedName" - , Set.fromList - [(dirtyId cpt,(PopAlphaNumeric . urlEncodedName . name) cpt) + , Set.fromList [Uni] + , [ (dirtyId cpt, PopAlphaNumeric . urlEncodedName . name $ cpt) | cpt::A_Concept <- instanceList fSpec ] ) ,("urlEncodedName" , "Pattern" , "EncodedName" - , Set.fromList - [(dirtyId pat,(PopAlphaNumeric . urlEncodedName . name) pat) + , Set.fromList [Uni] + , [ (dirtyId pat, PopAlphaNumeric . urlEncodedName . name $ pat) | pat::Pattern <- instanceList fSpec ] ) ,("urlEncodedName" , "Rule" , "EncodedName" - , Set.fromList - [(dirtyId rul,(PopAlphaNumeric . urlEncodedName . name) rul) + , Set.fromList [Uni] + , [ (dirtyId rul, PopAlphaNumeric . urlEncodedName . name $ rul) | rul::Rule <- instanceList fSpec ] ) - ,("usedIn" , "Relation" , "Expression" - , Set.fromList - [(dirtyId rel, dirtyId expr) + ,("usedIn" , "Relation" , "Term" + , Set.empty + , [ (dirtyId rel, dirtyId expr) | expr::Expression <- instanceList fSpec , rel::Relation <- Set.elems $ bindedRelationsIn expr ] ) - ,("userCpt" , "Epsilon" , "Concept" - , Set.fromList - [(dirtyId expr, dirtyId x) + ,("userCpt" , "Epsilon" , "Concept" + , Set.fromList [Uni,Tot] + , [ (dirtyId expr, dirtyId x) | expr::Expression <- instanceList fSpec , Just (x::A_Concept) <- [userCpt expr] ] ) - ,("userSrc" , "V" , "Concept" - , Set.fromList - [(dirtyId expr, dirtyId x) + ,("userSrc" , "V" , "Concept" + , Set.fromList [Uni,Tot] + , [ (dirtyId expr, dirtyId x) | expr::Expression <- instanceList fSpec , Just x <- [userSrc expr] ] ) - ,("userTrg" , "V" , "Concept" - , Set.fromList - [(dirtyId expr, dirtyId x) + ,("userTgt" , "V" , "Concept" + , Set.fromList [Uni,Tot] + , [ (dirtyId expr, dirtyId x) | expr::Expression <- instanceList fSpec - , Just x <- [userTrg expr] + , Just x <- [userTgt expr] ] ) - ,("uses" , "Context" , "Pattern" - , Set.empty --TODO + ,("vdats" , "ViewDef" , "ViewSegment" + , Set.fromList [Inj,Sur] + , [ (dirtyId vd, PopAlphaNumeric . tshow $ vs) + | vd::ViewDef <- instanceList fSpec + , vs <- vdats vd + ] ) - ,("valid" , "Concept" , "Context" - , Set.empty --TODO + ,("vdcpt" , "ViewDef" , "Concept" + , Set.fromList [Uni] + , [ (dirtyId vd, PopAlphaNumeric . tshow . vdcpt $ vd) + | vd::ViewDef <- instanceList fSpec, vdIsDefault vd + ] ) - ,("valid" , "Relation" , "Context" - , Set.empty --TODO + ,("vdhtml" , "ViewDef" , "Concept" + , Set.fromList [Uni] + , [ (dirtyId vd, PopAlphaNumeric . tshow $ html) + | vd::ViewDef <- instanceList fSpec + , Just html <- [vdhtml vd] + ] + ) + ,("vdIsDefault" , "ViewDef" , "Concept" + , Set.fromList [Uni,Tot] + , [ (dirtyId vd, PopAlphaNumeric . tshow . vdcpt $ vd) + | vd::ViewDef <- instanceList fSpec + ] ) - ,("valid" , "Rule" , "Context" - , Set.empty --TODO + ,("vdpos" , "ViewDef" , "Origin" + , Set.fromList [Uni] + , [ (dirtyId vd, PopAlphaNumeric . tshow . origin $ vd) + | vd::ViewDef <- instanceList fSpec + , origin vd `notElem` [OriginUnknown, MeatGrinder] + ] ) ,("versionInfo" , "Context" , "AmpersandVersion" - , Set.fromList - [(dirtyId ctx,PopAlphaNumeric (longVersion appVersion)) + , Set.fromList [Uni,Tot] + , [ (dirtyId ctx,PopAlphaNumeric (longVersion appVersion)) | ctx::A_Context <- instanceList fSpec ] ) - ,("viewBy" , "Concept" , "Concept" - , Set.empty --TODO + ,("viewBy" , "Concept" , "Concept" + , Set.empty + , [] --TODO ) - ,("viol" , "Interface" , "Rule" - , Set.empty --TODO + ,("violatable" , "Interface" , "Rule" + , Set.empty + , [] --TODO ) ] - - --- | The list of all transformers, one for each and every relation in PrototypeContext. +dirtyIdWithoutType :: Unique a => a -> PopAtom +dirtyIdWithoutType = DirtyId . idWithoutType + +-- | The following transformers provide the metamodel needed to run a prototype. +-- Note: The information in transformersPrototypeContext is fully contained in FormalAmpersand. +-- You might do this by dropping all prefixes "PF_" and "pf_" and doing +-- the following transformation: +-- label[Role*PF_Label] -> name[Role*RoleName] +-- Then you will see that the transformers defined here are a subset of the FormalAmpersand transformers. transformersPrototypeContext :: FSpec -> [Transformer] -transformersPrototypeContext fSpec = map toTransformer [ - ("ifc" , "PF_NavMenuItem" , "PF_Interface" - , Set.empty - ) - , ("isAPI" , "PF_Interface" , "PF_Interface" - , Set.fromList $ - [(dirtyIdWithoutType ifc, dirtyIdWithoutType ifc) +transformersPrototypeContext fSpec = map toTransformer +-- the following transformer is also contained in FormalAmpersand. + [ ("isAPI" , "PF_Interface" , "PF_Interface" + , Set.fromList [] + , [ (dirtyIdWithoutType ifc, dirtyIdWithoutType ifc) | ifc::Interface <- instanceList fSpec , ifcIsAPI ifc ] ) - , ("isPartOf" , "PF_NavMenuItem" , "PF_NavMenu" - , Set.empty - ) +-- the following transformer can be calculated by the Exec Engine. +-- it is also contained in FormalAmpersand. , ("isPublic" , "PF_Interface" , "PF_Interface" - , Set.fromList $ - [(dirtyIdWithoutType ifc, dirtyIdWithoutType ifc) + , Set.fromList [] + , [ (dirtyIdWithoutType ifc, dirtyIdWithoutType ifc) | ifc::Interface <- instanceList fSpec , null (ifcRoles ifc) ] ) - , ("isSubItemOf" , "PF_NavMenuItem" , "PF_NavMenuItem" - , Set.empty - ) - , ("isVisible" , "PF_NavMenuItem" , "PF_NavMenuItem" - , Set.empty - ) - , ("label" , "PF_Interface" , "PF_Label" - , Set.fromList $ - [(dirtyIdWithoutType ifc, PopAlphaNumeric . name $ ifc) +-- the following transformer is also contained in FormalAmpersand. + , ("label" , "PF_Interface" , "PF_Label" + , Set.fromList [] + , [ (dirtyIdWithoutType ifc, PopAlphaNumeric . name $ ifc) | ifc::Interface <- instanceList fSpec ] ) - , ("label" , "PF_NavMenuItem" , "PF_Label" - , Set.empty - ) +-- the following transformer is called name[Role*RoleName] in FormalAmpersand , ("label" , "Role" , "PF_Label" - , Set.fromList $ - [ (dirtyIdWithoutType role, PopAlphaNumeric . name $ role) + , Set.fromList [Uni] + , [ (dirtyIdWithoutType role, PopAlphaNumeric . name $ role) | role::Role <- instanceList fSpec ] ) - , ("lastAccess" , "SESSION" , "DateTime" - , Set.empty - ) +-- the following transformer is called ifcRoles[Interface*Role] in FormalAmpersand , ("pf_ifcRoles" , "PF_Interface" , "Role" - , Set.fromList $ - [(dirtyIdWithoutType ifc , dirtyIdWithoutType role) + , Set.fromList [] + , [ (dirtyIdWithoutType ifc , dirtyIdWithoutType role) | ifc::Interface <- instanceList fSpec , role <- ifcRoles ifc ] ) - , ("pf_navItemRoles" , "PF_NavMenuItem" , "Role" - , Set.empty - ) - , ("seqNr" , "PF_NavMenuItem" , "PF_SeqNr" - , Set.empty - ) - , ("sessionActiveRoles" , "SESSION" , "Role" - , Set.empty - ) - , ("sessionAllowedRoles" , "SESSION" , "Role" - , Set.empty - ) - , ("url" , "PF_NavMenuItem" , "PF_URL" - , Set.empty - ) ] - - -- | Within a specific context there are all kinds of things. -- These 'things' are instances (elements / atoms) of some -- Concept. They are the atoms of the concepts, as looked @@ -894,11 +925,11 @@ class Typeable a => Instances a where instances :: FSpec -> Set.Set a instanceList :: FSpec -> [a] instanceList = Set.toList . instances - {-# MINIMAL instances #-} + {-# MINIMAL instances #-} -- --WARNING: Beware of loops! -- To prevent loops in the definition of instances, it is considered bad --- to use the `instances` function while defining it. +-- to use the `instances` function while defining it. -- For this reason, some helper functions are defined here: expressionInstances :: FSpec -> Set.Set Expression expressionInstances = allExprs @@ -927,24 +958,26 @@ instance Instances Conjunct where instances = Set.fromList . allConjuncts instance Instances Expression where instances = expressionInstances -instance Instances IdentityDef where +instance Instances IdentityRule where instances = Set.fromList . ctxks . originalContext +instance Instances Rule where + instances = allRules . originalContext -- This contains all rules declared inside a context but outside the patterns it contains. instance Instances Interface where instances = interfaceInstances --instance Instances Meaning where -- instances = meaningInstances instance Instances Markup where - instances fSpec = (Set.fromList . map explMarkup . Set.toList . purposeInstances $ fSpec) + instances fSpec = (Set.fromList . map explMarkup . Set.toList . purposeInstances $ fSpec) `Set.union` (Set.fromList . map ameaMrk . Set.toList . meaningInstances $ fSpec) instance Instances ObjectDef where - instances fSpec = Set.fromList . concatMap (objects . ifcObj) + instances fSpec = Set.fromList . concatMap (objects . ifcObj) . interfaceInstances $ fSpec where objects :: ObjectDef -> [ObjectDef] objects obj = obj : fields obj instance Instances Pattern where - instances = Set.fromList . ctxpats . originalContext + instances = Set.fromList . vpatterns instance Instances Population where instances = Set.fromList . ctxpopus . originalContext instance Instances Purpose where @@ -955,21 +988,19 @@ instance Instances Role where instances = Set.fromList . map fst . fRoles instance Instances A_RoleRule where instances = Set.fromList . ctxrrules . originalContext -instance Instances Rule where - instances = ruleInstances instance Instances Signature where - instances fSpec = + instances fSpec = (Set.fromList . map sign . Set.toList . relationInstances $ fSpec) `Set.union` (Set.fromList . map sign . Set.toList . expressionInstances $ fSpec) instance Instances ViewDef where instances = Set.fromList . viewDefs . originalContext -class Instances a => HasPurpose a where +class Instances a => HasPurpose a where purposes :: FSpec -> a -> [Purpose] - purposes fSpec a = + purposes fSpec a = Set.toList . Set.filter (isFor a) . instances $ fSpec - isFor :: a -> Purpose -> Bool + isFor :: a -> Purpose -> Bool instance HasPurpose A_Concept where isFor cpt purp = case explObj purp of @@ -985,7 +1016,7 @@ instance HasPurpose Relation where case explObj purp of ExplRelation x -> rel == x _ -> False -instance HasPurpose IdentityDef where +instance HasPurpose IdentityRule where isFor idf purp = case explObj purp of ExplInterface x -> name idf == x @@ -1018,11 +1049,11 @@ data ExprInfo = ExprInfo , first' :: Maybe Expression , second' :: Maybe Expression , arg' :: Maybe Expression - , userCpt' :: Maybe A_Concept -- the concept of an Epsilon (and thus I too) expression - , userSrc' :: Maybe A_Concept -- the source concept of a V expression - , userTrg' :: Maybe A_Concept -- the target concept of a V expression - , singleton' :: Maybe PAtomValue -- the value of a singleton expression - } + , userCpt' :: Maybe A_Concept -- the concept of an Epsilon (and thus I too) Expression + , userSrc' :: Maybe A_Concept -- the source concept of a V Expression + , userTgt' :: Maybe A_Concept -- the target concept of a V Expression + , singleton' :: Maybe PAtomValue -- the value of a singleton Expression + } binOp :: Expression -> Maybe BinOp binOp = binOp' . exprInfo unaryOp :: Expression -> Maybe UnaryOp @@ -1039,8 +1070,8 @@ userCpt :: Expression -> Maybe A_Concept userCpt = userCpt' . exprInfo userSrc :: Expression -> Maybe A_Concept userSrc = userSrc' . exprInfo -userTrg :: Expression -> Maybe A_Concept -userTrg = userTrg' . exprInfo +userTgt :: Expression -> Maybe A_Concept +userTgt = userTgt' . exprInfo singleton :: Expression -> Maybe PAtomValue singleton = singleton' . exprInfo @@ -1056,7 +1087,7 @@ exprInfo expr = , arg' = Nothing , userCpt' = Nothing , userSrc' = Nothing - , userTrg' = Nothing + , userTgt' = Nothing , singleton' = Nothing } (EInc (l,r)) -> ExprInfo @@ -1068,7 +1099,7 @@ exprInfo expr = , arg' = Nothing , userCpt' = Nothing , userSrc' = Nothing - , userTrg' = Nothing + , userTgt' = Nothing , singleton' = Nothing } (EIsc (l,r)) -> ExprInfo @@ -1080,7 +1111,7 @@ exprInfo expr = , arg' = Nothing , userCpt' = Nothing , userSrc' = Nothing - , userTrg' = Nothing + , userTgt' = Nothing , singleton' = Nothing } (EUni (l,r)) -> ExprInfo @@ -1092,7 +1123,7 @@ exprInfo expr = , arg' = Nothing , userCpt' = Nothing , userSrc' = Nothing - , userTrg' = Nothing + , userTgt' = Nothing , singleton' = Nothing } (EDif (l,r)) -> ExprInfo @@ -1104,7 +1135,7 @@ exprInfo expr = , arg' = Nothing , userCpt' = Nothing , userSrc' = Nothing - , userTrg' = Nothing + , userTgt' = Nothing , singleton' = Nothing } (ELrs (l,r)) -> ExprInfo @@ -1116,7 +1147,7 @@ exprInfo expr = , arg' = Nothing , userCpt' = Nothing , userSrc' = Nothing - , userTrg' = Nothing + , userTgt' = Nothing , singleton' = Nothing } (ERrs (l,r)) -> ExprInfo @@ -1128,7 +1159,7 @@ exprInfo expr = , arg' = Nothing , userCpt' = Nothing , userSrc' = Nothing - , userTrg' = Nothing + , userTgt' = Nothing , singleton' = Nothing } (EDia (l,r)) -> ExprInfo @@ -1140,7 +1171,7 @@ exprInfo expr = , arg' = Nothing , userCpt' = Nothing , userSrc' = Nothing - , userTrg' = Nothing + , userTgt' = Nothing , singleton' = Nothing } (ECps (l,r)) -> ExprInfo @@ -1152,7 +1183,7 @@ exprInfo expr = , arg' = Nothing , userCpt' = Nothing , userSrc' = Nothing - , userTrg' = Nothing + , userTgt' = Nothing , singleton' = Nothing } (ERad (l,r)) -> ExprInfo @@ -1164,7 +1195,7 @@ exprInfo expr = , arg' = Nothing , userCpt' = Nothing , userSrc' = Nothing - , userTrg' = Nothing + , userTgt' = Nothing , singleton' = Nothing } (EPrd (l,r)) -> ExprInfo @@ -1176,7 +1207,7 @@ exprInfo expr = , arg' = Nothing , userCpt' = Nothing , userSrc' = Nothing - , userTrg' = Nothing + , userTgt' = Nothing , singleton' = Nothing } (EKl0 e) -> ExprInfo @@ -1188,7 +1219,7 @@ exprInfo expr = , arg' = Just e , userCpt' = Nothing , userSrc' = Nothing - , userTrg' = Nothing + , userTgt' = Nothing , singleton' = Nothing } (EKl1 e) -> ExprInfo @@ -1200,7 +1231,7 @@ exprInfo expr = , arg' = Just e , userCpt' = Nothing , userSrc' = Nothing - , userTrg' = Nothing + , userTgt' = Nothing , singleton' = Nothing } (EFlp e) -> ExprInfo @@ -1212,7 +1243,7 @@ exprInfo expr = , arg' = Just e , userCpt' = Nothing , userSrc' = Nothing - , userTrg' = Nothing + , userTgt' = Nothing , singleton' = Nothing } (ECpl e) -> ExprInfo @@ -1224,7 +1255,7 @@ exprInfo expr = , arg' = Just e , userCpt' = Nothing , userSrc' = Nothing - , userTrg' = Nothing + , userTgt' = Nothing , singleton' = Nothing } (EBrk e) -> ExprInfo @@ -1236,7 +1267,7 @@ exprInfo expr = , arg' = arg e , userCpt' = userCpt e , userSrc' = userSrc e - , userTrg' = userTrg e + , userTgt' = userTgt e , singleton' = singleton e } (EDcD r) -> ExprInfo @@ -1248,7 +1279,7 @@ exprInfo expr = , arg' = Nothing , userCpt' = Nothing , userSrc' = Nothing - , userTrg' = Nothing + , userTgt' = Nothing , singleton' = Nothing } (EDcI cpt) -> ExprInfo @@ -1260,7 +1291,7 @@ exprInfo expr = , arg' = Nothing , userCpt' = Just cpt , userSrc' = Nothing - , userTrg' = Nothing + , userTgt' = Nothing , singleton' = Nothing } (EEps cpt _) -> ExprInfo @@ -1272,7 +1303,7 @@ exprInfo expr = , arg' = Nothing , userCpt' = Just cpt , userSrc' = Nothing - , userTrg' = Nothing + , userTgt' = Nothing , singleton' = Nothing } (EDcV sgn) -> ExprInfo @@ -1284,7 +1315,7 @@ exprInfo expr = , arg' = Nothing , userCpt' = Nothing , userSrc' = Just (source sgn) - , userTrg' = Just (target sgn) + , userTgt' = Just (target sgn) , singleton' = Nothing } (EMp1 val _) -> ExprInfo @@ -1296,10 +1327,10 @@ exprInfo expr = , arg' = Nothing , userCpt' = Nothing , userSrc' = Nothing - , userTrg' = Nothing + , userTgt' = Nothing , singleton' = Just val } -data UnaryOp = +data UnaryOp = KleeneStar | KleenePlus | Converse @@ -1312,12 +1343,12 @@ data BinOp = CartesianProduct | Composition | Diamond | Difference - | Equivalence - | Inclusion - | Intersection + | Equivalence + | Inclusion + | Intersection | LeftResidu | RightResidu - | RelativeAddition + | RelativeAddition | Union deriving (Eq, Show, Typeable) instance Unique BinOp where showUnique = tshow diff --git a/src/Ampersand/Graphic/ClassDiagram.hs b/src/Ampersand/Graphic/ClassDiagram.hs index ae803834fd..65f5a80bf6 100644 --- a/src/Ampersand/Graphic/ClassDiagram.hs +++ b/src/Ampersand/Graphic/ClassDiagram.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE OverloadedStrings #-} + module Ampersand.Graphic.ClassDiagram (ClassDiag(..), Class(..), CdAttribute(..), Association(..), Aggregation(..), Generalization(..), Deleting(..), Method(..), diff --git a/src/Ampersand/Graphic/Fspec2ClassDiagrams.hs b/src/Ampersand/Graphic/Fspec2ClassDiagrams.hs index 9deeb25ab1..49daaf8f49 100644 --- a/src/Ampersand/Graphic/Fspec2ClassDiagrams.hs +++ b/src/Ampersand/Graphic/Fspec2ClassDiagrams.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE OverloadedStrings #-} + module Ampersand.Graphic.Fspec2ClassDiagrams ( clAnalysis, cdAnalysis, tdAnalysis ) diff --git a/src/Ampersand/Graphic/Graphics.hs b/src/Ampersand/Graphic/Graphics.hs index 80eab95f1b..6e0ab61546 100644 --- a/src/Ampersand/Graphic/Graphics.hs +++ b/src/Ampersand/Graphic/Graphics.hs @@ -1,5 +1,5 @@ {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedStrings #-} + module Ampersand.Graphic.Graphics (makePicture, writePicture, Picture(..), PictureTyp(..), imagePathRelativeToDirOutput) where @@ -135,16 +135,17 @@ makePicture env fSpec pr = -- | pictureFileName is used in the filename of the picture. -- Each pictureFileName must be unique (within fSpec) to prevent overwriting newly created files. +-- File names are urlEncoded to cater for the entire alphabet. pictureFileName :: PictureTyp -> FilePath pictureFileName pr = toBaseFileName $ case pr of PTClassDiagram -> "Classification" PTLogicalDM -> "LogicalDataModel" PTTechnicalDM -> "TechnicalDataModel" - PTCDConcept cpt -> "CDConcept"<>name cpt - PTDeclaredInPat pat -> "RelationsInPattern"<>name pat - PTCDPattern pat -> "CDPattern"<>name pat - PTCDRule r -> "CDRule"<>name r + PTCDConcept cpt -> "CDConcept"<>urlEncodedName (name cpt) + PTDeclaredInPat pat -> "RelationsInPattern"<>urlEncodedName (name pat) + PTCDPattern pat -> "CDPattern"<>urlEncodedName (name pat) + PTCDRule r -> "CDRule"<>urlEncodedName (name r) -- | conceptualStructure produces a uniform structure, -- so the transformation to .dot-format can be done with one function. diff --git a/src/Ampersand/Input/ADL1/CtxError.hs b/src/Ampersand/Input/ADL1/CtxError.hs index 34470a44f1..990b6d61d4 100644 --- a/src/Ampersand/Input/ADL1/CtxError.hs +++ b/src/Ampersand/Input/ADL1/CtxError.hs @@ -1,7 +1,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE OverloadedStrings #-} + module Ampersand.Input.ADL1.CtxError ( CtxError(PE) , Warning diff --git a/src/Ampersand/Input/ADL1/FilePos.hs b/src/Ampersand/Input/ADL1/FilePos.hs index 234bacfee0..b0d96e098b 100644 --- a/src/Ampersand/Input/ADL1/FilePos.hs +++ b/src/Ampersand/Input/ADL1/FilePos.hs @@ -1,6 +1,6 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} + module Ampersand.Input.ADL1.FilePos ( FilePos(..), Origin(..), Traced(..), isFuzzyOrigin, maybeOrdering, sortWithOrigins, @@ -58,7 +58,7 @@ data Origin = OriginUnknown | FileLoc FilePos SymbolName | XLSXLoc FilePath Text (Int,Int) | MeatGrinder -- Constructor is used to specify stuff that originates from meatgrinder - deriving (Typeable, Generic, Data) + deriving (Eq,Typeable, Generic, Data) -- Eq and Ord have been removed by desing on Origin. See issue #1035 -- | A fuzzy origin has a constructor that breaks tracability. They should be used as little as possible. isFuzzyOrigin :: Origin -> Bool diff --git a/src/Ampersand/Input/ADL1/Lexer.hs b/src/Ampersand/Input/ADL1/Lexer.hs index 4709720d75..49a912dd40 100644 --- a/src/Ampersand/Input/ADL1/Lexer.hs +++ b/src/Ampersand/Input/ADL1/Lexer.hs @@ -1,5 +1,5 @@ {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE OverloadedStrings #-} + module Ampersand.Input.ADL1.Lexer ( keywords , operators diff --git a/src/Ampersand/Input/ADL1/Parser.hs b/src/Ampersand/Input/ADL1/Parser.hs index c3a23976af..41c6246c67 100644 --- a/src/Ampersand/Input/ADL1/Parser.hs +++ b/src/Ampersand/Input/ADL1/Parser.hs @@ -1,6 +1,6 @@ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} + module Ampersand.Input.ADL1.Parser ( AmpParser , Include(..) @@ -59,7 +59,7 @@ pContext = rebuild <$> posOf (pKey "CONTEXT") , [s | CIncl s<-ces] -- the INCLUDE filenames ) - --- ContextElement ::= Meta | PatternDef | ProcessDef | RuleDef | Classify | RelationDef | ConceptDef | Index | ViewDef | Interface | Sqlplug | Phpplug | Purpose | Population | PrintThemes | IncludeStatement + --- ContextElement ::= MetaData | PatternDef | ProcessDef | RuleDef | Classify | RelationDef | ConceptDef | Index | ViewDef | Interface | Sqlplug | Phpplug | Purpose | Population | PrintThemes | IncludeStatement pContextElement :: AmpParser ContextElement pContextElement = CMeta <$> pMeta <|> CPat <$> pPatternDef <|> @@ -77,7 +77,7 @@ pContext = rebuild <$> posOf (pKey "CONTEXT") CPop <$> pPopulation <|> CIncl <$> pIncludeStatement -data ContextElement = CMeta Meta +data ContextElement = CMeta MetaData | CPat P_Pattern | CRul (P_Rule TermPrim) | CCfy [PClassify] @@ -114,9 +114,9 @@ pTextMarkup = ReST <$ pKey "REST" <|> LaTeX <$ pKey "LATEX" <|> Markdown <$ pKey "MARKDOWN" ---- Meta ::= 'META' Text Text -pMeta :: AmpParser Meta -pMeta = Meta <$> currPos <* pKey "META" <*> asText pDoubleQuotedString <*> asText pDoubleQuotedString +--- MetaData ::= 'META' Text Text +pMeta :: AmpParser MetaData +pMeta = MetaData <$> currPos <* pKey "META" <*> asText pDoubleQuotedString <*> asText pDoubleQuotedString --- PatternDef ::= 'PATTERN' ConceptName PatElem* 'ENDPATTERN' pPatternDef :: AmpParser P_Pattern diff --git a/src/Ampersand/Input/ADL1/ParsingLib.hs b/src/Ampersand/Input/ADL1/ParsingLib.hs index 8971a3c265..cf14ac10e7 100644 --- a/src/Ampersand/Input/ADL1/ParsingLib.hs +++ b/src/Ampersand/Input/ADL1/ParsingLib.hs @@ -156,7 +156,7 @@ pCrudString = check (\case testCrud s = if and $ [ not (null s) , L.nub caps == caps - ] ++ map (`elem` "CRUD") caps + ] ++ map (`elem` ['C','R','U','D'] ) caps then Just s else Nothing where caps = map toUpper s diff --git a/src/Ampersand/Input/Parsing.hs b/src/Ampersand/Input/Parsing.hs index a56cef2d17..4a79d3fb28 100644 --- a/src/Ampersand/Input/Parsing.hs +++ b/src/Ampersand/Input/Parsing.hs @@ -1,11 +1,11 @@ -{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TupleSections #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE OverloadedStrings #-} + -- This module provides an interface to be able to parse a script and to -- return an FSpec, as tuned by the command line options. -- This might include that RAP is included in the returned FSpec. module Ampersand.Input.Parsing ( - parseFileTransitive + parseFilesTransitive , parseFormalAmpersand , parsePrototypeContext , parseRule @@ -13,36 +13,62 @@ module Ampersand.Input.Parsing ( , ParseCandidate(..) -- exported for use with --daemon ) where -import Ampersand.ADL1 -import Ampersand.Basics -import Ampersand.Core.ShowPStruct -import Ampersand.Input.ADL1.CtxError +import Ampersand.ADL1 + ( Origin(Origin), mergeContexts, P_Context, Term, TermPrim ) +import Ampersand.Basics +import Ampersand.Core.ShowPStruct ( showP ) +import Ampersand.Input.ADL1.CtxError + ( addWarnings, + lexerError2CtxError, + lexerWarning2Warning, + mkErrorReadingINCLUDE, + whenCheckedM, + CtxError(PE), + Guarded(..) ) import Ampersand.Input.ADL1.Lexer ( initPos, Token(tokPos), lexer ) -import Ampersand.Input.ADL1.Parser -import Ampersand.Input.Archi.ArchiAnalyze -import Ampersand.Input.PreProcessor -import Ampersand.Input.Xslx.XLSX -import Ampersand.Misc.HasClasses -import Ampersand.Prototype.StaticFiles_Generated +import Ampersand.Input.ADL1.Parser + ( AmpParser, pContext, pRule, Include(..) ) +import Ampersand.Input.Archi.ArchiAnalyze ( archi2PContext ) +import Ampersand.Input.PreProcessor + ( preProcess, processFlags, PreProcDefine ) +import Ampersand.Input.Xslx.XLSX ( parseXlsxFile ) +import Ampersand.Misc.HasClasses ( HasFSpecGenOpts,Roots(..) ) +import Ampersand.Prototype.StaticFiles_Generated + ( getStaticFileContent, + FileKind(PrototypeContext, FormalAmpersand) ) import RIO.Char(toLower) import qualified RIO.List as L import qualified RIO.Set as Set import qualified RIO.Text as T -import System.Directory -import System.FilePath +import System.Directory + ( canonicalizePath, doesFileExist, getCurrentDirectory ) +import System.FilePath + ( takeDirectory, + (), + equalFilePath, + joinDrive, + joinPath, + normalise, + pathSeparators, + splitDrive, + splitPath, + takeExtension ) import Text.Parsec.Prim (runP) - - --- | Parse an Ampersand file and all transitive includes -parseFileTransitive :: (HasFSpecGenOpts env, HasLogFunc env) => - FilePath -- ^ The path of the file to be parsed, either absolute or relative to the current user's path +-- | Parse Ampersand files and all transitive includes +parseFilesTransitive :: (HasFSpecGenOpts env, HasLogFunc env) => + Roots -> RIO env ([ParseCandidate], Guarded P_Context) -- ^ A tuple containing a list of parsed files and the The resulting context -parseFileTransitive fp = do +parseFilesTransitive xs = do -- parseFileTransitive . NE.head . getRoots --TODO Fix this, to also take the tail files into account. curDir <- liftIO getCurrentDirectory - canonical <- liftIO $ canonicalizePath fp - parseThing' ParseCandidate - { pcBasePath = Just curDir + canonical <- liftIO . mapM canonicalizePath . getRoots $ xs + let candidates = map (mkCandidate curDir) canonical + + parseThings candidates + where + mkCandidate :: FilePath -> FilePath -> ParseCandidate + mkCandidate curdir canonical = ParseCandidate + { pcBasePath = Just curdir , pcOrigin = Nothing , pcFileKind = Nothing , pcCanonical = canonical @@ -68,14 +94,14 @@ parsePrototypeContext = parseThing ParseCandidate parseThing :: (HasFSpecGenOpts env, HasLogFunc env) => ParseCandidate -> RIO env (Guarded P_Context) -parseThing pc = snd <$> parseThing' pc +parseThing pc = snd <$> parseThings [pc] -parseThing' :: (HasFSpecGenOpts env, HasLogFunc env) => - ParseCandidate -> RIO env ([ParseCandidate], Guarded P_Context) -parseThing' pc = do - results <- parseADLs [] [pc] +parseThings :: (HasFSpecGenOpts env, HasLogFunc env) => + [ParseCandidate] -> RIO env ([ParseCandidate], Guarded P_Context) +parseThings pcs = do + results <- parseADLs [] pcs case results of - Errors err -> return ([pc], Errors err) + Errors err -> return (pcs, Errors err) Checked xs ws -> return ( candidates , Checked mergedContexts ws ) @@ -133,7 +159,7 @@ parseSingleADL pc | -- This feature enables the parsing of Excell files, that are prepared for Ampersand. extension == ".xlsx" = do popFromExcel <- catchInvalidXlsx $ parseXlsxFile (pcFileKind pc) filePath - return ((\pops -> (mkContextOfPopsOnly pops,[])) <$> popFromExcel) -- Excel file cannot contain include files + return ((,[]) <$> popFromExcel) -- An Excel file does not contain include files | -- This feature enables the parsing of Archimate models in ArchiMate® Model Exchange File Format extension == ".archimate" = do ctxFromArchi <- archi2PContext filePath -- e.g. "CA repository.xml" @@ -143,9 +169,7 @@ parseSingleADL pc writeFileUtf8 "ArchiMetaModel.adl" (showP ctx) logInfo "ArchiMetaModel.adl written" Errors _ -> pure () - return ((,) <$> ctxFromArchi - <*> pure [] -- ArchiMate file cannot contain include files - ) + return ((,[]) <$> ctxFromArchi) -- An Archimate file does not contain include files | otherwise = do mFileContents <- case pcFileKind pc of @@ -212,29 +236,6 @@ parseSingleADL pc where f :: SomeException -> RIO env a f exception = fatal ("The file does not seem to have a valid .xlsx structure:\n "<>tshow exception) --- | To enable roundtrip testing, all data can be exported. --- For this purpose mkContextOfPopsOnly exports the population only -mkContextOfPopsOnly :: [P_Population] -> P_Context -mkContextOfPopsOnly pops = - PCtx{ ctx_nm = "" - , ctx_pos = [] - , ctx_lang = Nothing - , ctx_markup = Nothing - , ctx_pats = [] - , ctx_rs = [] - , ctx_ds = [] - , ctx_cs = [] - , ctx_ks = [] - , ctx_rrules = [] - , ctx_reprs = [] - , ctx_vs = [] - , ctx_gs = [] - , ctx_ifcs = [] - , ctx_ps = [] - , ctx_pops = pops - , ctx_metas = [] - } - parse :: AmpParser a -> FilePath -> [Token] -> Guarded a parse p fn ts = -- runP :: Parsec s u a -> u -> FilePath -> s -> Either ParseError a diff --git a/src/Ampersand/Input/Xslx/XLSX.hs b/src/Ampersand/Input/Xslx/XLSX.hs index 363c315a58..367b1212b2 100644 --- a/src/Ampersand/Input/Xslx/XLSX.hs +++ b/src/Ampersand/Input/Xslx/XLSX.hs @@ -1,10 +1,11 @@ {-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE OverloadedStrings #-} + module Ampersand.Input.Xslx.XLSX (parseXlsxFile) where import Ampersand.Basics hiding (view, (^?), (^.)) import Ampersand.Core.ParseTree +import Ampersand.Core.ShowPStruct -- Just for debugging purposes import Ampersand.Input.ADL1.CtxError import Ampersand.Misc.HasClasses import Ampersand.Prototype.StaticFiles_Generated @@ -17,9 +18,11 @@ import qualified RIO.ByteString.Lazy as BL import RIO.Char import qualified RIO.Map as Map import qualified RIO.Text as T +import qualified RIO.NonEmpty as NE +import qualified RIO.Set as Set parseXlsxFile :: (HasFSpecGenOpts env) => - Maybe FileKind -> FilePath -> RIO env (Guarded [P_Population]) + Maybe FileKind -> FilePath -> RIO env (Guarded P_Context) parseXlsxFile mFk file = do env <- ask bytestr <- @@ -33,13 +36,161 @@ parseXlsxFile mFk file = return . xlsx2pContext env . toXlsx . BL.fromStrict $ bytestr where xlsx2pContext :: (HasFSpecGenOpts env) - => env -> Xlsx -> Guarded [P_Population] + => env -> Xlsx -> Guarded P_Context xlsx2pContext env xlsx = Checked pop [] where - pop = concatMap (toPops env file) + pop = mkContextOfPops + . concatMap (toPops env file) . concatMap theSheetCellsForTable $ (xlsx ^. xlSheets) +mkContextOfPops :: [P_Population] -> P_Context +mkContextOfPops pops = addRelations + PCtx{ ctx_nm = "" + , ctx_pos = [] + , ctx_lang = Nothing + , ctx_markup = Nothing + , ctx_pats = [] + , ctx_rs = [] + , ctx_ds = [] + , ctx_cs = [] + , ctx_ks = [] + , ctx_rrules = [] + , ctx_reprs = [] + , ctx_vs = [] + , ctx_gs = [] + , ctx_ifcs = [] + , ctx_ps = [] + , ctx_pops = pops + , ctx_metas = [] + } + +-- | addRelations is meant to enrich a population to a P_Context +-- The result of addRelations is a P_Context enriched with the relations in genericRelations +-- The population is reorganized in genericPopulations to accommodate the particular ISA-graph. +addRelations :: P_Context -> P_Context +addRelations pCtx = enrichedContext + where + enrichedContext :: P_Context + enrichedContext + = pCtx{ ctx_ds = mergeRels (genericRelations<>declaredRelations) + , ctx_pops = genericPopulations + } + declaredRelations :: [P_Relation] -- relations declared in the user's script + popRelations :: [P_Relation] -- relations that are "annotated" by the user in Excel-sheets. + -- popRelations are derived from P_Populations only. + declaredRelations = mergeRels (ctx_ds pCtx<>concatMap pt_dcs (ctx_pats pCtx)) + -- | To derive relations from populations, we derive the signature from the population's signature directly. + -- (SJ20210603: We do not add multiplicity properties because that might add violations that a user cannot fix.) + popRelations + = [ rel + | pop@P_RelPopu{p_src = src, p_tgt = tgt}<-ctx_pops pCtx<>[pop |pat<-ctx_pats pCtx, pop<-pt_pop pat] + , Just src'<-[src], Just tgt'<-[tgt] + , rel<-[ P_Relation{ dec_nm = name pop + , dec_sign = P_Sign src' tgt' + , dec_prps = mempty + , dec_pragma = mempty + , dec_Mean = mempty + , pos = origin pop + }] + , signatur rel `notElem` map signatur declaredRelations + ] + + genericRelations :: [P_Relation] -- generalization of popRelations due to CLASSIFY statements + genericPopulations :: [P_Population] -- generalization of popRelations due to CLASSIFY statements + -- | To derive relations from populations, we derive the signature from the population's signature directly. + -- Multiplicity properties are added to constrain the population without introducing violations. + (genericRelations, genericPopulations) + = recur [] popRelations pops invGen + where + recur :: [P_Concept]->[P_Relation]->[P_Population]->[(P_Concept,Set.Set P_Concept)]->([P_Relation], [P_Population]) + recur seen unseenrels unseenpops ((g,specs):invGens) + = if g `elem` seen then fatal ("Concept "<>name g<>" has caused a cycle error.") else + recur (g:seen) (genericRels<>remainder) (genericPops<>remainPop) invGens + where + sameNameTargetRels :: [NE.NonEmpty P_Relation] + sameNameTargetRels = eqCl (\r->(name r,targt r)) unseenrels + genericRels :: [P_Relation] + remainingRels :: [[P_Relation]] + (genericRels, remainingRels) + = 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]) + } -- 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 + ) + | sRel<-sameNameTargetRels + , specs `Set.isSubsetOf` (Set.fromList . NE.toList $ fmap sourc sRel) + , headrel<-[NE.head sRel] + ] + remainder :: [P_Relation] + remainder + = concat (remainingRels<>fmap NE.toList + [ sRel | sRel<-sameNameTargetRels + , not (specs `Set.isSubsetOf` (Set.fromList . NE.toList $ fmap sourc sRel))] + ) + sameNameTargetPops :: [NE.NonEmpty P_Population] + sameNameTargetPops = eqCl (\r->(name r,tgtPop r)) unseenpops + genericPops :: [P_Population] + remainingPops :: [[P_Population]] + (genericPops, remainingPops) + = L.unzip + [ ( headPop{p_src=Just g} -- the generic relation that summarizes sRel + -- , [ pop| pop<-sPop, srcPop pop `elem` specs ] -- the specific (and therefore obsolete) populations + , [ pop| pop<-NE.toList sPop, srcPop pop `notElem` specs ] -- the remaining relations + ) + | sPop<-sameNameTargetPops + , specs `Set.isSubsetOf` (Set.fromList . NE.toList $ fmap srcPop sPop) + , headPop@P_RelPopu{}<-[NE.head sPop] -- Restrict to @P_RelPopu{} because field name p_src is being used + ] + remainPop :: [P_Population] + remainPop + = concat (remainingPops<>fmap NE.toList + [ sPop | sPop<-sameNameTargetPops + , not (specs `Set.isSubsetOf` (Set.fromList . NE.toList $ fmap srcPop sPop))] + ) + recur _ rels popus [] = (rels,popus) + srcPop, tgtPop :: P_Population -> P_Concept -- get the source concept of a P_Population. + srcPop pop@P_CptPopu{} = PCpt (name pop) + srcPop pop@P_RelPopu{p_src = src} = case src of Just s -> s; _ -> fatal ("srcPop ("<>showP pop<>") is mistaken.") + tgtPop pop@P_CptPopu{} = PCpt (name pop) + tgtPop pop@P_RelPopu{p_tgt = tgt} = case tgt of Just t -> t; _ -> fatal ("tgtPop ("<>showP pop<>") is mistaken.") + + sourc, targt :: P_Relation -> P_Concept -- get the source concept of a P_Relation. + sourc = pSrc . dec_sign + targt = pTgt . dec_sign + invGen :: [(P_Concept,Set.Set P_Concept)] -- each pair contains a concept with all of its specializations + invGen = [ (fst (NE.head cl), Set.fromList spcs) + | cl<-eqCl fst [ (g,specific gen) | gen<-ctx_gs pCtx, g<-NE.toList (generics gen)] + , g<-[fst (NE.head cl)], spcs<-[[snd c | c<-NE.toList cl, snd c/=g]], not (null spcs) + ] + signatur :: P_Relation -> (Text, P_Sign) + signatur rel =(name rel, dec_sign rel) + concepts = L.nub $ + [ PCpt (name pop) | pop@P_CptPopu{}<-ctx_pops pCtx] <> + [ src' | P_RelPopu{p_src = src}<-ctx_pops pCtx, Just src'<-[src]] <> + [ tgt' | P_RelPopu{p_tgt = tgt}<-ctx_pops pCtx, Just tgt'<-[tgt]] <> + map sourc declaredRelations<> map targt declaredRelations<> + concat [specific gen: NE.toList (generics gen)| gen<-ctx_gs pCtx] + pops = computeConceptPopulations (ctx_pops pCtx<>[p |pat<-ctx_pats pCtx, p<-pt_pop pat]) -- All populations defined in this context, from POPULATION statements as well as from Relation declarations. + computeConceptPopulations :: [P_Population] -> [P_Population] + computeConceptPopulations pps -- I feel this computation should be done in P2A_Converters.hs, so every A_structure has compliant populations. + = [ P_CptPopu{pos = OriginUnknown, p_cpt = c, p_popas = L.nub $ + [ atom | cpt@P_CptPopu{}<-pps, PCpt (name cpt) == c, atom<-p_popas cpt]<> + [ ppLeft pair + | pop@P_RelPopu{p_src = src}<-pps, Just src'<-[src], src' == c + , pair<-p_popps pop]<> + [ ppRight pair + | pop@P_RelPopu{p_tgt = tgt}<-pps, Just tgt'<-[tgt], tgt' == c + , pair<-p_popps pop]} + | c<-concepts + ] <> + [ rpop{p_popps=concatMap p_popps cl} + | cl<-eqCl (\pop->(name pop,p_src pop,p_tgt pop)) [ pop | pop@P_RelPopu{}<-pps], rpop<-[NE.head cl] + ] + data SheetCellsForTable = Mapping{ theSheetName :: Text , theCellMap :: CellMap diff --git a/src/Ampersand/Misc/Commands.hs b/src/Ampersand/Misc/Commands.hs index 2989efef2f..cdc629236e 100644 --- a/src/Ampersand/Misc/Commands.hs +++ b/src/Ampersand/Misc/Commands.hs @@ -1,6 +1,6 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} + {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} module Ampersand.Misc.Commands @@ -96,11 +96,11 @@ commandLineHandler currentDir _progName args = complicatedOptions ( "Create an ADL model based on the content of a spreadsheet. The spreadsheet" <>"must comply to the specific format." <>"This is an experimental feature.") - dataAnalysisCmd + (mkAction exportAsAdl) (outputFileOptsParser "MetaModel.adl") addCommand'' Devoutput "Generate some diagnostic files, intended for developers of ampersand." - devoutputCmd + (mkAction devoutput) (devoutputOptsParser ".") addCommand'' Documentation ( "Generate a functional design document, to kick-start your " @@ -109,37 +109,37 @@ commandLineHandler currentDir _progName args = complicatedOptions docOptsParser -- addCommand'' Fpa -- "" --- fpaCmd +-- (mkAction fpa) -- fpaOptsParser -- addCommand'' Init -- "" --- initCmd +-- (mkAction init) -- initOptsParser addCommand'' Population "Generate a file that contains the population of your script." - populationCmd + (mkAction population) populationOptsParser addCommand'' Proofs "Generate a report containing proofs." - proofCmd + (mkAction proof) proofOptsParser addCommand'' Proto "Generate a prototype from your specification." - protoCmd + (mkAction proto) protoOptsParser addCommand'' Export "Generate a single .adl file of your script (prettyprinted)" - pprintCmd + (mkAction exportAsAdl) (outputFileOptsParser "export.adl") addCommand'' Uml "Generate a data model in UML 2.0 style." - umlCmd + (mkAction uml) umlOptsParser addCommand'' Validate ("Compare results of rule evaluation in Haskell and SQL, for" <> "testing expression semantics. This requires command line php with"<> "MySQL support.") - validateCmd + (mkAction validate) validateOptsParser addCommand'' Test ("Run testsuites in a given directory. This is meant to do regression testing" <> @@ -148,11 +148,15 @@ commandLineHandler currentDir _progName args = complicatedOptions (testOptsParser ".") where -- addCommand hiding global options - addCommand'' :: Command -> String -> (a -> RIO Runner ()) -> Parser a + addCommand'' :: HasOptions a => Command -> String -> (a -> RIO Runner ()) -> Parser a -> AddCommand - addCommand'' cmd title constr = - addCommand (map toLower . show $ cmd) title globalFooter constr (\_ gom -> gom) globalOpts - + addCommand'' cmd title constr parser = + addCommand (map toLower . show $ cmd) title globalFooter constr' (\_ gom -> gom) globalOpts parser + where constr' opts = do + runner <- ask + logDebug .display $ shortVersion appVersion <> " runs with the following settings:" + showOptions (runner,opts) + constr opts @@ -247,16 +251,11 @@ addCommand cmd title footerStr constr extendCommon = -- -- | Add a command that takes sub-commands to the options dispatcher. -- addSubCommands -- :: Monoid c --- => Text --- -- ^ command string --- -> Text --- -- ^ title of command --- -> Text --- -- ^ footer of command help --- -> Parser c --- -- ^ common parser --- -> ExceptT b (Writer (Mod CommandFields (b,c))) () --- -- ^ sub-commands (use 'addCommand') +-- => Text -- ^ command string +-- -> Text -- ^ title of command +-- -> Text -- ^ footer of command help +-- -> Parser c -- ^ common parser +-- -> ExceptT b (Writer (Mod CommandFields (b,c))) () -- ^ sub-commands (use 'addCommand') -- -> ExceptT b (Writer (Mod CommandFields (b,c))) () -- addSubCommands cmd title footerStr commonParser commandParser = -- addCommand' cmd @@ -279,6 +278,9 @@ addCommand' cmd title footerStr constr commonParser inner = (info (constr <$> inner <*> commonParser) (progDesc title <> footer footerStr)))) +-- | The Options parser type +--type OptParser a = (RIO Runner ()) (Writer (Mod CommandFields ((RIO Runner (),a))) () +-- P.ParsecT [Token] FilePos Identity a -- ^ The Parsec parser for a list of tokens with a file position. -- | Generate a complicated options parser. complicatedParser @@ -317,84 +319,41 @@ helpOption = daemonCmd :: DaemonOpts -> RIO Runner () daemonCmd daemonOpts = - extendWith daemonOpts - runDaemon + extendWith daemonOpts runDaemon + documentationCmd :: DocOpts -> RIO Runner () documentationCmd docOpts = do - extendWith docOpts . forceAllowInvariants $ mkAction False doGenDocument + (extendWith docOpts . forceAllowInvariants . doOrDie) doGenDocument where forceAllowInvariants :: HasFSpecGenOpts env => RIO env a -> RIO env a forceAllowInvariants env = local (set allowInvariantViolationsL True) env --- | Create a prototype based on the current script. -protoCmd :: ProtoOpts -> RIO Runner () -protoCmd protOpts = - extendWith protOpts $ do - env <- ask - let recipe = recipeBuilder True env - mFSpec <- createFspec recipe - doOrDie mFSpec proto testCmd :: TestOpts -> RIO Runner () testCmd testOpts = extendWith testOpts test -dataAnalysisCmd :: InputOutputOpts -> RIO Runner () -dataAnalysisCmd opts = - extendWith opts $ do - let recipe = script UserScript `andThen` EncloseInConstraints - mFSpec <- createFspec recipe - doOrDie mFSpec exportAsAdl -pprintCmd :: InputOutputOpts -> RIO Runner () -pprintCmd opts = - extendWith opts $ mkAction False exportAsAdl checkCmd :: FSpecGenOpts -> RIO Runner () -checkCmd opts = - extendWith opts $ mkAction False doNothing +checkCmd = mkAction doNothing where doNothing fSpec = do - logInfo $ "This script of "<>(display . name $ fSpec)<>" contains no type errors." -populationCmd :: PopulationOpts -> RIO Runner () -populationCmd opts = - extendWith opts $ mkAction False population - -proofCmd :: ProofOpts -> RIO Runner () -proofCmd opts = - extendWith opts $ mkAction False proof - ---initCmd :: InitOpts -> RIO Runner () ---initCmd opts = --- extendWith opts init - -umlCmd :: UmlOpts -> RIO Runner () -umlCmd opts = - extendWith opts $ mkAction False uml - -validateCmd :: ValidateOpts -> RIO Runner () -validateCmd opts = - extendWith opts $ mkAction True validate - -devoutputCmd :: DevOutputOpts -> RIO Runner () -devoutputCmd opts = - extendWith opts $ mkAction False devoutput - -doOrDie :: HasLogFunc env => Guarded a -> (a -> RIO env b) -> RIO env b -doOrDie gA act = - case gA of - Checked a ws -> do - showWarnings ws - act a - Errors err -> exitWith . NoValidFSpec . T.lines . T.intercalate (T.replicate 30 "=" <> "\n") - . NE.toList . fmap tshow $ err - where - showWarnings ws = mapM_ logWarn (fmap displayShow ws) - -mkAction :: (HasLogFunc a, HasFSpecGenOpts a) => Bool -> (FSpec -> RIO a b) -> RIO a b -mkAction isForPrototype theAction = do - env <- ask - let recipe = recipeBuilder isForPrototype env - mFSpec <- createFspec recipe - doOrDie mFSpec theAction - - + logInfo $ "This script of "<>display (name fSpec)<>" contains no type errors." + + +mkAction :: forall a . (HasFSpecGenOpts a) => + (FSpec -> RIO (ExtendedRunner a) ()) -> a -> RIO Runner () +mkAction theAction opts + = extendWith opts $ doOrDie theAction + +doOrDie :: (HasLogFunc env, HasFSpecGenOpts env) => + (FSpec -> RIO env b) -> RIO env b +doOrDie theAction = do + mFSpec <- createFspec + case mFSpec of + Checked a ws -> do + mapM_ (logWarn . displayShow) ws + theAction a + Errors err -> exitWith . NoValidFSpec + . T.lines . T.intercalate (T.replicate 30 "=" <> "\n") + . NE.toList . fmap tshow $ err data Command = Check @@ -421,26 +380,4 @@ instance Show Command where show Proto = "proto" show Test = "test" show Uml = "uml" - show Validate = "validate" --- | Generic way to specify the recipe to be used to generate an FSpec -recipeBuilder :: (HasFSpecGenOpts env) => Bool -> env -> BuildRecipe -recipeBuilder isForPrototype env = - (if isForPrototype then enablePrototype else id) $ - case view recipeNameL env of - Prototype -> enablePrototype (script UserScript) - Standard -> script UserScript - RAP -> script UserScript - `merge` - script (MetaScript FormalAmpersand) - AtlasPopulation -> script UserScript `andThen` Grind FormalAmpersand - AtlasComplete -> script (MetaScript FormalAmpersand) - `merge` - (script UserScript `andThen` Grind FormalAmpersand) - where - enablePrototype :: BuildRecipe -> BuildRecipe - enablePrototype x = three - where prototypeContext = script (MetaScript PrototypeContext) - one = x `merge` prototypeContext - two = one `andThen` Grind PrototypeContext - three = one `merge` two - \ No newline at end of file + show Validate = "validate" \ No newline at end of file diff --git a/src/Ampersand/Misc/HasClasses.hs b/src/Ampersand/Misc/HasClasses.hs index 7414c4dc40..2170f5f42c 100644 --- a/src/Ampersand/Misc/HasClasses.hs +++ b/src/Ampersand/Misc/HasClasses.hs @@ -1,5 +1,5 @@ {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedStrings #-} + {-# LANGUAGE UndecidableInstances #-} module Ampersand.Misc.HasClasses @@ -7,6 +7,21 @@ where import Ampersand.Basics import Ampersand.Misc.Defaults (defaultDirPrototype) import RIO.FilePath +import qualified RIO.List as L +import qualified RIO.Text as T + +class HasOptions a where + showOptions :: HasLogFunc env => a -> RIO env () + showOptions opts = mapM_ showOpt . L.sortOn fst . optsList $ opts + where showOpt :: HasLogFunc env => (Text,Text) -> RIO env () + showOpt (key,value) = + logDebug . display $ key <>" "<> value + optsList :: a -> [(Text,Text)] -- A tuple containing the 'key' and the value of the options. + {-# MINIMAL optsList #-} +instance (HasOptions a, HasOptions b) => HasOptions (a,b) where + optsList (a,b) = optsList a <> optsList b +--instance (HasOptions a, Foldable f, Functor f) => HasOptions (f a) where +-- optsList xs = concat . toList . fmap optsList $ xs class HasFSpecGenOpts a where fSpecGenOptsL :: Lens' a FSpecGenOpts @@ -20,8 +35,10 @@ class HasFSpecGenOpts a where defaultCrudL = fSpecGenOptsL . lens xdefaultCrud (\x y -> x { xdefaultCrud = y }) trimXLSXCellsL :: Lens' a Bool trimXLSXCellsL = fSpecGenOptsL . lens xtrimXLSXCells (\x y -> x { xtrimXLSXCells = y }) - recipeNameL :: Lens' a KnownRecipe - recipeNameL = fSpecGenOptsL . lens xrecipeName (\x y -> x { xrecipeName = y }) + recipeL :: Lens' a Recipe + recipeL = fSpecGenOptsL . lens xrecipe (\x y -> x { xrecipe = y }) + allowInvariantViolationsL :: Lens' a Bool + allowInvariantViolationsL = fSpecGenOptsL . lens xallowInvariantViolations (\x y -> x { xallowInvariantViolations = y }) instance HasFSpecGenOpts FSpecGenOpts where fSpecGenOptsL = id {-# INLINE fSpecGenOptsL #-} @@ -47,56 +64,59 @@ instance HasFSpecGenOpts ProtoOpts where class (HasRootFile a) => HasDirPrototype a where dirPrototypeL :: Lens' a (Maybe FilePath) getTemplateDir :: a -> FilePath - getTemplateDir x = + getTemplateDir x = getDirPrototype x "templates" getAppDir :: a -> FilePath getAppDir x = getDirPrototype x "public" "app" "project" getGenericsDir :: a -> FilePath - getGenericsDir x = - getDirPrototype x "generics" + getGenericsDir x = + getDirPrototype x "generics" + getMetamodelDir :: a -> FilePath + getMetamodelDir x = + getDirPrototype x "metamodel" getDirPrototype :: a -> FilePath getDirPrototype x = fromMaybe defaultDirPrototype . view dirPrototypeL $ x instance HasDirPrototype ProtoOpts where dirPrototypeL = lens xdirPrototype (\x y -> x { xdirPrototype = y }) -class HasAllowInvariantViolations a where - allowInvariantViolationsL :: Lens' a Bool -instance (HasFSpecGenOpts a) => HasAllowInvariantViolations a where - allowInvariantViolationsL = fSpecGenOptsL . lens xallowInvariantViolations (\x y -> x { xallowInvariantViolations = y }) class HasGenerateFrontend a where generateFrontendL :: Lens' a Bool instance HasGenerateFrontend ProtoOpts where generateFrontendL = lens xgenerateFrontend (\x y -> x { xgenerateFrontend = y }) - class HasGenerateBackend a where generateBackendL :: Lens' a Bool instance HasGenerateBackend ProtoOpts where generateBackendL = lens xgenerateBackend (\x y -> x { xgenerateBackend = y }) +class HasGenerateMetamodel a where + generateMetamodelL :: Lens' a Bool +instance HasGenerateMetamodel ProtoOpts where + generateMetamodelL = lens xgenerateMetamodel (\x y -> x { xgenerateMetamodel = y }) +-- | A type to denote the root file(s) to be parsed for the creation of an Fspec +newtype Roots = Roots {getRoots :: [FilePath] + -- ^ Normally this should be a non-empty list. However, the daemon command is an exception to + -- this. The command `ampersand daemon` expects no script name. The script name(s) will be + -- configured by means of the `.ampersand` configuration file. + } +instance Show Roots where + show = L.intercalate ", " . getRoots class HasRootFile a where - rootFileL :: Lens' a (Maybe FilePath) + rootFileL :: Lens' a Roots baseName :: a -> FilePath - baseName = - maybe - (fatal "Cannot determine the basename of the script that is being compiled") - takeBaseName - . view rootFileL + baseName x = case getRoots . view rootFileL $ x of + [] -> fatal "Cannot determine the basename of the script that is being compiled" + (h:_) -> takeBaseName h dirSource :: a -> FilePath -- the directory of the script that is being compiled - dirSource = - maybe - (fatal "Cannot determine the directory of the script that is being compiled") - takeDirectory - . view rootFileL -instance (HasFSpecGenOpts a) => HasRootFile a where + dirSource = takeDirectory . baseName + +instance HasFSpecGenOpts a => HasRootFile a where rootFileL = fSpecGenOptsL . lens xrootFile (\x y -> x { xrootFile = y }) class HasOutputLanguage a where languageL :: Lens' a (Maybe Lang) -- The language in which the user wants the documentation to be printed. instance HasOutputLanguage ProtoOpts where languageL = lens x1OutputLanguage (\x y -> x { x1OutputLanguage = y }) -instance HasOutputLanguage DaemonOpts where - languageL = lens x2OutputLanguage (\x y -> x { x2OutputLanguage = y }) instance HasOutputLanguage DocOpts where languageL = lens x3OutputLanguage (\x y -> x { x3OutputLanguage = y }) instance HasOutputLanguage UmlOpts where @@ -128,8 +148,10 @@ class HasOutputLanguage a => HasDocumentOpts a where fspecFormatL = documentOptsL . lens xfspecFormat (\x y -> x { xfspecFormat = y }) genLegalRefsL :: Lens' a Bool -- Generate a table of legal references in Natural Language chapter genLegalRefsL = documentOptsL . lens xgenLegalRefs (\x y -> x { xgenLegalRefs = y }) - genGraphicsL :: Lens' a Bool -- Generate graphics during generation of functional design document. + genGraphicsL :: Lens' a Bool -- Generate graphics. Useful for generating text and graphics separately. genGraphicsL = documentOptsL . lens xgenGraphics (\x y -> x { xgenGraphics = y }) + genTextL :: Lens' a Bool -- Generate text. Useful for generating text and graphics separately. + genTextL = documentOptsL . lens xgenText (\x y -> x { xgenText = y }) instance HasDocumentOpts DocOpts where documentOptsL = id @@ -137,7 +159,7 @@ instance HasDocumentOpts DocOpts where class HasBlackWhite a where blackWhiteL :: Lens' a Bool -- only use black/white in graphics instance HasBlackWhite DocOpts where - blackWhiteL = lens xblackWhite (\x y -> x { xblackWhite = y }) + blackWhiteL = lens xblackWhite (\x y -> x { xblackWhite = y }) class HasOutputFile a where outputfileL :: Lens' a FilePath @@ -145,8 +167,8 @@ instance HasOutputFile InputOutputOpts where outputfileL = lens x4outputFile (\x y -> x { x4outputFile = y }) class HasVersion a where - preVersionL :: Lens' a Text - postVersionL :: Lens' a Text + preVersionL :: Lens' a Text + postVersionL :: Lens' a Text class HasProtoOpts env where protoOptsL :: Lens' env ProtoOpts @@ -157,7 +179,7 @@ instance HasProtoOpts ProtoOpts where protoOptsL = id {-# INLINE protoOptsL #-} instance HasProtoOpts ValidateOpts where - protoOptsL = lens protoOpts (\x y -> x { protoOpts = y }) + protoOptsL = lens protoOpts (\x y -> x { protoOpts = y }) class HasDevoutputOpts env where devoutputOptsL :: Lens' env DevOutputOpts class HasInitOpts env where @@ -178,13 +200,20 @@ instance HasTestOpts TestOpts where -- | Options for @ampersand daemon@. data DaemonOpts = DaemonOpts - { x2OutputLanguage :: !(Maybe Lang) - , xdaemonConfig :: !FilePath + { xdaemonConfig :: !FilePath -- ^ The path (relative from current directory OR absolute) and filename of a file that contains the root file(s) to be watched by the daemon. , x2fSpecGenOpts :: !FSpecGenOpts , xshowWarnings :: !Bool -- ^ Enable/disable show of warnings (if any). } +instance HasOptions DaemonOpts where + optsList opts = + [ ("--daemonconfig", tshow $ xdaemonConfig opts) + ] <> + optsList (x2fSpecGenOpts opts) <> + [ ("--[no-]warnings", tshow $ xshowWarnings opts) + ] + class (HasFSpecGenOpts a) => HasDaemonOpts a where daemonOptsL :: Lens' a DaemonOpts daemonConfigL :: Lens' a FilePath @@ -194,32 +223,50 @@ instance HasDaemonOpts DaemonOpts where {-# INLINE daemonOptsL #-} -- | An enumeration type for building an FSpec in some common way -data KnownRecipe = - Standard -- ^ Plain way of building. No fancy stuff. - | Prototype -- ^ Userscript grinded with prototype metamodel - | RAP -- ^ Merge the metamodel of FormalAmpersand to your script - | AtlasComplete -- ^ A recipe to build an FSpec containing a selfcontained Atlas. - | AtlasPopulation -- ^ A recipe to build an FSpec as used by RAP, for the Atlas. +data Recipe = + Standard -- ^ Plain way of building. No fancy stuff. + | Grind -- ^ Generates population for an atlas. + -- It assumes that the database is fit to receive that population, as RAP does. + | Prototype -- ^ A recipe to build a prototyping environment. + | RAP -- ^ A recipe to build a Repository for Ampersand Projects (RAP) + -- The option 'RAP' generates a database that is fit to receive metamodels, so an Atlas is possible. + -- The 'makeAtlas' button in RAP uses the 'Grind' option to populate the metamodel. deriving (Show, Enum, Bounded) + data FSpecGenOpts = FSpecGenOpts - { xrootFile :: !(Maybe FilePath) --relative path. Must be set the first time it is read. + { xrootFile :: !Roots --relative paths. Must be set the first time it is read. , xsqlBinTables :: !Bool , xgenInterfaces :: !Bool -- , xnamespace :: !Text -- prefix database identifiers with this namespace, to isolate namespaces within the same database. , xdefaultCrud :: !(Bool,Bool,Bool,Bool) , xtrimXLSXCells :: !Bool - , xrecipeName :: !KnownRecipe - -- ^ Should leading and trailing spaces of text values in .XLSX files be ignored? + , xrecipe :: !Recipe + -- ^ Which recipe for generating code? , xallowInvariantViolations :: !Bool -- ^ Should invariant violations be ignored? } deriving Show +instance HasOptions FSpecGenOpts where + optsList opts = + [ ("AMPERSAND_SCRIPT", tshow $ xrootFile opts) + , ("--sql-bin-tables", tshow $ xsqlBinTables opts) + , ("--interfaces", tshow $ xgenInterfaces opts) + , ("--namespace", tshow $ xnamespace opts) + , ("--crud-defaults", let (c,r,u,d) = xdefaultCrud opts + f :: Bool -> Text -> Text + f b = (if b then T.toUpper else T.toLower) + in mconcat [f c "c", f r "r",f u "u",f d "d"] + ) + , ("--[no-]trim-cellvalues", tshow $ xtrimXLSXCells opts) + , ("--build-recipe", tshow $ xrecipe opts) + , ("--ignore-invariant-violations", tshow $ xallowInvariantViolations opts) + ] -data FSpecFormat = +data FSpecFormat = FPandoc | Fasciidoc | Fcontext | Fdocbook - | Fdocx + | Fdocx | Fhtml | Fman | Fmarkdown @@ -244,6 +291,11 @@ data InputOutputOpts = InputOutputOpts { x4fSpecGenOpts :: !FSpecGenOpts , x4outputFile :: !FilePath --relative path } +instance HasOptions InputOutputOpts where + optsList opts = + optsList (x4fSpecGenOpts opts) <> + [ ("OUTPUTDIRECTORY", tshow $ x4outputFile opts) + ] -- | Options for @ampersand proto@. data ProtoOpts = ProtoOpts @@ -256,7 +308,21 @@ data ProtoOpts = ProtoOpts , xzwolleVersion :: !FilePath , xgenerateFrontend :: !Bool , xgenerateBackend :: !Bool + , xgenerateMetamodel :: !Bool } deriving Show +instance HasOptions ProtoOpts where + optsList opts = + [ ("--force-reinstall-framework", tshow $ xforceReinstallFramework opts) + , ("--language", tshow $ x1OutputLanguage opts) + ] <> + optsList (x1fSpecGenOpts opts) <> + [ ("--proto-dir", maybe "" tshow $ xdirPrototype opts) + , ("--customizations", maybe "" (T.intercalate "; " . fmap T.pack) $ xdirCustomizations opts) + , ("--prototype-framework-version", tshow $ xzwolleVersion opts) + , ("--[no-]frontend", tshow $ xgenerateFrontend opts) + , ("--[no-]backend", tshow $ xgenerateBackend opts) + , ("--[no-]metamodel", tshow $ xgenerateMetamodel opts) + ] -- | Options for @ampersand documentation@. data DocOpts = DocOpts @@ -265,7 +331,9 @@ data DocOpts = DocOpts , xchapters :: ![Chapter] -- ^ a list containing all chapters that are required to be in the generated documentation , xgenGraphics :: !Bool - -- ^ enable/disable generation of graphics while generating documentation + -- ^ enable/disable generation of graphics. Used to generate text and graphics in separation. + , xgenText :: !Bool + -- ^ enable/disable generation of text. Used to generate text and graphics in separation. , xfspecFormat :: !FSpecFormat -- ^ the format of the documentation , x3fSpecGenOpts :: !FSpecGenOpts @@ -275,16 +343,38 @@ data DocOpts = DocOpts , xgenLegalRefs :: !Bool -- ^ enable/disable generation of legal references in the documentation } deriving Show +instance HasOptions DocOpts where + optsList opts = + [ ("--blackWhite", tshow $ xblackWhite opts) + ] <> + fmap chapters [minBound ..] <> + [ ("--[no-]graphics", tshow $ xgenGraphics opts) + , ("--[no-]text", tshow $ xgenText opts) + , ("--format", tshow $ xfspecFormat opts) + ] <> + optsList (x3fSpecGenOpts opts) <> + [ ("--language", tshow $ x3OutputLanguage opts) + , ("--[no-]legal-refs", tshow $ xgenLegalRefs opts) + ] + where + chapters :: Chapter -> (Text,Text) + chapters chp = ("--[no-]"<> tshow chp,tshow $ chp `elem` xchapters opts) data PopulationOutputFormat = - XLSX + XLSX | JSON deriving (Show, Enum, Bounded) -- | Options for @ampersand population@ data PopulationOpts = PopulationOpts { x5fSpecGenOpts :: !FSpecGenOpts -- ^ Options required to build the fSpec - , xoutputFormat :: !PopulationOutputFormat + , xoutputFormat :: !PopulationOutputFormat } deriving Show +instance HasOptions PopulationOpts where + optsList opts = + optsList (x5fSpecGenOpts opts) <> + [ ("--output-format", tshow $ xoutputFormat opts) + ] + instance HasPopulationOpts PopulationOpts where populationOptsL = id outputFormatL = populationOptsL . lens xoutputFormat (\x y -> x { xoutputFormat = y }) @@ -294,6 +384,10 @@ newtype ProofOpts = ProofOpts { x6fSpecGenOpts :: FSpecGenOpts -- ^ Options required to build the fSpec } deriving Show +instance HasOptions ProofOpts where + optsList opts = + optsList (x6fSpecGenOpts opts) + -- | Options for @ampersand init@ data InitOpts = InitOpts deriving Show @@ -304,24 +398,44 @@ data UmlOpts = UmlOpts , x4OutputLanguage :: !(Maybe Lang) -- ^ Language of the output document } deriving Show +instance HasOptions UmlOpts where + optsList opts = + optsList (x7fSpecGenOpts opts) <> + [ ("--language", tshow $ x4OutputLanguage opts) + ] + -- | Options for @ampersand validate@ newtype ValidateOpts = ValidateOpts { protoOpts :: ProtoOpts -- ^ Options required to build the fSpec } deriving Show +instance HasOptions ValidateOpts where + optsList opts = + optsList (protoOpts opts) + -- | Options for @ampersand devoutput@ data DevOutputOpts = DevOutputOpts { x8fSpecGenOpts :: !FSpecGenOpts -- ^ Options required to build the fSpec , x5outputFile :: !FilePath --relative path } deriving Show +instance HasOptions DevOutputOpts where + optsList opts = + optsList (x8fSpecGenOpts opts) <> + [ ("OUTPUTDIRECTORY", tshow $ x5outputFile opts) + ] + newtype TestOpts = TestOpts { rootTestDir :: FilePath --relative path to directory containing test scripts } deriving Show +instance HasOptions TestOpts where + optsList opts = + [ ("TESTDIRECTORY", tshow $ rootTestDir opts) + ] data Chapter = Intro | SharedLang | Diagnosis | ConceptualAnalysis | DataAnalysis - deriving (Eq, Show, Enum, Bounded) + deriving (Eq, Show, Enum, Bounded) diff --git a/src/Ampersand/Options/DaemonParser.hs b/src/Ampersand/Options/DaemonParser.hs index 9048d4df5a..1b5a8bce4e 100644 --- a/src/Ampersand/Options/DaemonParser.hs +++ b/src/Ampersand/Options/DaemonParser.hs @@ -1,34 +1,26 @@ -{-# LANGUAGE NoImplicitPrelude #-} + module Ampersand.Options.DaemonParser where -import Options.Applicative -import Ampersand.Misc.HasClasses -import Ampersand.Basics -import Ampersand.Options.Utils -import Ampersand.Options.FSpecGenOptsParser -import Options.Applicative.Builder.Extra (boolFlags) +import Ampersand.Basics +import Ampersand.Misc.HasClasses +import Ampersand.Options.FSpecGenOptsParser +import Options.Applicative +import Options.Applicative.Builder.Extra (boolFlags) -- | Command-line parser for the daemon command. daemonOptsParser :: Parser DaemonOpts -daemonOptsParser = - ( \outputLanguage daemonConfig fSpecGenOpts - showWarnings-> DaemonOpts - { x2OutputLanguage = outputLanguage - , xdaemonConfig = daemonConfig - , x2fSpecGenOpts = fSpecGenOpts - , xshowWarnings = showWarnings - }) - <$> outputLanguageP - <*> strOption - ( long "daemonconfig" - <> metavar "CONFIGFILE" - <> value ".ampersand" - <> showDefault - <> help "The config file contains the list of files to be monitored." - ) - <*> fSpecGenOptsParser True - <*> boolFlags True "warnings" - "show warnings in the output, if any. " - mempty - - +daemonOptsParser = + DaemonOpts + <$> strOption + ( long "daemonconfig" + <> metavar "CONFIGFILE" + <> value ".ampersand" + <> showDefault + <> help "The config file contains the list of files to be monitored." + ) + <*> fSpecGenOptsParser True + <*> boolFlags + True + "warnings" + "show warnings in the output, if any. " + mempty diff --git a/src/Ampersand/Options/DevoutputOptsParser.hs b/src/Ampersand/Options/DevoutputOptsParser.hs index 321ab864dc..48a877a770 100644 --- a/src/Ampersand/Options/DevoutputOptsParser.hs +++ b/src/Ampersand/Options/DevoutputOptsParser.hs @@ -1,30 +1,22 @@ -{-# LANGUAGE NoImplicitPrelude #-} -module Ampersand.Options.DevoutputOptsParser - (devoutputOptsParser) -where +module Ampersand.Options.DevoutputOptsParser (devoutputOptsParser) where -import Ampersand.Basics -import Ampersand.Misc.HasClasses (DevOutputOpts (..)) -import Options.Applicative -import Ampersand.Options.FSpecGenOptsParser +import Ampersand.Basics +import Ampersand.Misc.HasClasses (DevOutputOpts (..)) +import Ampersand.Options.FSpecGenOptsParser +import Options.Applicative -- | Command-line parser for DevOutputOpts. devoutputOptsParser :: FilePath -> Parser DevOutputOpts -devoutputOptsParser defOutputdir = - ( \fSpecGenOpts outputfile -> DevOutputOpts - { x8fSpecGenOpts = fSpecGenOpts - , x5outputFile = outputfile - } - ) <$> fSpecGenOptsParser False - <*> outputdirP defOutputdir - -outputdirP :: FilePath -> Parser FilePath -outputdirP defOutputdir = strArgument - (metavar "OUTPUTDIRECTORY" - <> value defOutputdir - <> showDefault - <> help "The name of the directory where the diagnostic files will be written to." - ) - - - +devoutputOptsParser defOutputdir = + DevOutputOpts + <$> fSpecGenOptsParser False + <*> outputdirP + where + outputdirP :: Parser FilePath + outputdirP = + strArgument + ( metavar "OUTPUTDIRECTORY" + <> value defOutputdir + <> showDefault + <> help "The name of the directory where the diagnostic files will be written to." + ) diff --git a/src/Ampersand/Options/DocOptsParser.hs b/src/Ampersand/Options/DocOptsParser.hs index f6266ce8f1..a6144a608a 100644 --- a/src/Ampersand/Options/DocOptsParser.hs +++ b/src/Ampersand/Options/DocOptsParser.hs @@ -1,131 +1,153 @@ + {-# LANGUAGE TupleSections #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -module Ampersand.Options.DocOptsParser - (docOptsParser) -where -import Ampersand.Basics -import Ampersand.Misc.HasClasses -import Ampersand.Options.FSpecGenOptsParser -import Ampersand.Options.Utils -import Data.Tuple.Extra -import Options.Applicative -import Options.Applicative.Builder.Extra +module Ampersand.Options.DocOptsParser (docOptsParser) where + +import Ampersand.Basics +import Ampersand.Misc.HasClasses +import Ampersand.Options.FSpecGenOptsParser +import Ampersand.Options.Utils +import Data.Tuple.Extra +import Options.Applicative +import Options.Applicative.Builder.Extra import qualified RIO.List as L import qualified RIO.Text as T - --- | Command-line parser for the proto command. -docOptsParser :: - Parser DocOpts +-- | Command-line parser for the document command. +docOptsParser :: + Parser DocOpts docOptsParser = - ( \blackWhite chapters genGraphics fspecFormat fSpecGenOpts - outputLanguage genLegalRefs -> DocOpts - { xblackWhite = blackWhite - , xchapters = chapters - , xgenGraphics = genGraphics - , xfspecFormat = fspecFormat - , x3fSpecGenOpts = fSpecGenOpts - , x3OutputLanguage = outputLanguage - , xgenLegalRefs = genLegalRefs - } - ) <$> blackWhiteP - <*> chaptersP - <*> genGraphicsP - <*> fSpecFormatP - <*> fSpecGenOptsParser False - <*> outputLanguageP - <*> genLegalRefsP - -chaptersP :: Parser [Chapter] -chaptersP = - (\intro sharedlang diagnosis conceptualanalysis dataanalysis -> - let x = [intro,sharedlang,diagnosis,conceptualanalysis,dataanalysis] - in - if length x /= length [c::Chapter | c <- [minBound..]] - then --To fix this: make sute all chapters are handled in this function. - fatal "Not all chapters are implemented thru options." - else - case both (fmap fst) . L.partition isTrue . filter (isJust . snd) $ x of - ([],[]) -> [minBound..] - (xs,[]) -> xs -- Only explicit requested chapters - ([],ys) -> case [minBound..] L.\\ ys of - [] -> exitWith $ PosAndNegChaptersSpecified - [ "Are you kidding? do you realy want an empty document?"] - cs -> cs -- All chapters exept ys - (xs,ys) -> let otherChapters = ([minBound..] L.\\ xs) L.\\ ys - in if null otherChapters - then xs - else exitWith $ PosAndNegChaptersSpecified - [ "It is unclear what chapters you want in your document." - , " You want: "<> (T.intercalate ", " . map tshow $ xs) - , " You don't want: "<> (T.intercalate ", " . map tshow $ ys) - , " What about the other chapters: " <> (T.intercalate ", " . map tshow $ otherChapters)<>" ?" - , " Please don't mix `--no-` with `--`." - ] - ) <$> chapterParser Intro - <*> chapterParser SharedLang - <*> chapterParser Diagnosis - <*> chapterParser ConceptualAnalysis - <*> chapterParser DataAnalysis + DocOpts + <$> blackWhiteP + <*> chaptersP + <*> genGraphicsP + <*> genTextP + <*> fSpecFormatP + <*> fSpecGenOptsParser False + <*> outputLanguageP + <*> genLegalRefsP where - isTrue :: (Chapter,Maybe Bool) -> Bool - isTrue (_,Just True) = True - isTrue _ = False - chapterParser :: Chapter -> Parser (Chapter,Maybe Bool) - chapterParser chp = (chp,) - <$> enableDisableFlags Nothing (Just True) (Just False) - (show chp) (" printing of chapter "<>show chp<>".") mods - where - mods = help $ "Do or do not include chapter "<>show chp<>" in the generated document." - + chaptersP :: Parser [Chapter] + chaptersP = + aap + <$> chapterParser Intro + <*> chapterParser SharedLang + <*> chapterParser Diagnosis + <*> chapterParser ConceptualAnalysis + <*> chapterParser DataAnalysis + where + aap intro sharedlang diagnosis conceptualanalysis dataanalysis + | length x /= length [c :: Chapter | c <- [minBound ..]] = + --To fix this: make sure all chapters are handled in this function. + fatal "Not all chapters are implemented thru options." + | otherwise = case both (fmap fst) . L.partition isTrue . filter (isJust . snd) $ x of + ([], []) -> [minBound ..] + (xs, []) -> xs -- Only explicit requested chapters + ([], ys) -> case [minBound ..] L.\\ ys of + [] -> + exitWith $ + PosAndNegChaptersSpecified + ["Are you kidding? do you realy want an empty document?"] + cs -> cs -- All chapters exept ys + (xs, ys) -> + let otherChapters = ([minBound ..] L.\\ xs) L.\\ ys + in if null otherChapters + then xs + else + exitWith $ + PosAndNegChaptersSpecified + [ "It is unclear what chapters you want in your document.", + " You want: " <> (T.intercalate ", " . map tshow $ xs), + " You don't want: " <> (T.intercalate ", " . map tshow $ ys), + " What about the other chapters: " <> (T.intercalate ", " . map tshow $ otherChapters) <> " ?", + " Please don't mix `--no-` with `--`." + ] + where + x = [intro, sharedlang, diagnosis, conceptualanalysis, dataanalysis] -fSpecFormatP :: Parser FSpecFormat -fSpecFormatP = toFormat . T.pack <$> strOption - ( long "format" - <> metavar "FORMAT" - <> completeWith (map (T.unpack . stripF) allFormats) - <> help "The format in which the output is written." - ) - where toFormat :: Text -> FSpecFormat - toFormat s = case filter matches allFormats of - -- FIXME: The fatals here should be plain parse errors. Not sure yet how that should be done. - -- See https://hackage.haskell.org/package/optparse-applicative - [] -> fatal $ T.unlines - ["No matching formats found. Possible formats are:" - , " "<>T.intercalate ", " (map stripF allFormats) - ] - [f] -> f - xs -> fatal $ T.unlines - [ "Ambiguous format specified. Possible matches are:" - , " "<>T.intercalate ", " (map stripF xs) - ] - where - matches :: FSpecFormat -> Bool - matches fmt = T.toLower s `T.isPrefixOf` stripF fmt - stripF :: FSpecFormat -> Text - stripF fmt = case T.uncons . T.toLower . tshow $ fmt of - Just ('f',tl) -> tl - xs -> fatal $ "All formats used to start with an 'F': "<>tshow xs - allFormats :: [FSpecFormat] - allFormats = [minBound..] + isTrue :: (Chapter, Maybe Bool) -> Bool + isTrue (_, Just True) = True + isTrue _ = False + chapterParser :: Chapter -> Parser (Chapter, Maybe Bool) + chapterParser chp = + (chp,) + <$> enableDisableFlags + Nothing + (Just True) + (Just False) + (show chp) + (" printing of chapter " <> show chp <> ".") + mods + where + mods = help $ "Do or do not include chapter " <> show chp <> " in the generated document." -genGraphicsP :: Parser Bool -genGraphicsP = boolFlags True "graphics" - "generation of graphics before generating the document." - mempty + fSpecFormatP :: Parser FSpecFormat + fSpecFormatP = + toFormat . T.pack + <$> strOption + ( long "format" + <> metavar "FORMAT" + <> completeWith (map (T.unpack . stripF) allFormats) + <> help "The format in which the output is written." + ) + where + toFormat :: Text -> FSpecFormat + toFormat s = case filter matches allFormats of + -- FIXME: The fatals here should be plain parse errors. Not sure yet how that should be done. + -- See https://hackage.haskell.org/package/optparse-applicative + [] -> + fatal $ + T.unlines + [ "No matching formats found. Possible formats are:", + " " <> T.intercalate ", " (map stripF allFormats) + ] + [f] -> f + xs -> + fatal $ + T.unlines + [ "Ambiguous format specified. Possible matches are:", + " " <> T.intercalate ", " (map stripF xs) + ] + where + matches :: FSpecFormat -> Bool + matches fmt = T.toLower s `T.isPrefixOf` stripF fmt + stripF :: FSpecFormat -> Text + stripF fmt = case T.uncons . T.toLower . tshow $ fmt of + Just ('f', tl) -> tl + xs -> fatal $ "All formats used to start with an 'F': " <> tshow xs + allFormats :: [FSpecFormat] + allFormats = [minBound ..] -blackWhiteP :: Parser Bool -blackWhiteP = switch - ( long "blackWhite" - <> help ("avoid coloring conventions to facilitate readable pictures in " - <> "black and white.") - ) + genGraphicsP :: Parser Bool + genGraphicsP = + boolFlags + True + "graphics" + "generation of graphics before generating the document." + mempty -genLegalRefsP :: Parser Bool -genLegalRefsP = boolFlags False "legal-refs" - "generation of a table of legal references in Natural Language chapter of the output document." - mempty + genTextP :: Parser Bool + genTextP = + boolFlags + True + "text" + "generation the document file." + mempty + blackWhiteP :: Parser Bool + blackWhiteP = + switch + ( long "blackWhite" + <> help + ( "avoid coloring conventions to facilitate readable pictures in " + <> "black and white." + ) + ) + genLegalRefsP :: Parser Bool + genLegalRefsP = + boolFlags + False + "legal-refs" + "generation of a table of legal references in Natural Language chapter of the output document." + mempty diff --git a/src/Ampersand/Options/FSpecGenOptsParser.hs b/src/Ampersand/Options/FSpecGenOptsParser.hs index 0bcb900ef3..5539ef0726 100644 --- a/src/Ampersand/Options/FSpecGenOptsParser.hs +++ b/src/Ampersand/Options/FSpecGenOptsParser.hs @@ -1,143 +1,168 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -module Ampersand.Options.FSpecGenOptsParser - (fSpecGenOptsParser, defFSpecGenOpts) -where -import Ampersand.Misc.HasClasses (FSpecGenOpts (..),KnownRecipe(..)) -import Ampersand.Basics + +module Ampersand.Options.FSpecGenOptsParser (fSpecGenOptsParser, defFSpecGenOpts) where + +import Ampersand.Basics +import Ampersand.Misc.HasClasses (FSpecGenOpts (..), Recipe (..), Roots (Roots)) -- import Ampersand.FSpec.ShowMeatGrinder (MetaModel(..)) -import Options.Applicative -import Options.Applicative.Builder.Extra +import Options.Applicative +import Options.Applicative.Builder.Extra import qualified RIO.Text as T -- | Command-line parser for the proto command. -fSpecGenOptsParser :: - Bool -- When for the daemon command, the rootfile will eventually come from - -- the daemon config file. - -> Parser FSpecGenOpts +fSpecGenOptsParser :: + Bool -> -- When for the daemon command, the rootfile will eventually come from + -- the daemon config file. + Parser FSpecGenOpts fSpecGenOptsParser isForDaemon = - ( \rootFile sqlBinTables genInterfaces namespace - defaultCrud trimXLSXCells - knownRecipe allowInvariantViolations - -> FSpecGenOpts - { xrootFile = rootFile - , xsqlBinTables = sqlBinTables - , xgenInterfaces = genInterfaces - , xnamespace = namespace - , xdefaultCrud = defaultCrud - , xtrimXLSXCells = trimXLSXCells - , xrecipeName = knownRecipe - , xallowInvariantViolations = allowInvariantViolations - } - ) <$> (if isForDaemon - then pure Nothing -- The rootfile should come from the daemon config file. - else Just <$> rootFileP ) - <*> sqlBinTablesP - <*> genInterfacesP - <*> namespaceP - <*> crudP - <*> trimXLSXCellsP - <*> knownRecipeP - <*> allowInvariantViolationsP -defFSpecGenOpts :: FilePath -> FSpecGenOpts -defFSpecGenOpts rootAdl = FSpecGenOpts - { xrootFile = Just rootAdl - , xsqlBinTables = False - , xgenInterfaces = False - , xnamespace = "" - , xdefaultCrud = (True,True,True,True) - , xtrimXLSXCells = True - , xrecipeName = Standard - , xallowInvariantViolations = False - } -rootFileP :: Parser FilePath -rootFileP = strArgument - (metavar "AMPERSAND_SCRIPT" - <> help "The root file of your Ampersand model.") -sqlBinTablesP :: Parser Bool -sqlBinTablesP = switch + FSpecGenOpts + <$> rootsP + <*> sqlBinTablesP + <*> genInterfacesP + <*> namespaceP + <*> crudP + <*> trimXLSXCellsP + <*> knownRecipeP + <*> allowInvariantViolationsP + where + rootsP :: Parser Roots + rootsP = if isForDaemon + then pure $ Roots [] -- The rootfile should come from the daemon config file. + else Roots <$> some rootFileP + + rootFileP :: Parser FilePath + rootFileP = + strArgument + ( metavar "AMPERSAND_SCRIPT" + <> help "The root file of your Ampersand model." + ) + + sqlBinTablesP :: Parser Bool + sqlBinTablesP = + switch ( long "sql-bin-tables" - <> help ("Generate binary tables instead of broad tables in SQL " - <>"database, for testing purposes." ) + <> help + ( "Generate binary tables instead of broad tables in SQL " + <> "database, for testing purposes." + ) ) -genInterfacesP :: Parser Bool -genInterfacesP = switch + + genInterfacesP :: Parser Bool + genInterfacesP = + switch ( long "interfaces" - <> help "Generate interfaces, which currently does not work." + <> help "Generate interfaces, which currently does not work." ) - -namespaceP :: Parser Text -namespaceP = strOption + + namespaceP :: Parser Text + namespaceP = + strOption ( long "namespace" - <> metavar "NAMESPACE" - <> value "" - <> showDefault - <> help ("Prefix database identifiers with this namespace, to " - <>"isolate namespaces within the same database." ) + <> metavar "NAMESPACE" + <> value "" + <> showDefault + <> help + ( "Prefix database identifiers with this namespace, to " + <> "isolate namespaces within the same database." + ) ) - -crudP :: Parser (Bool,Bool,Bool,Bool) -crudP = toCruds <$> strOption - (long "crud-defaults" - <> value "CRUD" - <> showDefault - <> metavar "CRUD" - <> help ("Temporary switch to learn about the semantics of crud in " - <>"interface expressions." ) + + crudP :: Parser (Bool, Bool, Bool, Bool) + crudP = + toCruds + <$> strOption + ( long "crud-defaults" + <> value "CRUD" + <> showDefault + <> metavar "CRUD" + <> help + ( "Temporary switch to learn about the semantics of crud in " + <> "interface expressions." + ) ) - where - toCruds :: String -> (Bool,Bool,Bool,Bool) - toCruds crudString = - ( 'c' `notElem` crudString - , 'r' `notElem` crudString - , 'u' `notElem` crudString - , 'd' `notElem` crudString - ) - -trimXLSXCellsP :: Parser Bool -trimXLSXCellsP = boolFlags True "trim-cellvalues" - ( "ignoring the leading and trailing spaces in .xlsx files "<> - "that are INCLUDED in the script.") - mempty -knownRecipeP :: Parser KnownRecipe -knownRecipeP = toKnownRecipe . T.pack <$> strOption - ( long "build-recipe" - <> metavar "RECIPE" - <> value (show Standard) - <> showDefault - <> completeWith (map show allKnownRecipes) - <> help ("Build the internal FSpec with a predefined recipe. Allowd values are: " - <> show allKnownRecipes - ) - ) - where - allKnownRecipes :: [KnownRecipe] - allKnownRecipes = [minBound..] - toKnownRecipe :: Text -> KnownRecipe - toKnownRecipe s = case filter matches allKnownRecipes of - -- FIXME: The fatals here should be plain parse errors. Not sure yet how that should be done. - -- See https://hackage.haskell.org/package/optparse-applicative - [] -> fatal $ T.unlines - ["No matching recipe found. Possible recipes are:" - , " "<>T.intercalate ", " (map tshow allKnownRecipes) - , " You specified: `"<>s<>"`" - ] - [f] -> f - xs -> fatal $ T.unlines - [ "Ambiguous recipe specified. Possible matches are:" - , " "<>T.intercalate ", " (map tshow xs) - ] - where - matches :: (Show a) => a -> Bool - matches x = T.toLower s `T.isPrefixOf` T.toLower (tshow x) - -allowInvariantViolationsP :: Parser Bool -allowInvariantViolationsP = switch + where + toCruds :: String -> (Bool, Bool, Bool, Bool) + toCruds crudString = + ( 'c' `notElem` crudString, + 'r' `notElem` crudString, + 'u' `notElem` crudString, + 'd' `notElem` crudString + ) + + trimXLSXCellsP :: Parser Bool + trimXLSXCellsP = + boolFlags + True + "trim-cellvalues" + ( "ignoring the leading and trailing spaces in .xlsx files " + <> "that are INCLUDED in the script." + ) + mempty + + -- | This code is written such that the recipe names from `data Recipe` (from CreateFspec.hs) + -- can be altered without changing the code below. + knownRecipeP :: Parser Recipe + knownRecipeP = + toKnownRecipe . T.pack + <$> strOption + ( long "build-recipe" + <> metavar "RECIPE" + <> value (show Standard) + <> showDefault + <> completeWith (map show allKnownRecipes) + <> help + ( "Build the internal FSpec with a predefined recipe. Allowd values are: " + <> show allKnownRecipes + ) + ) + where + allKnownRecipes :: [Recipe] + allKnownRecipes = [minBound ..] + toKnownRecipe :: Text -> Recipe + toKnownRecipe s = case filter matches allKnownRecipes of + -- TODO: The fatals here should be plain parse errors. Not sure yet how that should be done. + -- See https://hackage.haskell.org/package/optparse-applicative + [] -> + fatal $ + T.unlines + [ "No matching recipe found. Possible recipes are:", + " " <> T.intercalate ", " (map tshow allKnownRecipes), + " You specified: `" <> s <> "`" + ] + [f] -> f + xs -> + fatal $ + T.unlines + [ "Ambiguous recipe specified. Possible matches are:", + " " <> T.intercalate ", " (map tshow xs) + ] + where + matches :: (Show a) => a -> Bool + matches x = T.toLower s `T.isPrefixOf` T.toLower (tshow x) + + allowInvariantViolationsP :: Parser Bool + allowInvariantViolationsP = + switch ( long "ignore-invariant-violations" - <> help ("ignore invariant violations. In case of the prototype command, the " - <>"generated prototype might not behave as you expect. " - <>"Documentation is not affected. This means that invariant violations " - <>"are reported anyway. " - <>"(See https://github.com/AmpersandTarski/Ampersand/issues/728)") + <> help + ( "ignore invariant violations. In case of the prototype command, the " + <> "generated prototype might not behave as you expect. " + <> "Documentation is not affected. This means that invariant violations " + <> "are reported anyway. " + <> "(See https://github.com/AmpersandTarski/Ampersand/issues/728)" + ) ) + +defFSpecGenOpts :: [FilePath] -> FSpecGenOpts +defFSpecGenOpts rootAdl = + FSpecGenOpts + { xrootFile = Roots rootAdl, + xsqlBinTables = False, + xgenInterfaces = False, + xnamespace = "", + xdefaultCrud = (True, True, True, True), + xtrimXLSXCells = True, + xrecipe = Standard, + xallowInvariantViolations = False + } + \ No newline at end of file diff --git a/src/Ampersand/Options/GlobalParser.hs b/src/Ampersand/Options/GlobalParser.hs index 49fce51fab..3abceafa5d 100644 --- a/src/Ampersand/Options/GlobalParser.hs +++ b/src/Ampersand/Options/GlobalParser.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE DeriveGeneric #-} module Ampersand.Options.GlobalParser diff --git a/src/Ampersand/Options/InputOutputOpts.hs b/src/Ampersand/Options/InputOutputOpts.hs index d2ad788bfa..28dffb4133 100644 --- a/src/Ampersand/Options/InputOutputOpts.hs +++ b/src/Ampersand/Options/InputOutputOpts.hs @@ -1,30 +1,22 @@ -{-# LANGUAGE NoImplicitPrelude #-} -module Ampersand.Options.InputOutputOpts - (outputFileOptsParser) -where +module Ampersand.Options.InputOutputOpts (outputFileOptsParser) where -import Ampersand.Basics -import Ampersand.Misc.HasClasses (InputOutputOpts (..)) -import Options.Applicative -import Ampersand.Options.FSpecGenOptsParser +import Ampersand.Basics +import Ampersand.Misc.HasClasses (InputOutputOpts (..)) +import Ampersand.Options.FSpecGenOptsParser +import Options.Applicative -- | Command-line parser for OutputFileOpts. outputFileOptsParser :: FilePath -> Parser InputOutputOpts -outputFileOptsParser defOutputFile = - ( \fSpecGenOpts outputfile -> InputOutputOpts - { x4fSpecGenOpts = fSpecGenOpts - , x4outputFile = outputfile - } - ) <$> fSpecGenOptsParser False - <*> outputfileP defOutputFile - -outputfileP :: FilePath -> Parser FilePath -outputfileP defOutputFile = strArgument - (metavar "OUTPUTFILE" - <> value defOutputFile - <> showDefault - <> help "The name of the output file." - ) - - - +outputFileOptsParser defOutputFile = + InputOutputOpts + <$> fSpecGenOptsParser False + <*> outputfileP + where + outputfileP :: Parser FilePath + outputfileP = + strArgument + ( metavar "OUTPUTFILE" + <> value defOutputFile + <> showDefault + <> help "The name of the output file." + ) diff --git a/src/Ampersand/Options/LogLevelParser.hs b/src/Ampersand/Options/LogLevelParser.hs index 57443f40ee..eefadb7abe 100644 --- a/src/Ampersand/Options/LogLevelParser.hs +++ b/src/Ampersand/Options/LogLevelParser.hs @@ -1,5 +1,4 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} + module Ampersand.Options.LogLevelParser where diff --git a/src/Ampersand/Options/PopulationOptsParser.hs b/src/Ampersand/Options/PopulationOptsParser.hs index 26a7b0a7ac..0c9110698e 100644 --- a/src/Ampersand/Options/PopulationOptsParser.hs +++ b/src/Ampersand/Options/PopulationOptsParser.hs @@ -1,55 +1,55 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -module Ampersand.Options.PopulationOptsParser - (populationOptsParser) -where -import Ampersand.Basics -import Ampersand.Misc.HasClasses (PopulationOpts (..),PopulationOutputFormat(..)) -import Ampersand.Options.FSpecGenOptsParser -import Options.Applicative + +module Ampersand.Options.PopulationOptsParser (populationOptsParser) where + +import Ampersand.Basics +import Ampersand.Misc.HasClasses (PopulationOpts (..), PopulationOutputFormat (..)) +import Ampersand.Options.FSpecGenOptsParser +import Options.Applicative import qualified RIO.Text as T + -- | Command-line parser for ProofOpts. populationOptsParser :: Parser PopulationOpts -populationOptsParser = - ( \fSpecGenOpts outputFormat -> - PopulationOpts - { x5fSpecGenOpts = fSpecGenOpts - , xoutputFormat = outputFormat - } - ) <$> fSpecGenOptsParser False - <*> outputFormatP +populationOptsParser = + PopulationOpts + <$> fSpecGenOptsParser False + <*> outputFormatP outputFormatP :: Parser PopulationOutputFormat -outputFormatP = toFormat . T.pack <$> strOption - ( long "output-format" - <> metavar "FORMAT" - <> value (show XLSX) - <> showDefault - <> completeWith (map show allformats) - <> help ("The format that Population should be written to. Allowd values are: " - <> show allformats - ) +outputFormatP = + toFormat . T.pack + <$> strOption + ( long "output-format" + <> metavar "FORMAT" + <> value (show XLSX) + <> showDefault + <> completeWith (map show allformats) + <> help + ( "The format that Population should be written to. Allowd values are: " + <> show allformats + ) ) - - where - allformats :: [PopulationOutputFormat] - allformats = [minBound..] - toFormat :: Text -> PopulationOutputFormat - toFormat s = case filter matches allformats of - -- FIXME: The fatals here should be plain parse errors. Not sure yet how that should be done. - -- See https://hackage.haskell.org/package/optparse-applicative - [] -> fatal $ T.unlines - ["No matching recipe found. Possible recipes are:" - , " "<>T.intercalate ", " (map tshow allformats) - , " You specified: `"<>s<>"`" - ] - [f] -> f - xs -> fatal $ T.unlines - [ "Ambiguous recipe specified. Possible matches are:" - , " "<>T.intercalate ", " (map tshow xs) - ] - where - matches :: PopulationOutputFormat -> Bool - matches x = T.toLower s `T.isPrefixOf` T.toLower (tshow x) - + where + allformats :: [PopulationOutputFormat] + allformats = [minBound ..] + toFormat :: Text -> PopulationOutputFormat + toFormat s = case filter matches allformats of + -- FIXME: The fatals here should be plain parse errors. Not sure yet how that should be done. + -- See https://hackage.haskell.org/package/optparse-applicative + [] -> + fatal $ + T.unlines + [ "No matching recipe found. Possible recipes are:", + " " <> T.intercalate ", " (map tshow allformats), + " You specified: `" <> s <> "`" + ] + [f] -> f + xs -> + fatal $ + T.unlines + [ "Ambiguous recipe specified. Possible matches are:", + " " <> T.intercalate ", " (map tshow xs) + ] + where + matches :: PopulationOutputFormat -> Bool + matches x = T.toLower s `T.isPrefixOf` T.toLower (tshow x) diff --git a/src/Ampersand/Options/ProofOptsParser.hs b/src/Ampersand/Options/ProofOptsParser.hs index b336e83537..d0865568f0 100644 --- a/src/Ampersand/Options/ProofOptsParser.hs +++ b/src/Ampersand/Options/ProofOptsParser.hs @@ -1,20 +1,12 @@ -{-# LANGUAGE NoImplicitPrelude #-} -module Ampersand.Options.ProofOptsParser - (proofOptsParser) -where +module Ampersand.Options.ProofOptsParser (proofOptsParser) where -import Ampersand.Basics -import Ampersand.Misc.HasClasses (ProofOpts (..)) -import Options.Applicative -import Ampersand.Options.FSpecGenOptsParser +import Ampersand.Basics +import Ampersand.Misc.HasClasses (ProofOpts (..)) +import Ampersand.Options.FSpecGenOptsParser +import Options.Applicative -- | Command-line parser for ProofOpts. proofOptsParser :: Parser ProofOpts -proofOptsParser = - ( \fSpecGenOpts -> ProofOpts - { x6fSpecGenOpts = fSpecGenOpts - } - ) <$> fSpecGenOptsParser False - - - +proofOptsParser = + ProofOpts + <$> fSpecGenOptsParser False diff --git a/src/Ampersand/Options/ProtoOptsParser.hs b/src/Ampersand/Options/ProtoOptsParser.hs index 9c487f4a21..8bc137fd8b 100644 --- a/src/Ampersand/Options/ProtoOptsParser.hs +++ b/src/Ampersand/Options/ProtoOptsParser.hs @@ -1,78 +1,101 @@ -{-# LANGUAGE NoImplicitPrelude #-} -module Ampersand.Options.ProtoOptsParser - (protoOptsParser) -where +module Ampersand.Options.ProtoOptsParser (protoOptsParser) where -import Options.Applicative.Builder.Extra -import Ampersand.Commands.Proto (ProtoOpts (..)) -import Ampersand.Basics -import Ampersand.Misc.Defaults (defaultDirPrototype) -import Ampersand.Options.Utils -import Ampersand.Options.FSpecGenOptsParser -import Data.List.Split (splitWhen) -import Options.Applicative +import Ampersand.Basics +import Ampersand.Misc.Defaults (defaultDirPrototype) +import Ampersand.Misc.HasClasses +import Ampersand.Options.FSpecGenOptsParser +import Ampersand.Options.Utils +import Data.List.Split (splitWhen) +import Options.Applicative +import Options.Applicative.Builder.Extra -- | Command-line parser for the proto command. protoOptsParser :: Parser ProtoOpts -protoOptsParser = - ( \forceReinstall - outputLanguage fSpecGenOpts - dirPrototype dirCustomizations - - zwolleVersion generateFrontend generateBackend -> ProtoOpts - { xforceReinstallFramework = forceReinstall - , x1OutputLanguage = outputLanguage - , x1fSpecGenOpts = fSpecGenOpts - , xdirPrototype = dirPrototype - , xdirCustomizations = dirCustomizations - , xzwolleVersion = zwolleVersion - , xgenerateFrontend = generateFrontend - , xgenerateBackend = generateBackend - }) - <$> forceReinstallP - <*> outputLanguageP <*> fSpecGenOptsParser False - <*> optional dirPrototypeP <*> optional dirCustomizationsP - <*> zwolleVersionP - <*> generateFrontendP <*> generateBackendP +protoOptsParser = + standardToProtoType + <$> ( ProtoOpts + <$> forceReinstallP + <*> outputLanguageP + <*> fSpecGenOptsParser False + <*> optional dirPrototypeP + <*> optional dirCustomizationsP + <*> zwolleVersionP + <*> generateFrontendP + <*> generateBackendP + <*> generateMetamodelP + ) + where + standardToProtoType :: ProtoOpts -> ProtoOpts + standardToProtoType opts = + case view recipeL opts of + Standard -> set recipeL Prototype opts + _ -> opts -forceReinstallP :: Parser Bool -forceReinstallP = switch + forceReinstallP :: Parser Bool + forceReinstallP = + switch ( long "force-reinstall-framework" - <> help ("Re-install the prototype framework. This discards any previously "<> - "installed version.") + <> help + ( "Re-install the prototype framework. This discards any previously " + <> "installed version." + ) ) -dirPrototypeP :: Parser String -dirPrototypeP = strOption + + dirPrototypeP :: Parser String + dirPrototypeP = + strOption ( long "proto-dir" - <> metavar "DIRECTORY" - <> value defaultDirPrototype - <> showDefault - <> help "Specify the directory where the prototype will be generated" + <> metavar "DIRECTORY" + <> value defaultDirPrototype + <> showDefault + <> help "Specify the directory where the prototype will be generated" ) -dirCustomizationsP :: Parser [String] -dirCustomizationsP = splitWhen (== ';') <$> strOption - ( long "customizations" - <> metavar "DIR;DIR;.." - <> help "Copy one or more directories into the generated prototype. " - ) -zwolleVersionP :: Parser String -zwolleVersionP = strOption + + dirCustomizationsP :: Parser [String] + dirCustomizationsP = + splitWhen (== ';') + <$> strOption + ( long "customizations" + <> metavar "DIR;DIR;.." + <> help "Copy one or more directories into the generated prototype. " + ) + + zwolleVersionP :: Parser String + zwolleVersionP = + strOption ( long "prototype-framework-version" - <> metavar "VERSION" - <> value "v1.6.0" - <> showDefault - <> help ( "Tag, branch or SHA of the prototype framework on Github. " - <>"Normally you shouldn't need to use anohter version " - <>"than the default. Only a developer of the framework " - <>"can make good use of it. ") + <> metavar "VERSION" + <> value "v1.6.0" + <> showDefault + <> help + ( "Tag, branch or SHA of the prototype framework on Github. " + <> "Normally you shouldn't need to use anohter version " + <> "than the default. Only a developer of the framework " + <> "can make good use of it. " + ) ) -generateFrontendP :: Parser Bool -generateFrontendP = boolFlags True "frontend" + + generateFrontendP :: Parser Bool + generateFrontendP = + boolFlags + True + "frontend" "Generate prototype frontend files (Angular application)" mempty -generateBackendP :: Parser Bool -generateBackendP = boolFlags True "backend" + generateBackendP :: Parser Bool + generateBackendP = + boolFlags + True + "backend" "Generate backend files (PHP application)" mempty + -- This metamodel shows what the meatgrinder has made. This is useful for building prototypes that build on the meatgrinder. + generateMetamodelP :: Parser Bool + generateMetamodelP = + boolFlags + False + "metamodel" -- the default is "do NOT generate a metamodel" + "Generate metamodel.adl" + mempty diff --git a/src/Ampersand/Options/TestOptsParser.hs b/src/Ampersand/Options/TestOptsParser.hs index 9d71220b93..1ca5c732ed 100644 --- a/src/Ampersand/Options/TestOptsParser.hs +++ b/src/Ampersand/Options/TestOptsParser.hs @@ -1,27 +1,16 @@ -{-# LANGUAGE NoImplicitPrelude #-} -module Ampersand.Options.TestOptsParser - (testOptsParser) -where +module Ampersand.Options.TestOptsParser (testOptsParser) where -import Ampersand.Basics -import Ampersand.Misc.HasClasses (TestOpts (..)) -import Options.Applicative +import Ampersand.Basics +import Ampersand.Misc.HasClasses (TestOpts (..)) +import Options.Applicative --- | Command-line parser for DevOutputOpts. +-- | Command-line parser for TestOpts. testOptsParser :: FilePath -> Parser TestOpts -testOptsParser dir = - ( \root -> TestOpts - { rootTestDir = root - } - ) <$> rootTestDirP dir - -rootTestDirP :: FilePath -> Parser FilePath -rootTestDirP fp = strArgument - (metavar "TESTDIRECTORY" - <> value fp - <> showDefault - <> help "The root of the directory tree where the regression test cases can be found." - ) - - - +testOptsParser dir = + TestOpts + <$> strArgument + ( metavar "TESTDIRECTORY" + <> value dir + <> showDefault + <> help "The root of the directory tree where the regression test cases can be found." + ) diff --git a/src/Ampersand/Options/UmlOptsParser.hs b/src/Ampersand/Options/UmlOptsParser.hs index 8967e5b5ad..cfb3d09335 100644 --- a/src/Ampersand/Options/UmlOptsParser.hs +++ b/src/Ampersand/Options/UmlOptsParser.hs @@ -1,21 +1,14 @@ -{-# LANGUAGE NoImplicitPrelude #-} -module Ampersand.Options.UmlOptsParser - (umlOptsParser) -where +module Ampersand.Options.UmlOptsParser (umlOptsParser) where -import Options.Applicative -import Ampersand.Misc.HasClasses (UmlOpts (..)) -import Ampersand.Basics -import Ampersand.Options.FSpecGenOptsParser -import Ampersand.Options.Utils +import Ampersand.Basics +import Ampersand.Misc.HasClasses (UmlOpts (..)) +import Ampersand.Options.FSpecGenOptsParser +import Ampersand.Options.Utils +import Options.Applicative -- | Command-line parser for the Uml command. umlOptsParser :: Parser UmlOpts umlOptsParser = - ( \fSpecGenOpts outputLanguage -> UmlOpts - { x7fSpecGenOpts = fSpecGenOpts - , x4OutputLanguage = outputLanguage - } - ) <$> fSpecGenOptsParser False - <*> outputLanguageP - + UmlOpts + <$> fSpecGenOptsParser False + <*> outputLanguageP diff --git a/src/Ampersand/Options/Utils.hs b/src/Ampersand/Options/Utils.hs index 1d2206cc3c..5a74dcdf66 100644 --- a/src/Ampersand/Options/Utils.hs +++ b/src/Ampersand/Options/Utils.hs @@ -1,43 +1,44 @@ -{-# LANGUAGE NoImplicitPrelude #-} module Ampersand.Options.Utils where -import Options.Applicative -import Ampersand.Basics +import Ampersand.Basics +import Options.Applicative import qualified RIO.Char as C -- | If argument is True, hides the option from usage and help hideMods :: Bool -> Mod f a hideMods hide = if hide then internal <> hidden else idm - - -- Common parsers: outputLanguageP :: Parser (Maybe Lang) -outputLanguageP = - f <$> strOption - ( long "language" - <> metavar "OUTPUTLANGUAGE" - <> value "language of the context of the model" - <> help ("Pick 'NL' for Dutch or 'EN' for English, as the "<> - "language to be used in your output. Without this "<> - "option, output is written in the language of your "<> - "context." ) - ) - where - f :: String -> Maybe Lang - f l = case map C.toUpper l of - "NL" -> Just Dutch - "UK" -> Just English - "US" -> Just English - "EN" -> Just English - _ -> Nothing +outputLanguageP = + f + <$> strOption + ( long "language" + <> metavar "OUTPUTLANGUAGE" + <> value "language of the context of the model" + <> help + ( "Pick 'NL' for Dutch or 'EN' for English, as the " + <> "language to be used in your output. Without this " + <> "option, output is written in the language of your " + <> "context." + ) + ) + where + f :: String -> Maybe Lang + f l = case map C.toUpper l of + "NL" -> Just Dutch + "UK" -> Just English + "US" -> Just English + "EN" -> Just English + _ -> Nothing outputFileP :: String -> Parser FilePath -outputFileP deflt = strOption - ( long "to" +outputFileP deflt = + strOption + ( long "to" <> metavar "OUTPUTFILE" <> value deflt <> showDefault <> help "Name of the file where the output is written to." - ) + ) diff --git a/src/Ampersand/Options/ValidateOptsParser.hs b/src/Ampersand/Options/ValidateOptsParser.hs index eb9fdf00e6..a8fc149ac7 100644 --- a/src/Ampersand/Options/ValidateOptsParser.hs +++ b/src/Ampersand/Options/ValidateOptsParser.hs @@ -1,18 +1,11 @@ -{-# LANGUAGE NoImplicitPrelude #-} -module Ampersand.Options.ValidateOptsParser - (validateOptsParser) -where +module Ampersand.Options.ValidateOptsParser (validateOptsParser) where -import Options.Applicative -import Ampersand.Misc.HasClasses (ValidateOpts (..)) -import Ampersand.Options.ProtoOptsParser +import Ampersand.Misc.HasClasses (ValidateOpts (..)) +import Ampersand.Options.ProtoOptsParser +import Options.Applicative --- | Command-line parser for ProofOpts. +-- | Command-line parser for ValidateOpts. validateOptsParser :: Parser ValidateOpts -validateOptsParser= - ( \fSpecGenOpts -> ValidateOpts - { protoOpts = fSpecGenOpts - } - ) <$> protoOptsParser - - +validateOptsParser = + ValidateOpts + <$> protoOptsParser diff --git a/src/Ampersand/Output/FSpec2Pandoc.hs b/src/Ampersand/Output/FSpec2Pandoc.hs index 45db2e1833..aacf85fcce 100644 --- a/src/Ampersand/Output/FSpec2Pandoc.hs +++ b/src/Ampersand/Output/FSpec2Pandoc.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE OverloadedStrings #-} + {-# LANGUAGE ScopedTypeVariables #-} module Ampersand.Output.FSpec2Pandoc (fSpec2Pandoc) where diff --git a/src/Ampersand/Output/FSpec2SQL.hs b/src/Ampersand/Output/FSpec2SQL.hs index dc7b8df503..1be46ccaee 100644 --- a/src/Ampersand/Output/FSpec2SQL.hs +++ b/src/Ampersand/Output/FSpec2SQL.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE OverloadedStrings #-} + module Ampersand.Output.FSpec2SQL (dumpSQLqueries,databaseStructureSql) where diff --git a/src/Ampersand/Output/PandocAux.hs b/src/Ampersand/Output/PandocAux.hs index c69e2bfa92..9af4ac5900 100644 --- a/src/Ampersand/Output/PandocAux.hs +++ b/src/Ampersand/Output/PandocAux.hs @@ -2,7 +2,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE OverloadedStrings #-} + module Ampersand.Output.PandocAux ( writepandoc , chptTitle diff --git a/src/Ampersand/Output/Population2Xlsx.hs b/src/Ampersand/Output/Population2Xlsx.hs index f2320f88ba..d588c6869d 100644 --- a/src/Ampersand/Output/Population2Xlsx.hs +++ b/src/Ampersand/Output/Population2Xlsx.hs @@ -1,5 +1,5 @@ {-# LANGUAGE TupleSections #-} -{-# LANGUAGE OverloadedStrings #-} + module Ampersand.Output.Population2Xlsx (fSpec2PopulationXlsx) where diff --git a/src/Ampersand/Output/ToJSON/Concepts.hs b/src/Ampersand/Output/ToJSON/Concepts.hs index 74a38ad22d..78bdc651d2 100644 --- a/src/Ampersand/Output/ToJSON/Concepts.hs +++ b/src/Ampersand/Output/ToJSON/Concepts.hs @@ -1,7 +1,7 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} + module Ampersand.Output.ToJSON.Concepts (Concepts,Segment) where diff --git a/src/Ampersand/Output/ToJSON/Interfaces.hs b/src/Ampersand/Output/ToJSON/Interfaces.hs index e143e32ba8..b279a5698a 100644 --- a/src/Ampersand/Output/ToJSON/Interfaces.hs +++ b/src/Ampersand/Output/ToJSON/Interfaces.hs @@ -1,7 +1,7 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} + module Ampersand.Output.ToJSON.Interfaces (Interfaces) where diff --git a/src/Ampersand/Output/ToJSON/JSONutils.hs b/src/Ampersand/Output/ToJSON/JSONutils.hs index 0674fddc8b..3cbe066365 100644 --- a/src/Ampersand/Output/ToJSON/JSONutils.hs +++ b/src/Ampersand/Output/ToJSON/JSONutils.hs @@ -1,6 +1,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE OverloadedStrings #-} + module Ampersand.Output.ToJSON.JSONutils (JSON(..), JSON'(..), ToJSON(..) , module Ampersand.Basics diff --git a/src/Ampersand/Output/ToJSON/Relations.hs b/src/Ampersand/Output/ToJSON/Relations.hs index a16c95e7fd..d09d688825 100644 --- a/src/Ampersand/Output/ToJSON/Relations.hs +++ b/src/Ampersand/Output/ToJSON/Relations.hs @@ -1,6 +1,6 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} + module Ampersand.Output.ToJSON.Relations (Relationz) where diff --git a/src/Ampersand/Output/ToJSON/Rules.hs b/src/Ampersand/Output/ToJSON/Rules.hs index f1fbe4759b..9e479ef853 100644 --- a/src/Ampersand/Output/ToJSON/Rules.hs +++ b/src/Ampersand/Output/ToJSON/Rules.hs @@ -1,7 +1,7 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} + module Ampersand.Output.ToJSON.Rules (Rulez) where diff --git a/src/Ampersand/Output/ToPandoc/ChapterConceptualAnalysis.hs b/src/Ampersand/Output/ToPandoc/ChapterConceptualAnalysis.hs index 78b526f632..3946def818 100644 --- a/src/Ampersand/Output/ToPandoc/ChapterConceptualAnalysis.hs +++ b/src/Ampersand/Output/ToPandoc/ChapterConceptualAnalysis.hs @@ -1,5 +1,5 @@ {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE OverloadedStrings #-} + module Ampersand.Output.ToPandoc.ChapterConceptualAnalysis where import Ampersand.Graphic.ClassDiagram diff --git a/src/Ampersand/Output/ToPandoc/ChapterDataAnalysis.hs b/src/Ampersand/Output/ToPandoc/ChapterDataAnalysis.hs index 93cfed49a1..6fc8715925 100644 --- a/src/Ampersand/Output/ToPandoc/ChapterDataAnalysis.hs +++ b/src/Ampersand/Output/ToPandoc/ChapterDataAnalysis.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE OverloadedStrings #-} + module Ampersand.Output.ToPandoc.ChapterDataAnalysis (chpDataAnalysis) where import Ampersand.ADL1 diff --git a/src/Ampersand/Output/ToPandoc/ChapterDiagnosis.hs b/src/Ampersand/Output/ToPandoc/ChapterDiagnosis.hs index be555dd752..386adfa867 100644 --- a/src/Ampersand/Output/ToPandoc/ChapterDiagnosis.hs +++ b/src/Ampersand/Output/ToPandoc/ChapterDiagnosis.hs @@ -1,5 +1,5 @@ {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE OverloadedStrings #-} + module Ampersand.Output.ToPandoc.ChapterDiagnosis where import Ampersand.Output.PandocAux diff --git a/src/Ampersand/Output/ToPandoc/ChapterIntroduction.hs b/src/Ampersand/Output/ToPandoc/ChapterIntroduction.hs index 6f46e08efe..615f640ad3 100644 --- a/src/Ampersand/Output/ToPandoc/ChapterIntroduction.hs +++ b/src/Ampersand/Output/ToPandoc/ChapterIntroduction.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE OverloadedStrings #-} + {-# LANGUAGE ScopedTypeVariables #-} module Ampersand.Output.ToPandoc.ChapterIntroduction (chpIntroduction) diff --git a/src/Ampersand/Output/ToPandoc/ChapterNatLangReqs.hs b/src/Ampersand/Output/ToPandoc/ChapterNatLangReqs.hs index 8352814874..1436001d2b 100644 --- a/src/Ampersand/Output/ToPandoc/ChapterNatLangReqs.hs +++ b/src/Ampersand/Output/ToPandoc/ChapterNatLangReqs.hs @@ -1,5 +1,5 @@ {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE OverloadedStrings #-} + module Ampersand.Output.ToPandoc.ChapterNatLangReqs ( chpNatLangReqs ) where diff --git a/src/Ampersand/Output/ToPandoc/SharedAmongChapters.hs b/src/Ampersand/Output/ToPandoc/SharedAmongChapters.hs index ed7188db69..a0c4280590 100644 --- a/src/Ampersand/Output/ToPandoc/SharedAmongChapters.hs +++ b/src/Ampersand/Output/ToPandoc/SharedAmongChapters.hs @@ -1,5 +1,5 @@ {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE OverloadedStrings #-} + module Ampersand.Output.ToPandoc.SharedAmongChapters ( module Text.Pandoc.Builder , module Text.Pandoc @@ -35,7 +35,7 @@ module Ampersand.Output.ToPandoc.SharedAmongChapters , printConcept ) where -import Ampersand.ADL1 hiding (Meta) +import Ampersand.ADL1 hiding (MetaData) import Ampersand.Basics hiding (Reader,Identity,toList,link) import Ampersand.Classes import Ampersand.Core.ShowAStruct @@ -242,7 +242,6 @@ refStuff x = ("relation","rule" ,"expression","pattern","theme") - data ThemeContent = Thm { themeNr :: Int , patOfTheme :: Maybe Pattern -- A theme is about either a pattern or about everything outside patterns diff --git a/src/Ampersand/Prototype/GenFrontend.hs b/src/Ampersand/Prototype/GenFrontend.hs index 54d3a63d8f..f172a620c2 100644 --- a/src/Ampersand/Prototype/GenFrontend.hs +++ b/src/Ampersand/Prototype/GenFrontend.hs @@ -1,6 +1,6 @@ {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE OverloadedStrings #-} -module Ampersand.Prototype.GenFrontend (doGenFrontend, doGenBackend, copyCustomizations) where + +module Ampersand.Prototype.GenFrontend (doGenFrontend, doGenBackend, doGenMetaModel, copyCustomizations) where import Ampersand.ADL1 import Ampersand.Basics @@ -96,6 +96,16 @@ doGenBackend fSpec = do writeFile (dir "populations"<.>"json") $ populationToJSON env fSpec logInfo "Backend generated" +doGenMetaModel :: (HasLogFunc env, HasDirPrototype env) => FSpec -> RIO env() +doGenMetaModel fSpec = do + env <- ask + logInfo "Generating metamodel ..." + let dir = getMetamodelDir env + filepath = dir "metamodel.adl" + logDebug $ " Generating "<>display (T.pack filepath) + liftIO $ createDirectoryIfMissing True dir + writeFileUtf8 filepath (showA (originalContext fSpec)) + writeFile :: (HasLogFunc env) => FilePath -> BL.ByteString -> RIO env() writeFile filePath content = do logDebug $ " Generating "<>display (T.pack filePath) diff --git a/src/Ampersand/Prototype/PHP.hs b/src/Ampersand/Prototype/PHP.hs index 720dfd8265..c2fe88cd11 100644 --- a/src/Ampersand/Prototype/PHP.hs +++ b/src/Ampersand/Prototype/PHP.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE OverloadedStrings #-} + module Ampersand.Prototype.PHP ( evaluateExpSQL , createTempDatabase diff --git a/src/Ampersand/Prototype/ProtoUtil.hs b/src/Ampersand/Prototype/ProtoUtil.hs index a9289baada..06005b1cc5 100644 --- a/src/Ampersand/Prototype/ProtoUtil.hs +++ b/src/Ampersand/Prototype/ProtoUtil.hs @@ -1,5 +1,5 @@ {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedStrings #-} + module Ampersand.Prototype.ProtoUtil ( getGenericsDir , writePrototypeAppFile diff --git a/src/Ampersand/Prototype/TableSpec.hs b/src/Ampersand/Prototype/TableSpec.hs index e34314c7ce..00724ed8c4 100644 --- a/src/Ampersand/Prototype/TableSpec.hs +++ b/src/Ampersand/Prototype/TableSpec.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE OverloadedStrings #-} + {-# LANGUAGE FlexibleInstances #-} module Ampersand.Prototype.TableSpec ( TableSpec(tsCmnt) diff --git a/src/Ampersand/Prototype/ValidateSQL.hs b/src/Ampersand/Prototype/ValidateSQL.hs index c0a90e8de7..47d3a29a79 100644 --- a/src/Ampersand/Prototype/ValidateSQL.hs +++ b/src/Ampersand/Prototype/ValidateSQL.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE OverloadedStrings #-} + module Ampersand.Prototype.ValidateSQL (validateRulesSQL) where import Ampersand.ADL1 @@ -11,8 +11,7 @@ import qualified RIO.NonEmpty as NE import qualified RIO.Set as Set {- Validate the generated SQL for all rules in the fSpec, by comparing the evaluation results -with the results from Haskell-based Ampersand rule evaluator. The latter is much simpler and -therefore most likely to be correct in case of discrepancies. +with the results from Haskell-based Ampersand rule evaluator. -} validateRulesSQL :: (HasLogFunc env) => FSpec -> RIO env [Text] diff --git a/src/Ampersand/Runners.hs b/src/Ampersand/Runners.hs index 32292715d4..a37120bb0d 100644 --- a/src/Ampersand/Runners.hs +++ b/src/Ampersand/Runners.hs @@ -1,7 +1,5 @@ -{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} -- | Utilities for running stack commands. -- diff --git a/src/Ampersand/Test/Parser/ArbitraryTree.hs b/src/Ampersand/Test/Parser/ArbitraryTree.hs index 839abae125..95026c3e67 100644 --- a/src/Ampersand/Test/Parser/ArbitraryTree.hs +++ b/src/Ampersand/Test/Parser/ArbitraryTree.hs @@ -1,6 +1,6 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedStrings #-} + module Ampersand.Test.Parser.ArbitraryTree () where import Ampersand.Basics @@ -121,9 +121,9 @@ instance Arbitrary Origin where instance Arbitrary P_Context where arbitrary = PCtx <$> identifier -- name - <*> arbitrary -- pos - <*> arbitrary -- lang - <*> arbitrary -- markup + <*> arbitrary -- pos + <*> arbitrary -- lang + <*> arbitrary -- markup <*> arbitrary -- patterns <*> arbitrary -- rules <*> arbitrary -- relations @@ -138,8 +138,8 @@ instance Arbitrary P_Context where <*> arbitrary -- populations <*> arbitrary -- generic meta information -instance Arbitrary Meta where - arbitrary = Meta <$> arbitrary <*> safeStr <*> safeStr +instance Arbitrary MetaData where + arbitrary = MetaData <$> arbitrary <*> safeStr <*> safeStr instance Arbitrary P_RoleRule where arbitrary = Maintain <$> arbitrary <*> arbitrary <*> listOf1 identifier diff --git a/src/Ampersand/Test/Parser/ParserTest.hs b/src/Ampersand/Test/Parser/ParserTest.hs index a02d71a3ed..1db5183615 100644 --- a/src/Ampersand/Test/Parser/ParserTest.hs +++ b/src/Ampersand/Test/Parser/ParserTest.hs @@ -1,5 +1,5 @@ {-# LANGUAGE NoMonomorphismRestriction #-} -{-# LANGUAGE OverloadedStrings #-} + {-# LANGUAGE Rank2Types #-} {-# LANGUAGE ScopedTypeVariables #-} module Ampersand.Test.Parser.ParserTest ( @@ -9,6 +9,7 @@ module Ampersand.Test.Parser.ParserTest ( import Ampersand.Basics import Ampersand.Input.ADL1.CtxError (Guarded(..),CtxError) import Ampersand.Input.Parsing +import Ampersand.Misc.HasClasses import Ampersand.Options.FSpecGenOptsParser import Ampersand.Types.Config import qualified RIO.NonEmpty as NE @@ -19,16 +20,16 @@ parseScripts :: (HasRunner env) => parseScripts paths = case paths of [] -> return True - (f:fs) -> do - let fSpecGenOpts = defFSpecGenOpts f - parsed <- snd <$> extendWith fSpecGenOpts (parseFileTransitive f) + h:tl -> do + let fSpecGenOpts = defFSpecGenOpts (h:tl) + parsed <- snd <$> extendWith fSpecGenOpts (parseFilesTransitive (Roots (h:tl))) case parsed of Checked _ ws -> do - logInfo $ "Parsed: " <> display (T.pack f) + logInfo $ "Parsed: " <> display (T.pack h) mapM_ logWarn (fmap displayShow ws) - parseScripts fs + parseScripts tl Errors e -> do - logError $ "Cannot parse: " <> display (T.pack f) + logError $ "Cannot parse: " <> display (T.pack h) showErrors (NE.toList e) return False diff --git a/src/Ampersand/Test/Parser/QuickChecks.hs b/src/Ampersand/Test/Parser/QuickChecks.hs index ec3b2e052d..6340448c82 100644 --- a/src/Ampersand/Test/Parser/QuickChecks.hs +++ b/src/Ampersand/Test/Parser/QuickChecks.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE OverloadedStrings #-} + {-# LANGUAGE Rank2Types #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE NoMonomorphismRestriction #-} diff --git a/src/Ampersand/Test/Regression.hs b/src/Ampersand/Test/Regression.hs index b483112711..1934656b82 100644 --- a/src/Ampersand/Test/Regression.hs +++ b/src/Ampersand/Test/Regression.hs @@ -1,5 +1,5 @@ {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} + module Ampersand.Test.Regression ( regressionTest ) diff --git a/src/Ampersand/Types/Config.hs b/src/Ampersand/Types/Config.hs index ebaf88ba63..9e2685fe31 100644 --- a/src/Ampersand/Types/Config.hs +++ b/src/Ampersand/Types/Config.hs @@ -1,5 +1,5 @@ {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} + {-# OPTIONS_GHC -fno-warn-orphans #-} module Ampersand.Types.Config ( @@ -60,6 +60,8 @@ data Runner = Runner } deriving Show instance Show LogFunc where show _ = "" instance Show ProcessContext where show _ = "" +instance HasOptions Runner where + optsList = optsList . runnerGlobalOpts -- | Class for environment values which have a 'Runner'. class (HasProcessContext env, HasLogFunc env) => HasRunner env where @@ -79,6 +81,20 @@ data GlobalOpts = GlobalOpts , globalTermWidth :: !(Maybe Int) -- ^ Terminal width override , globalOutputDir :: !FilePath -- ^ Relative path where output should be written to } deriving (Show) +instance HasOptions GlobalOpts where + optsList opts = + [ ("--verbosity", case globalLogLevel opts of + LevelDebug -> "debug" + LevelInfo -> "info" + LevelWarn -> "warn" + LevelError -> "error" + LevelOther x -> x + ) + , ("--[no-]time-in-log", tshow $ globalTimeInLog opts) + , ("--[no-]terminal", tshow $ globalTerminal opts) + , ("--terminal-width", tshow $ globalTermWidth opts) + , ("--output-dir", tshow $ globalOutputDir opts) + ] instance HasDirOutput GlobalOpts where dirOutputL = lens globalOutputDir (\x y -> x { globalOutputDir = y }) instance HasDirOutput Runner where @@ -117,10 +133,6 @@ extendWith ext inner = do runRIO env1 $ do -- extendWith ext $ inner env2 <- ask runRIO (ExtendedRunner env2 ext) inner ---extendWith :: a -> RIO (ExtendedRunner a) b -> RIO Runner b ---extendWith opts inner = do --- env <- ask --- runRIO (ExtendedRunner env opts) inner data ExtendedRunner a = ExtendedRunner { eRunner :: !Runner @@ -128,31 +140,33 @@ data ExtendedRunner a = ExtendedRunner } deriving Show cmdOptsL :: Lens' (ExtendedRunner a) a cmdOptsL = lens eCmdOpts (\x y -> x { eCmdOpts = y }) -instance (HasOutputLanguage a) => HasOutputLanguage (ExtendedRunner a) where +instance HasOutputLanguage a => HasOutputLanguage (ExtendedRunner a) where languageL = cmdOptsL . languageL -instance (HasFSpecGenOpts a) => HasFSpecGenOpts (ExtendedRunner a) where +instance HasFSpecGenOpts a => HasFSpecGenOpts (ExtendedRunner a) where fSpecGenOptsL = cmdOptsL . fSpecGenOptsL -instance (HasDocumentOpts a) => HasDocumentOpts (ExtendedRunner a) where +instance HasDocumentOpts a => HasDocumentOpts (ExtendedRunner a) where documentOptsL = cmdOptsL . documentOptsL -instance (HasDaemonOpts a) => HasDaemonOpts (ExtendedRunner a) where +instance HasDaemonOpts a => HasDaemonOpts (ExtendedRunner a) where daemonOptsL = cmdOptsL . daemonOptsL -instance (HasTestOpts a) => HasTestOpts (ExtendedRunner a) where +instance HasTestOpts a => HasTestOpts (ExtendedRunner a) where testOptsL = cmdOptsL . testOptsL -instance (HasDirCustomizations a) => HasDirCustomizations (ExtendedRunner a) where +instance HasDirCustomizations a => HasDirCustomizations (ExtendedRunner a) where dirCustomizationsL = cmdOptsL . dirCustomizationsL -instance (HasZwolleVersion a) => HasZwolleVersion (ExtendedRunner a) where +instance HasZwolleVersion a => HasZwolleVersion (ExtendedRunner a) where zwolleVersionL = cmdOptsL . zwolleVersionL -instance (HasGenerateFrontend a) => HasGenerateFrontend (ExtendedRunner a) where +instance HasGenerateFrontend a => HasGenerateFrontend (ExtendedRunner a) where generateFrontendL = cmdOptsL . generateFrontendL -instance (HasGenerateBackend a) => HasGenerateBackend (ExtendedRunner a) where +instance HasGenerateBackend a => HasGenerateBackend (ExtendedRunner a) where generateBackendL = cmdOptsL . generateBackendL +instance HasGenerateMetamodel a => HasGenerateMetamodel (ExtendedRunner a) where + generateMetamodelL = cmdOptsL . generateMetamodelL instance (HasFSpecGenOpts a, HasDirPrototype a) => HasDirPrototype (ExtendedRunner a) where dirPrototypeL = cmdOptsL . dirPrototypeL -instance (HasProtoOpts a) => HasProtoOpts (ExtendedRunner a) where +instance HasProtoOpts a => HasProtoOpts (ExtendedRunner a) where protoOptsL = cmdOptsL . protoOptsL -instance (HasPopulationOpts a) => HasPopulationOpts (ExtendedRunner a) where +instance HasPopulationOpts a => HasPopulationOpts (ExtendedRunner a) where populationOptsL = cmdOptsL . populationOptsL -instance (HasOutputFile a) => HasOutputFile (ExtendedRunner a) where +instance HasOutputFile a => HasOutputFile (ExtendedRunner a) where outputfileL = cmdOptsL . outputfileL instance HasRunner (ExtendedRunner a) where diff --git a/src/MainApps.hs b/src/MainApps.hs index 617af685c8..c395919805 100644 --- a/src/MainApps.hs +++ b/src/MainApps.hs @@ -1,5 +1,4 @@ {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE OverloadedStrings #-} module MainApps( IO , ampersand @@ -7,6 +6,9 @@ module MainApps( , mainTest ) where +-- The purpose of this module is to call "commandLineHandler" with the correct directory, program name, and arguments. +-- Or, in case of the preprocessor or test engine, call them. + import Ampersand import Ampersand.Input.PreProcessor import Ampersand.Options.GlobalParser @@ -40,8 +42,9 @@ ampersandWorker eGlobalRun = do Right (globalMonoid,run) -> do global <- globalOptsFromMonoid isTerminal defaultOuptutDir globalMonoid -- when (globalLogLevel global == LevelDebug) $ hPutStrLn stderr versionString' + withRunnerGlobal global $ run `catch` \e -> - -- This special handler stops "stack: " from being printed before the + -- This special handler stops "ampersand: " from being printed before the -- exception case fromException e of Just ec -> exitWith ec diff --git a/src/Options/Applicative/Builder/Extra.hs b/src/Options/Applicative/Builder/Extra.hs index c2500186c3..d3dc593212 100644 --- a/src/Options/Applicative/Builder/Extra.hs +++ b/src/Options/Applicative/Builder/Extra.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} diff --git a/stack.config b/stack.config deleted file mode 100644 index 72e051bc9a..0000000000 --- a/stack.config +++ /dev/null @@ -1,204 +0,0 @@ -Cabal 2.4.1.0 -Glob 0.10.0 -HStringTemplate 0.8.7 -HTTP 4000.3.14 -HsYAML 0.2.1.0 -JuicyPixels 3.3.4 -QuickCheck 2.13.2 -SHA 1.6.4.4 -SpreadsheetML 0.1 -StateVar 1.2 -adjunctions 4.4 -aeson 1.4.6.0 -aeson-pretty 0.8.8 -ampersand 4.1.5 -ansi-terminal 0.10.3 -ansi-wl-pprint 0.6.9 -array 0.5.3.0 -asn1-encoding 0.9.6 -asn1-parse 0.9.5 -asn1-types 0.3.3 -async 2.2.2 -attoparsec 0.13.2.3 -base 4.12.0.0 -base-compat 0.10.5 -base-noprelude 4.12.0.0 -base-orphans 0.8.2 -base-unicode-symbols 0.2.3 -base16-bytestring 0.1.1.6 -base64-bytestring 1.0.0.3 -basement 0.0.11 -bifunctors 5.5.7 -binary 0.8.6.0 -binary-search 1.0.0.3 -bitarray 0.0.1.1 -blaze-builder 0.4.1.0 -blaze-html 0.9.1.2 -blaze-markup 0.8.2.3 -bytestring 0.10.8.2 -cabal-doctest 1.0.8 -call-stack 0.1.0 -case-insensitive 1.2.0.11 -cereal 0.5.8.1 -clock 0.8 -cmark-gfm 0.2.1 -cmdargs 0.10.20 -colour 2.3.5 -comonad 5.0.6 -conduit 1.3.1.2 -conduit-extra 1.3.4 -connection 0.3.1 -constraints 0.10.1 -containers 0.6.0.1 -contravariant 1.5.2 -cookie 0.4.5 -cryptonite 0.25 -data-accessor 0.2.2.8 -data-accessor-template 0.2.1.16 -data-accessor-transformers 0.2.1.7 -data-default 0.7.1.1 -data-default-class 0.1.2.0 -data-default-instances-containers 0.0.1 -data-default-instances-dlist 0.0.1 -data-default-instances-old-locale 0.0.1 -deepseq 1.4.4.0 -digest 0.0.1.2 -directory 1.3.6.1 -distributive 0.6.1 -dlist 0.8.0.7 -doclayout 0.3 -doctemplates 0.8.2 -emojis 0.1 -enclosed-exceptions 1.0.3 -errors 2.3.0 -exceptions 0.10.4 -extra 1.6.19 -fail 4.9.0.0 -fgl 5.7.0.2 -file-embed 0.0.11.1 -filepath 1.4.2.1 -free 5.1.3 -fsnotify 0.3.0.1 -generic-deriving 1.12.4 -ghc-boot-th 8.6.5 -ghc-prim 0.5.3 -gitrev 1.3.1 -graphviz 2999.20.0.4 -haddock-library 1.8.0 -hashable 1.2.7.0 -hinotify 0.4 -hourglass 0.2.12 -hslua 1.0.3.2 -hslua-module-system 0.2.1 -hslua-module-text 0.2.1 -http-client 0.6.4 -http-client-tls 0.3.5.3 -http-conduit 2.3.7.3 -http-types 0.12.3 -hxt 9.3.1.18 -hxt-charproperties 9.4.0.0 -hxt-regex-xmlschema 9.2.0.3 -hxt-unicode 9.0.2.4 -integer-gmp 1.0.2.0 -integer-logarithms 1.0.3 -invariant 0.5.3 -ipynb 0.1 -jira-wiki-markup 1.1.4 -kan-extensions 5.2 -lens 4.18.1 -libyaml 0.1.2 -lifted-async 0.10.0.5 -lifted-base 0.2.3.12 -memory 0.14.18 -microlens 0.4.10 -mime-types 0.1.0.9 -monad-control 1.0.2.3 -mono-traversable 1.0.15.1 -mtl 2.2.2 -mutable-containers 0.3.4 -network 2.8.0.1 -network-uri 2.6.2.0 -old-locale 1.0.0.7 -old-time 1.1.0.3 -open-browser 0.2.1.0 -optparse-applicative 0.15.1.0 -pandoc 2.9.2.1 -pandoc-crossref 0.3.6.2 -pandoc-types 1.20 -parallel 3.2.2.0 -parsec 3.1.14.0 -pem 0.2.4 -polyparse 1.12.1 -pretty 1.1.3.6 -primitive 0.6.4.0 -process 1.6.10.0 -profunctors 5.3 -quickcheck-instances 0.3.22 -random 1.1 -reflection 2.1.5 -regex-base 0.94.0.0 -regex-pcre-builtin 0.95.1.2.8.43 -resourcet 1.2.2 -rio 0.1.14.0 -roman-numerals 0.5.1.5 -rts 1.0 -safe 0.3.18 -scientific 0.3.6.2 -semigroupoids 5.3.4 -semigroups 0.18.5 -shelly 1.8.1 -simple-sql-parser 0.4.4 -skylighting 0.8.5 -skylighting-core 0.8.5 -socks 0.6.1 -split 0.2.3.3 -splitmix 0.0.3 -stm 2.5.0.0 -streaming-commons 0.2.1.2 -syb 0.7.1 -system-fileio 0.3.16.4 -system-filepath 0.4.14 -tagged 0.8.6 -tagsoup 0.14.8 -template-haskell 2.14.0.0 -temporary 1.3 -terminal-size 0.3.2.1 -texmath 0.12.0.2 -text 1.2.3.1 -text-conversions 0.3.0 -th-abstraction 0.3.2.0 -time 1.8.0.4 -time-compat 1.9.2.2 -tls 1.4.1 -transformers 0.5.6.2 -transformers-base 0.4.5.2 -transformers-compat 0.6.5 -type-equality 1 -typed-process 0.2.6.0 -unicode-transforms 0.3.6 -unix 2.7.2.2 -unix-compat 0.5.2 -unliftio 0.2.12 -unliftio-core 0.1.2.0 -unordered-containers 0.2.10.0 -utf8-string 1.0.1.1 -utility-ht 0.0.14 -uuid-types 1.0.3 -vector 0.12.1.2 -vector-algorithms 0.8.0.3 -void 0.7.3 -wl-pprint 1.2.1 -wl-pprint-text 1.2.0.1 -x509 1.7.5 -x509-store 1.6.7 -x509-system 1.6.6 -x509-validation 1.6.11 -xeno 0.3.5.2 -xlsx 0.8.1 -xml 1.3.14 -xml-conduit 1.8.0.1 -xml-types 0.3.6 -yaml 0.11.2.0 -yaml-config 0.4.0 -zip-archive 0.4.1 -zlib 0.6.2.1 diff --git a/testing/Sentinel/Tests/NoSentinel/Crud.adl b/testing/Sentinel/Tests/NoSentinel/Crud.adl index 24ca91fac9..3c7219dc75 100644 --- a/testing/Sentinel/Tests/NoSentinel/Crud.adl +++ b/testing/Sentinel/Tests/NoSentinel/Crud.adl @@ -47,7 +47,7 @@ rcref :: C*C[TOT,INJ] -- TODO: this makes C a non-Crud object. Is that what we w notInInterface :: X1*X2 INTERFACE RelNotInInterface(notInInterface) : I[ONE] BOX [ label : I ] --- Gives rise to X as an R object in interface A, even though it does not appear in any interface expression --- TODO: Can be fixed by static check on parameter usage, or by fixing implementation of relsUsedIn (uses expressionsIn, which returns parameters as expressions) +-- Gives rise to X as an R object in interface A, even though it does not appear in any interface term +-- TODO: Can be fixed by static check on parameter usage, or by fixing implementation of relsUsedIn (uses termsIn, which returns parameters as terms) ENDCONTEXT diff --git a/testing/Sentinel/Tests/ShouldSucceed/Issue166.adl b/testing/Sentinel/Tests/ShouldSucceed/Issue166.adl index 7a1e4bb1fa..b55bf8dfdf 100644 --- a/testing/Sentinel/Tests/ShouldSucceed/Issue166.adl +++ b/testing/Sentinel/Tests/ShouldSucceed/Issue166.adl @@ -6,7 +6,7 @@ MEANING "De persoon 'Sinterklaas' bestaat niet." ENDCONTEXT {- This test is all about the question of what is in the initial population. -Are singletons, mentioned in expressions only, part of that population? +Are singletons, mentioned in terms only, part of that population? Currently, a singleton is part of the initial population. In this case, a prototype cannot be generated, It gives the following error message: diff --git a/testing/Travis/testcases/Bugs/Current/SQL/ARM20-Test8.adl b/testing/Travis/testcases/Bugs/Current/SQL/ARM20-Test8.adl index 92db441ef0..d8ee2a5cc6 100644 --- a/testing/Travis/testcases/Bugs/Current/SQL/ARM20-Test8.adl +++ b/testing/Travis/testcases/Bugs/Current/SQL/ARM20-Test8.adl @@ -51,14 +51,14 @@ $allInterfaceObjects = ( // Top-level interface Overzicht for all roles: 'Overzicht' => array ( 'name' => 'Overzicht' - // original expression: I[ONE] + // original term: I[ONE] , 'interfaceRoles' => array () , 'editableConcepts' => array () , 'relation' => '' , 'relationIsFlipped' => '' , 'srcConcept' => 'ONE' , 'tgtConcept' => 'ONE' - , 'expressionSQL' => '/* case: ETyp x _ + , 'termSQL' => '/* case: ETyp x _ ETyp ( \"I\" ) _ */ /* I[ONE] */ /* case: (ERel (V (Sign s t))) @@ -69,12 +69,12 @@ $allInterfaceObjects = , 'boxSubInterfaces' => array ( array ( 'name' => 'Personen' - // original expression: V[ONE*Persoon] + // original term: V[ONE*Persoon] , 'relation' => '' , 'relationIsFlipped' => '' , 'srcConcept' => 'ONE' , 'tgtConcept' => 'Persoon' - , 'expressionSQL' => '/* case: ETyp x _ + , 'termSQL' => '/* case: ETyp x _ ETyp ( \"V\" ) _ */ /* case: (ERel (V (Sign s t))) ERel [ \"V[ONE*Persoon]\" ] */ @@ -84,23 +84,23 @@ $allInterfaceObjects = , 'boxSubInterfaces' => array ( array ( 'name' => 'Naam' - // original expression: I + // original term: I , 'relation' => '' , 'relationIsFlipped' => '' , 'srcConcept' => 'Persoon' , 'tgtConcept' => 'Persoon' - , 'expressionSQL' => 'SELECT DISTINCT `Persoon` AS src, `Persoon` AS tgt + , 'termSQL' => 'SELECT DISTINCT `Persoon` AS src, `Persoon` AS tgt FROM `Persoon` WHERE `Persoon` IS NOT NULL AND `Persoon` IS NOT NULL' // No subinterfaces ) , array ( 'name' => 'Eigenaar van' - // original expression: bfEigenaar~ + // original term: bfEigenaar~ , 'relation' => '' , 'relationIsFlipped' => '' , 'srcConcept' => 'Persoon' , 'tgtConcept' => 'Bedrijfsfunctie' - , 'expressionSQL' => '/* case: EFlp x. */ + , 'termSQL' => '/* case: EFlp x. */ SELECT DISTINCT `Bedrijfsfunctie` AS tgt, `bfEigenaar` AS src FROM `Bedrijfsfunctie` WHERE `Bedrijfsfunctie` IS NOT NULL AND `bfEigenaar` IS NOT NULL' @@ -109,12 +109,12 @@ $allInterfaceObjects = ) ) , array ( 'name' => 'Bedrijfsfuncties' - // original expression: V[ONE*Bedrijfsfunctie] + // original term: V[ONE*Bedrijfsfunctie] , 'relation' => '' , 'relationIsFlipped' => '' , 'srcConcept' => 'ONE' , 'tgtConcept' => 'Bedrijfsfunctie' - , 'expressionSQL' => '/* case: ETyp x _ + , 'termSQL' => '/* case: ETyp x _ ETyp ( \"V\" ) _ */ /* case: (ERel (V (Sign s t))) ERel [ \"V[ONE*Bedrijfsfunctie]\" ] */ @@ -123,12 +123,12 @@ $allInterfaceObjects = // No subinterfaces ) , array ( 'name' => 'Critera' - // original expression: V[ONE*Criterium] + // original term: V[ONE*Criterium] , 'relation' => '' , 'relationIsFlipped' => '' , 'srcConcept' => 'ONE' , 'tgtConcept' => 'Criterium' - , 'expressionSQL' => '/* case: ETyp x _ + , 'termSQL' => '/* case: ETyp x _ ETyp ( \"V\" ) _ */ /* case: (ERel (V (Sign s t))) ERel [ \"V[ONE*Criterium]\" ] */ diff --git a/testing/Travis/testcases/Misc/ARM20-Test3.adl b/testing/Travis/testcases/Misc/ARM20-Test3.adl index 90dd9cacf8..2c91db534e 100644 --- a/testing/Travis/testcases/Misc/ARM20-Test3.adl +++ b/testing/Travis/testcases/Misc/ARM20-Test3.adl @@ -9,7 +9,7 @@ Generating php Object files with Ampersand Generating Generics.php prototype.exe: !fatal error 344 (module RelBinGenSQL, Prototype v2.2.1.2458 (lib: Ampersand v2.2.1.1072)) - No plug for expression EDcD RELATION verplichting [BIAlijst*Verplichting] Nothing PRAGMA + No plug for term EDcD RELATION verplichting [BIAlijst*Verplichting] Nothing PRAGMA "" "" "" [BIAlijst*Verplichting] Errorlevel = 1 - prototype files will not be installed diff --git a/testing/Travis/testcases/Misc/ARM20-Test8.adl b/testing/Travis/testcases/Misc/ARM20-Test8.adl index 92db441ef0..d8ee2a5cc6 100644 --- a/testing/Travis/testcases/Misc/ARM20-Test8.adl +++ b/testing/Travis/testcases/Misc/ARM20-Test8.adl @@ -51,14 +51,14 @@ $allInterfaceObjects = ( // Top-level interface Overzicht for all roles: 'Overzicht' => array ( 'name' => 'Overzicht' - // original expression: I[ONE] + // original term: I[ONE] , 'interfaceRoles' => array () , 'editableConcepts' => array () , 'relation' => '' , 'relationIsFlipped' => '' , 'srcConcept' => 'ONE' , 'tgtConcept' => 'ONE' - , 'expressionSQL' => '/* case: ETyp x _ + , 'termSQL' => '/* case: ETyp x _ ETyp ( \"I\" ) _ */ /* I[ONE] */ /* case: (ERel (V (Sign s t))) @@ -69,12 +69,12 @@ $allInterfaceObjects = , 'boxSubInterfaces' => array ( array ( 'name' => 'Personen' - // original expression: V[ONE*Persoon] + // original term: V[ONE*Persoon] , 'relation' => '' , 'relationIsFlipped' => '' , 'srcConcept' => 'ONE' , 'tgtConcept' => 'Persoon' - , 'expressionSQL' => '/* case: ETyp x _ + , 'termSQL' => '/* case: ETyp x _ ETyp ( \"V\" ) _ */ /* case: (ERel (V (Sign s t))) ERel [ \"V[ONE*Persoon]\" ] */ @@ -84,23 +84,23 @@ $allInterfaceObjects = , 'boxSubInterfaces' => array ( array ( 'name' => 'Naam' - // original expression: I + // original term: I , 'relation' => '' , 'relationIsFlipped' => '' , 'srcConcept' => 'Persoon' , 'tgtConcept' => 'Persoon' - , 'expressionSQL' => 'SELECT DISTINCT `Persoon` AS src, `Persoon` AS tgt + , 'termSQL' => 'SELECT DISTINCT `Persoon` AS src, `Persoon` AS tgt FROM `Persoon` WHERE `Persoon` IS NOT NULL AND `Persoon` IS NOT NULL' // No subinterfaces ) , array ( 'name' => 'Eigenaar van' - // original expression: bfEigenaar~ + // original term: bfEigenaar~ , 'relation' => '' , 'relationIsFlipped' => '' , 'srcConcept' => 'Persoon' , 'tgtConcept' => 'Bedrijfsfunctie' - , 'expressionSQL' => '/* case: EFlp x. */ + , 'termSQL' => '/* case: EFlp x. */ SELECT DISTINCT `Bedrijfsfunctie` AS tgt, `bfEigenaar` AS src FROM `Bedrijfsfunctie` WHERE `Bedrijfsfunctie` IS NOT NULL AND `bfEigenaar` IS NOT NULL' @@ -109,12 +109,12 @@ $allInterfaceObjects = ) ) , array ( 'name' => 'Bedrijfsfuncties' - // original expression: V[ONE*Bedrijfsfunctie] + // original term: V[ONE*Bedrijfsfunctie] , 'relation' => '' , 'relationIsFlipped' => '' , 'srcConcept' => 'ONE' , 'tgtConcept' => 'Bedrijfsfunctie' - , 'expressionSQL' => '/* case: ETyp x _ + , 'termSQL' => '/* case: ETyp x _ ETyp ( \"V\" ) _ */ /* case: (ERel (V (Sign s t))) ERel [ \"V[ONE*Bedrijfsfunctie]\" ] */ @@ -123,12 +123,12 @@ $allInterfaceObjects = // No subinterfaces ) , array ( 'name' => 'Critera' - // original expression: V[ONE*Criterium] + // original term: V[ONE*Criterium] , 'relation' => '' , 'relationIsFlipped' => '' , 'srcConcept' => 'ONE' , 'tgtConcept' => 'Criterium' - , 'expressionSQL' => '/* case: ETyp x _ + , 'termSQL' => '/* case: ETyp x _ ETyp ( \"V\" ) _ */ /* case: (ERel (V (Sign s t))) ERel [ \"V[ONE*Criterium]\" ] */ diff --git a/testing/Travis/testcases/Parsing/shouldSucceed/testinfo.yaml b/testing/Travis/testcases/Parsing/shouldSucceed/testinfo.yaml index a1ae42faef..a88a4742b4 100644 --- a/testing/Travis/testcases/Parsing/shouldSucceed/testinfo.yaml +++ b/testing/Travis/testcases/Parsing/shouldSucceed/testinfo.yaml @@ -1,4 +1,3 @@ testCmds: -# - command: ampersand check --build-recipe AtlasComplete --verbose - command: ampersand check --verbose exitcode: 0 \ No newline at end of file diff --git a/testing/Travis/testcases/prototype/shouldFail/ParserOrTypecheckFailures/ARM20-Test2wrong.adl b/testing/Travis/testcases/prototype/shouldFail/ParserOrTypecheckFailures/ARM20-Test2wrong.adl index 930a563371..155e20fd3e 100644 --- a/testing/Travis/testcases/prototype/shouldFail/ParserOrTypecheckFailures/ARM20-Test2wrong.adl +++ b/testing/Travis/testcases/prototype/shouldFail/ParserOrTypecheckFailures/ARM20-Test2wrong.adl @@ -24,7 +24,7 @@ in the view definition at line 11:21 in file ARM20-Test2wrong.adl: The source of expID is "Verwachting". Each instance of Verwachting is a Criterium. Your VIEW definition does not specify how to view instances of Criterium that are not Verwachting. - In order to view every Criterium, you must replace expID by an expression whose source concept is equal to or more generic than Criterium. + In order to view every Criterium, you must replace expID by an term whose source concept is equal to or more generic than Criterium. TODO: the condensed type graph does NOT show this mistake!!!! (observation by SJ on July 23rd, 2013). Please fix ASAP... -} \ No newline at end of file diff --git a/testing/Travis/testcases/prototype/shouldFail/ParserOrTypecheckFailures/DoubleLabel.adl b/testing/Travis/testcases/prototype/shouldFail/ParserOrTypecheckFailures/DoubleLabel.adl index f2051977cf..5b14655a4a 100644 --- a/testing/Travis/testcases/prototype/shouldFail/ParserOrTypecheckFailures/DoubleLabel.adl +++ b/testing/Travis/testcases/prototype/shouldFail/ParserOrTypecheckFailures/DoubleLabel.adl @@ -8,13 +8,13 @@ INTERFACE Overview : I[ONE] ENDCONTEXT {- - Purpose: to examine the error message caused by multiple instances of the same attribute. + Purpose: to examine the error message caused by multiple instances of the same field. Result: FAIL - Reason: Attribute names in interfaces must be unique, because they are being referred to. + Reason: Field names in interfaces must be unique, because they are being referred to. Message: The interface named "Overview" contains errors: - line 3:11, file "DoubleLabel.adl": Different attributes have the same name: + line 3:11, file "DoubleLabel.adl": Different fields have the same name: (Unknown origin) "l" : V[ONE*ONE] (Unknown origin) "l" : V[ONE*ONE] -} \ No newline at end of file diff --git a/testing/Travis/testcases/prototype/shouldFail/ParserOrTypecheckFailures/InterfaceTest1.adl b/testing/Travis/testcases/prototype/shouldFail/ParserOrTypecheckFailures/InterfaceTest1.adl index 88b2ecfc58..1294a24146 100644 --- a/testing/Travis/testcases/prototype/shouldFail/ParserOrTypecheckFailures/InterfaceTest1.adl +++ b/testing/Travis/testcases/prototype/shouldFail/ParserOrTypecheckFailures/InterfaceTest1.adl @@ -10,6 +10,6 @@ ENDPATTERN ENDCONTEXT {- - Purpose: This script tests the mechanism of matching the source of an interface attribute to the target of the interface expression. + Purpose: This script tests the mechanism of matching the source of an interface field to the target of the interface term. Result: PASS -} \ No newline at end of file diff --git a/testing/Travis/testcases/prototype/shouldFail/ParserOrTypecheckFailures/try14.adl b/testing/Travis/testcases/prototype/shouldFail/ParserOrTypecheckFailures/try14.adl index 35eaa1c83e..67217b8a0f 100644 --- a/testing/Travis/testcases/prototype/shouldFail/ParserOrTypecheckFailures/try14.adl +++ b/testing/Travis/testcases/prototype/shouldFail/ParserOrTypecheckFailures/try14.adl @@ -10,10 +10,10 @@ ENDPATTERN ENDCONTEXT {- - Purpose: This script is meant to study the ambiguity of interpretation in expressions with complements. + Purpose: This script is meant to study the ambiguity of interpretation in terms with complements. Result: FAIL - An ambiguity arises in type checking. Be more specific in the expressions -s and -q. - You could add more types inside the expression, or write: + An ambiguity arises in type checking. Be more specific in the terms -s and -q. + You could add more types inside the term, or write: (V[A*B] - s) (V[B*C] - q) Error at symbol () in file try14.adl at line 7 : 14 diff --git a/testing/Travis/testcases/prototype/shouldFail/ParserOrTypecheckFailures/try7.adl b/testing/Travis/testcases/prototype/shouldFail/ParserOrTypecheckFailures/try7.adl index 9ff707e8f3..e75219be86 100644 --- a/testing/Travis/testcases/prototype/shouldFail/ParserOrTypecheckFailures/try7.adl +++ b/testing/Travis/testcases/prototype/shouldFail/ParserOrTypecheckFailures/try7.adl @@ -13,7 +13,7 @@ ENDPATTERN ENDCONTEXT {- - Purpose: This script that there are three types of rules: an equivalence, an implication, and an expression. + Purpose: This script that there are three types of rules: an equivalence, an implication, and an term. It also shows that the equivalence cannot be used inside another rule, which holds for the implication as well. Result: FAIL Reason: the rule on line 10 will not parse. diff --git a/testing/Travis/testcases/prototype/shouldSucceed/InterfaceTest1.adl b/testing/Travis/testcases/prototype/shouldSucceed/InterfaceTest1.adl index 9b0b390e35..1d4bdbf826 100644 --- a/testing/Travis/testcases/prototype/shouldSucceed/InterfaceTest1.adl +++ b/testing/Travis/testcases/prototype/shouldSucceed/InterfaceTest1.adl @@ -10,6 +10,6 @@ ENDPATTERN ENDCONTEXT {- - Purpose: This script tests the mechanism of matching the source of an interface attribute to the target of the interface expression. + Purpose: This script tests the mechanism of matching the source of an interface field to the target of the interface term. Result: PASS -} \ No newline at end of file diff --git a/testing/Travis/testcases/prototype/shouldFail/ParserOrTypecheckFailures/Issue142TooGeneric.adl b/testing/Travis/testcases/prototype/shouldSucceed/Issue142TooGeneric.adl similarity index 100% rename from testing/Travis/testcases/prototype/shouldFail/ParserOrTypecheckFailures/Issue142TooGeneric.adl rename to testing/Travis/testcases/prototype/shouldSucceed/Issue142TooGeneric.adl diff --git a/testing/Travis/testcases/prototype/shouldFail/ParserOrTypecheckFailures/Issue142TooGeneric.xlsx b/testing/Travis/testcases/prototype/shouldSucceed/Issue142TooGeneric.xlsx similarity index 100% rename from testing/Travis/testcases/prototype/shouldFail/ParserOrTypecheckFailures/Issue142TooGeneric.xlsx rename to testing/Travis/testcases/prototype/shouldSucceed/Issue142TooGeneric.xlsx diff --git a/testing/Travis/testcases/prototype/shouldSucceed/Issue746.adl b/testing/Travis/testcases/prototype/shouldSucceed/Issue746.adl index b6db6ca356..fed5e7f803 100644 --- a/testing/Travis/testcases/prototype/shouldSucceed/Issue746.adl +++ b/testing/Travis/testcases/prototype/shouldSucceed/Issue746.adl @@ -17,5 +17,5 @@ BOX [ "Sinterklaas moet hier altijd" : V[SESSION*Idee] ] ENDCONTEXT {- -This issue is about the sql implementation of expressions containing singleton expressions. +This issue is about the sql implementation of terms containing singleton terms. -} diff --git a/testing/Travis/testcases/prototype/shouldSucceed/Issue785.adl b/testing/Travis/testcases/prototype/shouldSucceed/Issue785.adl index b204c0005c..1ce10ec5cb 100644 --- a/testing/Travis/testcases/prototype/shouldSucceed/Issue785.adl +++ b/testing/Travis/testcases/prototype/shouldSucceed/Issue785.adl @@ -2,8 +2,8 @@ prop :: A * A [PROP] -RULE "good expression": (I - prop);V;"Some text"[B] -RULE "buggy expression": (I - prop)#"Some text"[B] +RULE "good term": (I - prop);V;"Some text"[B] +RULE "buggy term": (I - prop)#"Some text"[B] POPULATION B CONTAINS [ "Some Text" ] diff --git a/testing/Travis/testcases/prototype/shouldSucceed/NoMinMinValidate-Issue557/testinfo.yaml b/testing/Travis/testcases/prototype/shouldSucceed/NoMinMinValidate-Issue557/testinfo.yaml index d70128aa40..0e46db7391 100644 --- a/testing/Travis/testcases/prototype/shouldSucceed/NoMinMinValidate-Issue557/testinfo.yaml +++ b/testing/Travis/testcases/prototype/shouldSucceed/NoMinMinValidate-Issue557/testinfo.yaml @@ -1,4 +1,3 @@ testCmds: -# - command: ampersand population --verbose --build-recipe AtlasComplete - command: ampersand population --verbose exitcode: 0 diff --git a/testing/Travis/testcases/prototype/shouldSucceed/SelectExprTest.adl b/testing/Travis/testcases/prototype/shouldSucceed/SelectExprTest.adl index aeb21675c9..6d4750b34a 100644 --- a/testing/Travis/testcases/prototype/shouldSucceed/SelectExprTest.adl +++ b/testing/Travis/testcases/prototype/shouldSucceed/SelectExprTest.adl @@ -2,7 +2,7 @@ CONTEXT SelectExprTest IN ENGLISH PURPOSE PATTERN SelectExprTest IN ENGLISH {+ -This pattern is meant to test the translation of Expressions in Ampersand into +This pattern is meant to test the translation of Terms in Ampersand into SELECT statements in SQL. +} diff --git a/testing/Travis/testcases/prototype/shouldSucceed/Ticket454.adl b/testing/Travis/testcases/prototype/shouldSucceed/Ticket454.adl index 9d67bac6ad..6d4e6b22a8 100644 --- a/testing/Travis/testcases/prototype/shouldSucceed/Ticket454.adl +++ b/testing/Travis/testcases/prototype/shouldSucceed/Ticket454.adl @@ -1,7 +1,7 @@ CONTEXT Ticket454 IN ENGLISH {- PURPOSE: -Inside the Ampersand compiler, this script causes an EEps expression with EEps B (Sign B B) +Inside the Ampersand compiler, this script causes an EEps term with EEps B (Sign B B) That is not harmful, but rare. Therefore this script should succeed. -} diff --git a/testing/Travis/testcases/prototype/shouldSucceed/Try43.adl b/testing/Travis/testcases/prototype/shouldSucceed/Try43.adl index fe9996b8d2..6259d773dc 100644 --- a/testing/Travis/testcases/prototype/shouldSucceed/Try43.adl +++ b/testing/Travis/testcases/prototype/shouldSucceed/Try43.adl @@ -18,7 +18,7 @@ ENDCONTEXT {- This test case has originated from a bug chase in DemoLamicieCode702. It produced the error message: Prototype: !fatal 430 (module Core.AbstractSyntaxTree) Ampersand v3.0.1.1270:1271M - Cannot unite (with operator "\/") expression + Cannot unite (with operator "\/") term EFlp (EDcD RELATION z [A*B]) with EUni (ECpl (EDcD RELATION m [A*A]),ECpl (EDcD RELATION b [A*A])). diff --git a/testing/Travis/testcases/prototype/shouldSucceed/Try46.adl b/testing/Travis/testcases/prototype/shouldSucceed/Try46.adl index 01cb9e8b7f..93c27efa63 100644 --- a/testing/Travis/testcases/prototype/shouldSucceed/Try46.adl +++ b/testing/Travis/testcases/prototype/shouldSucceed/Try46.adl @@ -2,7 +2,7 @@ CONTEXT SelectExprTest IN ENGLISH PURPOSE PATTERN SelectExprTest IN ENGLISH {+ -This pattern is meant to test the translation of Expressions in Ampersand into +This pattern is meant to test the translation of Terms in Ampersand into SELECT statements in SQL. +} diff --git a/testing/Travis/testcases/prototype/shouldSucceed/WithMeatgrinder/SpecEdit.adl b/testing/Travis/testcases/prototype/shouldSucceed/WithMeatgrinder/SpecEdit.adl index e35526f91f..df68b51f14 100644 --- a/testing/Travis/testcases/prototype/shouldSucceed/WithMeatgrinder/SpecEdit.adl +++ b/testing/Travis/testcases/prototype/shouldSucceed/WithMeatgrinder/SpecEdit.adl @@ -6,8 +6,8 @@ CONTEXT SpecEdit IN ENGLISH -} PURPOSE CONTEXT SpecEdit {+ Simple context for testing edit operations on narrowed relations +} --- This script contains W-expressions, such as I[Orange];I[Lime];I[Citrus];I[Lemon]. These must be caught by the type checker, --- because it is predictable that there can never be any population in a W-expression. +-- This script contains W-terms, such as I[Orange];I[Lime];I[Citrus];I[Lemon]. These must be caught by the type checker, +-- because it is predictable that there can never be any population in a W-term. -- NOTE: these are currently not guaranteed to be empty, as mutual exclusion for CLASSIFY is not enforced (strangeLemon is an example) CONCEPT Fruit "Most general concept" @@ -59,9 +59,9 @@ BOX [ "Person atom" : I , "(I [Orange];citrusOwnedBy)~" : (I[Orange];citrusOwnedBy)~ , "(citrusOwnedBy~);I[Orange]" : (citrusOwnedBy~);I[Orange] , "ownsLimes;I[Orange]" : ownsLimes;I[Orange] - , "^ expression" : ownsLimes;I[Citrus];I[Lemon] -- Should fail + , "^ term" : ownsLimes;I[Citrus];I[Lemon] -- Should fail -- It's more of a '^' than a 'W' (ownsLimes; Eps Lime [Lime*Citrus]; I[Citrus]; Eps Lemon [Citrus*Lemon]; I[Lemon]), but it will also always be empty. - -- NOTE: like W expressions, these are currently not guaranteed to be empty, as mutual exclusion for CLASSIFY is not enforced (strangeLemon is an example) + -- NOTE: like W terms, these are currently not guaranteed to be empty, as mutual exclusion for CLASSIFY is not enforced (strangeLemon is an example) ] INTERFACE Lime (limeProperties) : I[Lime] @@ -92,7 +92,7 @@ dummyLimorange :: Limorange * Limorange = POPULATION ownsLimes[Person*Lime] CONTAINS [ ("martijn", "lime1") ; ("martijn", "limorange1") - ; ("martijn", "strangeLemon") -- causes ^ expression to be non-empty + ; ("martijn", "strangeLemon") -- causes ^ term to be non-empty ] POPULATION ownsCitrus[Person*Citrus] CONTAINS @@ -100,7 +100,7 @@ POPULATION ownsCitrus[Person*Citrus] CONTAINS ; ("martijn", "orange1") ; ("martijn", "orange2") ; ("martijn", "limorange1") - ; ("martijn", "strangeLemon") -- causes W expression to be non-empty + ; ("martijn", "strangeLemon") -- causes W term to be non-empty ] POPULATION ownsLimoranges[Person*Limorange] CONTAINS diff --git a/testing/Travis/testcases/prototype/shouldSucceed/WithMeatgrinder/residutest.adl b/testing/Travis/testcases/prototype/shouldSucceed/WithMeatgrinder/residutest.adl index 80b54a1ade..95ad310cc8 100644 --- a/testing/Travis/testcases/prototype/shouldSucceed/WithMeatgrinder/residutest.adl +++ b/testing/Travis/testcases/prototype/shouldSucceed/WithMeatgrinder/residutest.adl @@ -2,7 +2,7 @@ CONTEXT ResiduTest IN ENGLISH PURPOSE PATTERN SelectExprTest IN ENGLISH {+ -This pattern is meant to test the translation of Expressions in Ampersand into +This pattern is meant to test the translation of Terms in Ampersand into SELECT statements in SQL. +} @@ -32,8 +32,8 @@ RULE equiv4: s~\t~ = (t/s)~ And this produces the following fatal error: Cannot intersect (with operator "/\") - expression -(s~\t~) \/ (t/s)~ of type [B*D] - with expression s~;(t/s)~ |- t~ of type [C*D] + term -(s~\t~) \/ (t/s)~ of type [B*D] + with term s~;(t/s)~ |- t~ of type [C*D] -} diff --git a/testing/Travis/testcases/prototype/shouldSucceed/WithMeatgrinder/testinfo.yaml b/testing/Travis/testcases/prototype/shouldSucceed/WithMeatgrinder/testinfo.yaml index 52b9b48b22..e92104dd9b 100644 --- a/testing/Travis/testcases/prototype/shouldSucceed/WithMeatgrinder/testinfo.yaml +++ b/testing/Travis/testcases/prototype/shouldSucceed/WithMeatgrinder/testinfo.yaml @@ -1,6 +1,10 @@ testCmds: # The intention of this testcase is to test the meatgrinder. -# - command: ampersand proto --verbose --build-recipe AtlasComplete -# exitcode: 0 - - command: ampersand population --verbose --build-recipe AtlasPopulation + - command: ampersand population --verbose --build-recipe Standard + exitcode: 0 + - command: ampersand population --verbose --build-recipe Prototype + exitcode: 0 + - command: ampersand population --verbose --build-recipe Grind + exitcode: 0 + - command: ampersand population --verbose --build-recipe RAP exitcode: 0 \ No newline at end of file diff --git a/testing/Travis/testcases/prototype/shouldSucceed/try2.adl b/testing/Travis/testcases/prototype/shouldSucceed/try2.adl index 2432c1e2ec..5c1cfc9144 100644 --- a/testing/Travis/testcases/prototype/shouldSucceed/try2.adl +++ b/testing/Travis/testcases/prototype/shouldSucceed/try2.adl @@ -19,7 +19,7 @@ ENDCONTEXT Purpose: This script shows that a type conflict (between A and B) can be resolved by defining an intersection type D. Besides, it shows that the type checker can choose the right type for - subexpression t, which is t[B*Y] (line 6) + subterm t, which is t[B*Y] (line 6) Result: PASS Reason: the type on ; is inferred as I[D] -} \ No newline at end of file diff --git a/testing/Travis/testcases/prototype/shouldSucceed/try42.adl b/testing/Travis/testcases/prototype/shouldSucceed/try42.adl index fca493a2e3..d17125834b 100644 --- a/testing/Travis/testcases/prototype/shouldSucceed/try42.adl +++ b/testing/Travis/testcases/prototype/shouldSucceed/try42.adl @@ -17,10 +17,10 @@ ENDCONTEXT prototype: !fatal 428 (module Core.AbstractSyntaxTree) Ampersand v3.0.1.1261:126 2M - Cannot intersect (with operator "/\") expression + Cannot intersect (with operator "/\") term EDcV [ONE*A] with EIsc (EDcI A,ECps (EDcD RELATION s [A*B] Nothing PRAGMA "" "" "",EFlp (E DcD RELATION s [A*B] Nothing PRAGMA "" "" ""))). -NOTE In version v3.0.1.1261 this error occurs, but it dissapears when the expression in the box is simplified to : (I /\ s;s~ ) +NOTE In version v3.0.1.1261 this error occurs, but it dissapears when the term in the box is simplified to : (I /\ s;s~ ) -} \ No newline at end of file diff --git a/testing/Travis/testcases/prototype/shouldSucceed/try47.adl b/testing/Travis/testcases/prototype/shouldSucceed/try47.adl index 700a998cec..9208fea638 100644 --- a/testing/Travis/testcases/prototype/shouldSucceed/try47.adl +++ b/testing/Travis/testcases/prototype/shouldSucceed/try47.adl @@ -9,6 +9,6 @@ RELATION name[PatternX*PatternIdentifier] [UNI,TOT,INJ] ENDCONTEXT {- - Purpose: This script tests the mechanism of matching the source of an IDENT expression to the Concept of the IDENT + Purpose: This script tests the mechanism of matching the source of an IDENT term to the Concept of the IDENT Result: PASS -}