packages feed

ampersand 3.0.2 → 3.0.3

raw patch · 219 files changed

+26943/−21475 lines, 219 filesdep +HDBCdep +HDBC-odbcdep +HStringTemplatedep −ConfigFiledep −ampersanddep ~basedep ~bytestringdep ~containerssetup-changed

Dependencies added: HDBC, HDBC-odbc, HStringTemplate, csv, old-time, simple-sql-parser, text, uulib

Dependencies removed: ConfigFile, ampersand

Dependency ranges changed: base, bytestring, containers, directory, filepath, graphviz, mtl, old-locale, pandoc, pandoc-types, process, split, time, utf8-string

Files

AmpersandData/Examples/Delivery/Delivery.adl view
@@ -1,4 +1,4 @@-CONTEXT Delivery -- DATE: zo 24-04-2011  13:14:37,34
+CONTEXT Delivery IN ENGLISH -- DATE: zo 24-04-2011  13:14:37,34
 -- (file:  Delivery.pat ) -- 
 PATTERN Deliveries
− AmpersandData/FormalAmpersand/ADLTool.adl 
@@ -1,13 +0,0 @@-CONTEXT RAP 
-
-INCLUDE "FormalAmpersand.adl"
-
-PURPOSE CONTEXT RAP IN ENGLISH LATEX
-{+RAP is a Repository for Ampersand Projects.
-Its purpose is to provide a collaboration platform to groups of designers who work on Ampersand projects.
-This document is a step on the way of specifying RAP.
-It has largely been generated by the Ampersand toolset.
--}
-
-
-ENDCONTEXT
AmpersandData/FormalAmpersand/AST.adl view
@@ -1,219 +1,255 @@-CONTEXT RAP
+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 !--
 INCLUDE "ASTdocumentation.adl"
-CONCEPT Blob "A blob is a pString expected to need more than 256 characters of reserved space." TYPE "Blob"
-             "DatabaseDesign.Ampersand.Input.ADL1.UU_Scanner.pString:svn568"
-CONCEPT String "A string is a pString expected to be less than 256 characters."
-               "DatabaseDesign.Ampersand.Input.ADL1.UU_Scanner.pString:svn568"
-CONCEPT Conid "A conid is an identifier starting with an uppercase"
-              "DatabaseDesign.Ampersand.Input.ADL1.UU_Scanner.pConid:svn568"
-CONCEPT Varid "A varid is an identifier starting with a lowercase"
-              "DatabaseDesign.Ampersand.Input.ADL1.UU_Scanner.pVarid:svn568"
-CONCEPT ADLid "An ADLid is an identifier of type pVarid <|> pConid <|> pString"
-              "DatabaseDesign.Ampersand.Input.ADL1.Parser.pADLid:svn568"
+INCLUDE "ASTInterface.ifc"
+INCLUDE "Atoms.adl"
 
+{-RJ/20150207: Opmerkingen n.a.v. een vluchtige code-inspectie van dit bestand
+1) Het is nu nog wel, maar binnen RAP niet meer, mogelijk om een Pattern, Context en/of Concept dezelfde naam te geven (vanwege de INJectiviteit van relaties als name, ptnm). Deze nieuwe beperking lijkt me onwenselijk.
+      Reactie HJO/20150207: Die snap ik niet. Twee Concepten met dezelfde naam zijn hetzelfde Concept. Een Pattern mag dezelfde naam hebben als een Concept. Daarmee zijn de uiteraard niet identiek. Een Pattern is nou een maal geen Concept. Dit is nu zo geregeld in RAP. Als je punt is, dat twee verschillende Concepten best dezelfde naam zouden mogen hebben, dan hebben we een issue. Maar ik denk niet dat je dit bedoelt.
+2) VIEWs (zoals 'VIEW Gen') horen m.i. niet in dit bestand thuis, maar daar waar de UI wordt gespecificeerd. IDENTs horen wel in dit bestand thuis.
+      Reactie HJO/20150207: Helemaal mee eens. Gaan we doen. 
+3) Van "RELATION decprps[Declaration*PropertyRule]" zou ik denken dat hij niet alleen INJ, maar ook SUR moet zijn.
+      Reactie HJO/20150207: Dat denk ik ook. Leuk is, dat dit geen invloed heeft op de meatgrinder. Immers, die zorgt alleen maar voor de juiste populatie van Declarations. Als blijkt dat we dan overtredingen krijgen, dan gaan we dat meemaken...
+-}
+
+CONCEPT Purpose "" TYPE "Text"
+CONCEPT Meaning "" TYPE "Text"
+CONCEPT ConceptDefinition "" TYPE "Text"
+
 PATTERN Context
 CONCEPT Context "A context is the root of the abstract syntax tree of a valid Ampersand rule specification." 
-                "DatabaseDesign.Ampersand.Core.AbstractSyntaxTree.A_Context(ctxnm,ctxpats,ctxcs):svn568"
-KEY Context: Context(ctxnm)
-
-ctxnm  ::Context->Conid [INJ]
-MEANING IN ENGLISH "The name of a context."
-ctxpats::Context*Pattern
-MEANING IN ENGLISH "The patterns in a context."
-ctxcs  ::Context*PlainConcept
-MEANING IN ENGLISH "A concept, mentioned anywhere in a context, is declared."
+IDENT Context: Context(name[Context*ContextName])  
+--CLASSIFY ContextName ISA Conid
+RELATION name[Context*ContextName] [UNI,TOT,INJ]
+MEANING "The name of a context."
+RELATION patterns[Context*Pattern]
+MEANING "The patterns in a context."
+RELATION concs[Context*PlainConcept]
+MEANING "A concept, mentioned anywhere in a context."
+RELATION allDeclarations[Context*Declaration]
+MEANING "A relation declared in a context"
+RELATION gens[Context*Gen]
+MEANING "The user-defined generalization rules in a context."
 ENDPATTERN
 
-PATTERN Pattern
+PATTERN Patterns
 CONCEPT Pattern "A pattern is a container for relation declarations and rule definitions"
-                "DatabaseDesign.Ampersand.Core.AbstractSyntaxTree.Pattern(ptnm,ptdcs,ptgns,ptrls):svn568"
-KEY Pattern: Pattern(ptnm)
+IDENT Pattern: Pattern(name[Pattern*PatternName])  --TODO: The sign for name is overspecification, but is still required, for otherwise an error will occur in the typechecker.
 
-ptnm  :: Pattern->Conid [INJ]
-MEANING IN ENGLISH "The name of a pattern."
-ptrls :: Pattern*Rule
-MEANING IN ENGLISH "The user-defined rules in a pattern."
-ptgns :: Pattern*Gen
-MEANING IN ENGLISH "The user-defined generalization rules in a pattern."
-ptdcs :: Pattern*Declaration
-MEANING IN ENGLISH "The relation declarations in a pattern."
-ptxps :: Pattern*Blob
-MEANING IN ENGLISH "The purposes of a pattern."
+--CLASSIFY PatternName ISA Conid
+
+RELATION name[Pattern*PatternName] [UNI,TOT,INJ]
+MEANING "The name of a pattern."
+RELATION rules[Pattern*Rule]
+MEANING "The user-defined rules in a pattern."
+RELATION declarations[Pattern*Declaration]
+MEANING "The relation declarations in a pattern."
+RELATION purpose[Pattern*Purpose]
+MEANING "The purposes of a pattern."
+
+
 ENDPATTERN
 
-PATTERN Gen
-CONCEPT Gen "A gen, or generalization rule, is the is-a-relation between a more specific and a more generic concept."
-            "DatabaseDesign.Ampersand.Core.AbstractSyntaxTree.A_Gen(genspc,gengen):svn568"
-KEY Gen: Gen( TXT "SPEC ", genspc;cptnm , TXT " ISA " , gengen;cptnm )
+PATTERN Specialization
+VIEW Gen: Gen( TXT "CLASSIFY ", genspc;name , TXT " ISA " , gengen;name )
 RULE "eq gen": gengen;gengen~ /\ genspc;genspc~ |- I
-MEANING IN ENGLISH "Two generalization rules are identical when the specific concepts are identical and the generic concepts are identical."
+MEANING "Two generalization rules are identical when the specific concepts are identical and the generic concepts are identical."
 
-gengen :: Gen->PlainConcept
-MEANING IN ENGLISH "A generalization rule refers to a more generic concept."
-genspc :: Gen->PlainConcept
-MEANING IN ENGLISH "A generalization rule refers to a more specific concept."
+RELATION gengen[Gen*PlainConcept] [UNI,TOT]
+MEANING "A generalization rule refers to one more generic concept."
+RELATION genspc[Gen*PlainConcept] [UNI,TOT]
+MEANING "A generalization rule refers to one more specific concept."
 
+--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 Concept
 CONCEPT Concept "A concept is an abstract term representing a set of atomic terms."
-                "DatabaseDesign.Ampersand.Core.AbstractSyntaxTree.A_Concept(cptnm,cptdf,cptos):svn568"
-KEY Concept: Concept(cptnm)
+CONCEPT PlainConcept "A concept is a name for a category of similar objects."
+IDENT PlainConcept: PlainConcept(name[PlainConcept*ConceptName])
 CLASSIFY PlainConcept ISA Concept
+--CLASSIFY ConceptName ISA Conid
 
-cptnm :: Concept->Conid [INJ]
-MEANING IN ENGLISH "The name of a concept."
-cptos :: Concept*AtomID
-MEANING IN ENGLISH "The population of a concept."
-cptdf :: PlainConcept*Blob
-MEANING IN ENGLISH "The definitions of a concept."
-cptpurpose:: PlainConcept*Blob
-MEANING IN ENGLISH "The purposes of a concept."
-cpttp:: PlainConcept*Blob
-MEANING IN ENGLISH "The (technical) type of a concept"
 
-CONCEPT Order "The order of the is-a-relation between concepts."
-KEY Order: Order(ordername)
+RELATION name[PlainConcept*ConceptName] [UNI,TOT,INJ]
+MEANING "The name of a concept."
+--RELATION cptos[Concept*AtomID] [SUR]  --HJO20150204: Deze relatie is vervangen door instanceOf~ . Dit heeft te maken met het feit dat één AtomID in meerdere concepten kan voorkomen. 
+--MEANING "The population of a concept."
+RELATION cptdf[PlainConcept*ConceptDefinition]
+MEANING "The definitions of a concept."
+RELATION cptpurpose[PlainConcept*Purpose]
+MEANING "The purposes of a concept."
+RELATION cpttp[PlainConcept*TechnicalType] [UNI]
+MEANING "The (technical) type of a concept"
 
-ordername :: Order -> String [INJ]
-MEANING IN ENGLISH "The name of a class of is-a-related concepts."
-order :: Concept -> Order
-MEANING IN ENGLISH "A concept belongs to a class of is-a-related concepts."
-RULE "order": order~;genspc~;gengen;order |- I
-MEANING IN ENGLISH "Is-a-related concepts belong to the same class of is-a-related concepts."
+--CONCEPT Order "The order of the is-a-relation between concepts."
+--IDENT Order: Order(ordername)
+--
+--RELATION ordername[Order*String] [UNI,TOT,INJ]
+--MEANING "The name of a class of is-a-related concepts."
+--RELATION order[Concept*Order] [UNI,TOT]
+--MEANING "A concept belongs to a class of is-a-related concepts."
+--RULE "order": order~;genspc~;gengen;order |- I
+--MEANING "Is-a-related concepts belong to the same class of is-a-related concepts."
 --RULE "different order": ???, a closure would be nice...
---MEANING IN ENGLISH "Concepts, that are not is-a-related, are in different orders of the is-a-relation."
+--MEANING "Concepts, that are not is-a-related, are in different orders of the is-a-relation."
 
 --NOTE: MESSAGEs depend on the edit possibilities of the interface they are used in.
---if you have written messages for interfaces at a certain moment and you add an interface which can violate a message differently, then you should revise those messages, but probably you will forget to do so -> risk for awkward messages in new interface
-RULE "referential integrity": src~;decsgn~;decpopu;left \/ trg~;decsgn~;decpopu;right |- order;order~;cptos
-MEANING IN ENGLISH "An atom in the domain or codomain of a relation is an instance of a concept from the same class as the source respectively the target of that relation."
-MESSAGE "If an atom is in some tuple of a relation, then that atom must exist in the concept that is the source respectively target of that relation. Deletion of an atom from a concept is not permitted if that atom is still present in some tuple of some relation. Nor is addition of a tuple permitted if the source or target atom is not present in the related concept. It is a violation of <b>Referential integrity</b> rule for a relation." 
-VIOLATION (TXT "The tuple ", SRC I, TXT " refers to a source or target atom that does not exist." )
+--if you have written messages for interfaces at a certain moment and you add an interface which can violate a message differently, then you should revise those messages, but probably you will forget to do so->risk for awkward messages in new interface
+--RULE "referential integrity": src~;sign~;decpopu;left \/ trg~;sign~;decpopu;right |- order;order~;cptos
+--MEANING "An atom in the domain or codomain of a relation is an instance of a concept from the same class as the source respectively the target of that relation."
+--MESSAGE "If an atom is in some tuple of a relation, then that atom must exist in the concept that is the source respectively target of that relation. Deletion of an atom from a concept is not permitted if that atom is still present in some tuple of some relation. Nor is addition of a tuple permitted if the source or target atom is not present in the related concept. It is a violation of <b>Referential integrity</b> rule for a relation." 
+--VIOLATION (TXT "The tuple ", SRC I, TXT " refers to a source or target atom that does not exist." )
+ENDPATTERN
 
+PATTERN Sign
+VIEW Sign: Sign( TXT "[" , src;name[PlainConcept*ConceptName] , TXT "*" , trg;name[PlainConcept*ConceptName] , TXT "]" )
 
-CONCEPT AtomID "An atomID is the identity of an atomic term."
-CONCEPT Atom "An atom is the value of an atomic term." TYPE "Blob"
-             "DatabaseDesign.Ampersand.Input.ADL1.UU_Scanner.pAtom:svn568"
-KEY AtomID: AtomID( atomvalue , TXT " :: ", cptos~;order;ordername)
 
-atomvalue::AtomID->Atom
-MEANING IN ENGLISH "The value of an atom."
-RULE "entity integrity concept": atomvalue;atomvalue~ /\ cptos~;order;order~;cptos |- I
-MEANING IN ENGLISH "An atom of a concept has a unique value within the class of that concept."
-MESSAGE "Every atom of a concept is unique, or, no two atoms in the population of a concept have the same name. Addition of a duplicate atom is not permitted. It is a violation of the <b>Entity integrity</b> rule for this concept. Please refer to book <i>Rule Based Design</i>, page 43 and 52, <i>entity integrity</i>. "
-VIOLATION (TXT "An atom with name ", SRC I, TXT " already exists." )
+RELATION src[Sign*Concept] [UNI,TOT]
+MEANING "The source of a sign."
+RELATION trg[Sign*Concept] [UNI,TOT]
+MEANING "The target of a sign."
 
-ENDPATTERN
+--IEW PairID: PairID( TXT "<" , left;atomvalue , TXT "*" , right;atomvalue , TXT ">" )
+--HJO,20150420, uitgezet, vanwege gebruik van Atoms.adl: RELATION sign[PairID*Sign] [UNI,TOT]
+--HJO,20150420, uitgezet, vanwege gebruik van Atoms.adl: MEANING "The sign of a relationship"
+--HJO,20150420, uitgezet, vanwege gebruik van Atoms.adl: RELATION left[PairID*AtomID] [UNI,TOT]
+--HJO,20150420, uitgezet, vanwege gebruik van Atoms.adl: MEANING "The source of a relationship."
+--HJO,20150420, uitgezet, vanwege gebruik van Atoms.adl: RELATION right[PairID*AtomID] [UNI,TOT]
+--HJO,20150420, uitgezet, vanwege gebruik van Atoms.adl: MEANING "The target of a relationship."
 
-PATTERN Sign
-CONCEPT Sign "A sign is a relation type signature consisting of a source concept and a target concept."
-             "DatabaseDesign.Ampersand.Core.AbstractSyntaxTree.Sign:svn568"
-KEY Sign: Sign( src;cptnm , TXT " * " , trg;cptnm )
 
-src::Sign->Concept
-MEANING IN ENGLISH "The source of a sign."
-trg::Sign->Concept
-MEANING IN ENGLISH "The target of a sign."
+--HJO,20150420, uitgezet, vanwege gebruik van Atoms.adl: PURPOSE RULE "type consistency"
+{-In Ampersand, every pair has a signature.
+For example, the pair $\langle\id{Pete},5\rangle$ may have the signature $[\id{Person},\id{Rank}]$.
+Ampersand is called a type consistent language, because every pair in a relation has the same signature as the relation itself.
+For instance, as long as $\id{Person}$ and $\id{Rank}$ are different concepts,
+the pairs $\langle\id{Pete},5\rangle$ and $\langle5,\id{Pete}\rangle$ cannot be in the same relation.
 
-CONCEPT PairID "A pairID is an identifier for a pair of atomic terms as an instance of an element with a sign e.g. the population of a relation or the violations of a rule"
-KEY PairID: PairID( left;atomvalue , TXT " * " , right;atomvalue )
-left::PairID->AtomID
-MEANING IN ENGLISH "The source of a relationship."
-right::PairID->AtomID
-MEANING IN ENGLISH "The target of a relationship."
+In a compiler, type consistency is ensured by a type system.
+In a repository, the type of any expression does not depend on the contents of the relations in it.
+As a consequence, the type of an expression can be computed based on the types of its constituent relations only.
+-}
+--HJO,20150420, uitgezet, vanwege gebruik van Atoms.adl: RULE "type consistency" : sign=in[PairID*Declaration];sign
+--HJO,20150420, uitgezet, vanwege gebruik van Atoms.adl: MEANING "Type consistency means that all pairs in a relation have the same signature."
 ENDPATTERN
 
 PATTERN Declaration
-CONCEPT Declaration "A declaration is a declaration of a relation with a sign and properties of that relation"
-                    "DatabaseDesign.Ampersand.Core.AbstractSyntaxTree.Declaration(decnm,decsgn,decprps):svn568"
-KEY Declaration: Declaration( decnm , TXT " :: ", decsgn;src;cptnm ,TXT " * ", decsgn;trg;cptnm )
-RULE "eq declaration": decnm;decnm~ /\ decsgn;src;(decsgn;src)~ /\ decsgn;trg;(decsgn;trg)~ |- I
-MEANING IN ENGLISH "The unique signature of a relation consists of a relation name, a source concept, and a target concept."
-
-decnm   ::Declaration->Varid
-MEANING IN ENGLISH "The name of a relation."
-decsgn ::Declaration->Sign
-MEANING IN ENGLISH "The sign of a declaration."
-decprps::Declaration*PropertyRule [INJ]
-MEANING IN ENGLISH "The properties of a relation."
+--VIEW Declaration: Declaration( name , TXT "::", sign;src;name[PlainConcept*ConceptName] ,TXT " * ", sign;trg;name[PlainConcept*ConceptName] )
+--IDENT Declaration: Declaration( name, sign;src;name, sign;trg;name )
+CLASSIFY Declaration ISA Relation
+RULE "eq declaration": name;name~ /\ sign;src;(sign;src)~ /\ sign;trg;(sign;trg)~ |- I[Declaration]
+MEANING "The unique signature of a relation consists of a relation name, a source concept, and a target concept."
+--CLASSIFY DeclarationName ISA Varid
+RELATION name[Declaration*DeclarationName] [UNI] --TODO: Should be TOT, but this is only true for user-defined declarations. TODO: I[<Concept>] is a declaration? And what about V?? In Haskell, it currently is.
+MEANING "The name of a relation."
+RELATION sign[Declaration*Sign] [UNI] --TODO: Should be TOT, but this is only true for user-defined declarations. TODO: I[<Concept>] is a declaration? And what about V?? In Haskell, it currently is.
+MEANING "The sign of a declaration."
+RELATION decprps[Declaration*PropertyRule] [INJ]
+MEANING "The properties of a relation."
 
 CONCEPT PropertyRule "A property rule is a rule, that is a property of a user-declared relation"
-                     "DatabaseDesign.Ampersand.ADL1.Rule.rulefromProp:svn568"
-SPEC PropertyRule ISA Rule
-CONCEPT Property "..->.. or UNI<|>TOT<|>INJ<|>SUR<|>RFX<|>IRF<|>SYM<|>ASY<|>TRN<|>PROP"
-                 "DatabaseDesign.Ampersand.ADL1.Prop.Prop(..):svn568"
-RULE "property enum": I[Property] |- '->' \/ 'UNI' \/ 'TOT' \/ 'INJ' \/ 'SUR' \/ 'RFX' \/ 'IRF' \/ 'SYM' \/ 'ASY' \/ 'TRN' \/ 'PROP'
-MEANING IN ENGLISH "There are eleven tokens, that can be used to define properties on a relation. -> means univalent and total; UNI means univalent; TOT means total; INJ means injective; SUR means surjective; RFX means reflexive; IRF means irreflexive; SYM means symmetric; ASY means antisymmetric; TRN means transitive; and PROP means symmetric and antisymmetric."
-declaredthrough::PropertyRule*Property [TOT]
-MEANING IN ENGLISH "A property is defined as part of the declaration of relation."
-
-decprL  ::Declaration*String[UNI]
-MEANING IN ENGLISH "The prefix of the pragma of a relation."
-decprM  ::Declaration*String[UNI]
-MEANING IN ENGLISH "The infix of the pragma of a relation."
-decprR  ::Declaration*String[UNI]
-MEANING IN ENGLISH "The suffix of the pragma of a relation."
-decmean ::Declaration * Blob
-MEANING IN ENGLISH "The meanings of a relation."
-decpurpose::Declaration * Blob
-MEANING IN ENGLISH "The purposes of a relation."
-decpopu ::Declaration*PairID
-MEANING IN ENGLISH "The population of a relation."
+CLASSIFY PropertyRule ISA Rule
+CONCEPT Property "UNI<|>TOT<|>INJ<|>SUR<|>RFX<|>IRF<|>SYM<|>ASY<|>TRN<|>PROP"
+RULE "property enum": I[Property] |- 'UNI' \/ 'TOT' \/ 'INJ' \/ 'SUR' \/ 'RFX' \/ 'IRF' \/ 'SYM' \/ 'ASY' \/ 'TRN' \/ 'PROP'
+MEANING "There are eleven tokens, that can be used to define properties on a relation. -> is syntactic suger for UNI and TOT; UNI means univalent; TOT means total; INJ means injective; SUR means surjective; RFX means reflexive; IRF means irreflexive; SYM means symmetric; ASY means antisymmetric; TRN means transitive; and PROP means symmetric and antisymmetric."
+RELATION decprL[Declaration*String] [UNI]
+MEANING "The prefix of the pragma of a relation."
+RELATION decprM[Declaration*String] [UNI]
+MEANING "The infix of the pragma of a relation."
+RELATION decprR[Declaration*String] [UNI]
+MEANING "The suffix of the pragma of a relation."
+RELATION decmean[Declaration * Meaning]
+MEANING "The meanings of a relation."
+RELATION decpurpose[Declaration * Purpose]
+MEANING "The purposes of a relation."
+RELATION in[PairID*Declaration]
+MEANING "The population of a relation."
 
-RULE "entity integrity of relation": left;left~ /\ right;right~ /\ decpopu~;decpopu |- I
-MEANING IN ENGLISH "There cannot be two relationships in the population of a relation with the same source and same target."
-MESSAGE "Every tuple in a relation is unique, or, no two tuples in the population of a relation may have the same source and target atoms. Addition of a duplicate tuple is not permitted. It is a violation of the <b>Entity integrity</b> rule for this relation."
-VIOLATION (TXT "A tuple with the same source and target atoms ", SRC I, TXT " already exists." )
+--HJO,20150420, uitgezet, vanwege gebruik van Atoms.adl: RULE "entity integrity of relation": left;left~ /\ right;right~ /\ in;in~ |- I
+--HJO,20150420, uitgezet, vanwege gebruik van Atoms.adl: MEANING "There cannot be two relationships in the population of a relation with the same source and same target."
+--HJO,20150420, uitgezet, vanwege gebruik van Atoms.adl: MESSAGE "Every tuple in a relation is unique, or, no two tuples in the population of a relation may have the same source and target atoms. Addition of a duplicate tuple is not permitted. It is a violation of the <b>Entity integrity</b> rule for this relation."
+--HJO,20150420, uitgezet, vanwege gebruik van Atoms.adl: VIOLATION (TXT "A tuple with the same source and target atoms ", SRC I, TXT " already exists." )
 
-RULE "typed domain": decpopu;left;cptos~;order  |- decsgn;src;order
-MEANING IN ENGLISH "The atoms in the domain of a relation belong to the same class as the source of that relation."
-MESSAGE "You try to add a tuple with a source atom, that is not in the population of the source of the relation. This is a violation of the type of the tuple. TIP: enter text in the left input field to get a shorter pick list. Note on ISA-relations: You can make an atom more specific by moving it to the population of a more specific concept."
-VIOLATION (TXT "Source atom ", TGT I, TXT " is not in the population of ", SRC decsgn;src)
+--RULE "typed domain": decpopu;left;cptos~;order  |- sign;src;order
+--MEANING "The atoms in the domain of a relation belong to the same class as the source of that relation."
+--MESSAGE "You try to add a tuple with a source atom, that is not in the population of the source of the relation. This is a violation of the type of the tuple. TIP: enter text in the left input field to get a shorter pick list. Note on ISA-relations: You can make an atom more specific by moving it to the population of a more specific concept."
+--VIOLATION (TXT "Source atom ", TGT I, TXT " is not in the population of ", SRC sign;src)
 
-RULE "typed codomain": decpopu;right;cptos~;order |- decsgn;trg;order
-MEANING IN ENGLISH "The atoms in the codomain of a relation belong to the same class as the target of that relation."
-MESSAGE "You try to add a tuple with a target atom, that is not in the population of the target of the relation. This is a violation of the type of the tuple. TIP: enter text in the right input field to get a shorter pick list. Note on ISA-relations: You can make an atom more specific by moving it to the population of a more specific concept."
-VIOLATION (TXT "Target atom ", TGT I, TXT " is not in the population of ", SRC decsgn;trg)
+--RULE "typed codomain": decpopu;right;cptos~;order |- sign;trg;order
+--MEANING "The atoms in the codomain of a relation belong to the same class as the target of that relation."
+--MESSAGE "You try to add a tuple with a target atom, that is not in the population of the target of the relation. This is a violation of the type of the tuple. TIP: enter text in the right input field to get a shorter pick list. Note on ISA-relations: You can make an atom more specific by moving it to the population of a more specific concept."
+--VIOLATION (TXT "Target atom ", TGT I, TXT " is not in the population of ", SRC sign;trg)
 ENDPATTERN
 
 PATTERN Expression
-CONCEPT ExpressionID "An expressionID identifies an expression with a context-dependent meaning e.g. a rule assertion, a signal relation, or a relation."
-CONCEPT Expression "An expression is a relation algebraic expression in Ampersand ASCII syntax"
-                   "DatabaseDesign.Ampersand.Input.ADL1.Parser.pExpr:svn568"
-KEY ExpressionID : ExpressionID(exprvalue)
+--IDENT ExpressionID : ExpressionID(exprvalue)  -- @Stef wat wordt hiermee bedoeld? stel wat is de exprvalue van bijvoorbeeld de expressie 'r;t~' ?? Waarom onderscheid in Expression en ExpressonID??
 
-exprvalue :: ExpressionID->Expression
-MEANING IN ENGLISH "The value of an expression."
-rels  :: ExpressionID*Relation
-MEANING IN ENGLISH "The user-declared relations in an expression."
+RELATION exprvalue[ExpressionID*Expression] --[UNI,TOT]
+MEANING "The value of an expression."
+RELATION relsMentionedIn[ExpressionID*Declaration]
+MEANING "The user-declared relations in an expression."
 
-CONCEPT Relation "A relation is a relation term in an expression linked to a user-declared relation"
-KEY Relation: Relation( relnm , TXT "[" , relsgn;src;cptnm , TXT "*" , relsgn;trg;cptnm , TXT "]")
+-- TODO: HJO: @Stef: 20150407: Is onderstaand deel van dit PATTERN nog relevant? ik denk het niet. Zo ja, hoe dan? Zo nee: verwijderen.
+{-CLASSIFY RelationRef ISA Expression
 
-relnm :: Relation -> Varid
-MEANING IN ENGLISH "The name of a relation used as a relation token."
-relsgn:: Relation -> Sign
-MEANING IN ENGLISH "The sign of a relation."
-reldcl:: Relation -> Declaration
-MEANING IN ENGLISH "A relation token refers to a relation."
-RULE "rel name is decl name": relnm = reldcl;decnm
-MEANING IN ENGLISH "The name of a relation is used as a relation token to refer to that relation."
+CONCEPT RelationRef "A relation reference (aka relation token) is an expression that refers to a user-declared relation"  
+VIEW RelationRef: RelationRef( name , TXT "[" , relsgn;src;name[PlainConcept*ConceptName] , TXT "*" , relsgn;trg;name[PlainConcept*ConceptName] , TXT "]")
+
+RELATION name[RelationRef*DeclarationName] [UNI,TOT]
+MEANING "A relation reference has the name of the relation that is being referred to."
+RELATION relsgn[RelationRef*Sign] [UNI,TOT]
+MEANING "A relation reference has the sign of the relation that is being referred to."
+RELATION reldcl[RelationRef*Declaration] [UNI,TOT]
+MEANING "A relation reference has the relation that is being referred to."
+RULE "rel name is decl name": name = reldcl;name[Declaration*DeclarationName]
+MEANING "A relation reference has the same name as the relation to which it refers."
+RULE "rel sign sub of decl sign": reldcl = name;name[Declaration*DeclarationName]~ /\ relsgn;subsgn;sign~
+MEANING "A relation reference refers to the relation with the same name, the signature of which is larger or equal to the signature of the relation reference."
+-}ENDPATTERN
+
+PATTERN Rules
+IDENT Rule: Rule(name[Rule*RuleName])
+--CLASSIFY RuleName ISA ADLid
+RELATION name[Rule*RuleName] [UNI,TOT,INJ]
+MEANING "The name of a rule."
+RELATION sign[Rule*Sign] [UNI,TOT]
+RELATION rrexp[Rule*ExpressionID] [UNI,TOT]
+MEANING "The rule expressed in relation algebra."
+RELATION rrmean[Rule * Meaning]
+MEANING "The meanings of a rule."
+RELATION rrpurpose[Rule * Purpose]
+MEANING "The purposes of a rule."
+RELATION declaredthrough[PropertyRule*Property] [TOT]
+MEANING "A property is defined as part of the declaration of relation."
+
 ENDPATTERN
 
-PATTERN Rule
-CONCEPT Rule "A rule is the definition of an expression with the meaning of an assertion"
-             "DatabaseDesign.Ampersand.Core.AbstractSyntaxTree.Rule(rrnm,rrexp):svn568"
-KEY Rule: Rule(rrnm)
+PROCESS Plugs -- This pattern documents the semantics of plugs as of november 2014.
+RELATION maintains[Plug*Rule]
+RELATION in[PlainConcept*Plug] [TOT]
+RELATION in[Declaration*Plug] [TOT]
 
-rrnm  :: Rule -> ADLid [INJ]
-MEANING IN ENGLISH "The name of a rule."
-rrexp :: Rule -> ExpressionID
-MEANING IN ENGLISH "The rule expressed in relation algebra."
-rrmean:: Rule * Blob
-MEANING IN ENGLISH "The meanings of a rule."
-rrpurpose:: Rule * Blob
-MEANING IN ENGLISH "The purposes of a rule."
+-- Rules
+RULE "rule allocation" : maintains;rrexp;relsMentionedIn |- in~
+MEANING "A plug, which maintains a rule, must contain every relation that is mentioned explicitly in that rule."
+
+ROLE Ampersand MAINTAINS "All isas in one plug"
+RULE "All isas in one plug" : (-(genspc~;gengen;in) \/ in) /\ (-(gengen~;genspc;in) \/ in)
+MEANING "If a concept is stored in a plug, then every generalization of that concept is stored in the same plug."
+ENDPROCESS
+
+PATTERN ToDo -- This pattern contains stuff still to be done.
+RELATION rrviols[Rule*Violation]
 ENDPATTERN
 ENDCONTEXT
+ AmpersandData/FormalAmpersand/ASTInterface.ifc view
@@ -0,0 +1,91 @@+CONTEXT "AST Interface" IN ENGLISH
+
+INTERFACE Ampersand FOR Ampersand, Stef : I[SESSION];'_SESSION'
+TABS[ Context : V[SESSION*Context]
+    COLS ["Name" : name
+         ]
+    , "Patterns" : V[SESSION*Pattern]
+    COLS [ Pattern : name
+         , Purpose : purpose
+         , Rules : rules
+         , Declarations : declarations
+         ]
+    , "Specializations" : V[SESSION*Gen]
+    COLS [ Generic  : gengen
+         , Specific : genspc
+         ]
+    , "Concepts" : V[SESSION*PlainConcept]
+    COLS [ Definition : cptdf
+         , Purpose : cptpurpose
+         , "Technical Type" : cpttp
+         ]
+    , "Declarations" : V[SESSION*Declaration]
+    COLS [ Name : name
+         , sign : sign
+         , properties : decprps;declaredthrough
+         , pragmaL  : decprL
+         , pragmaM  : decprM
+         , pragmaR  : decprR
+         , Meaning  : decmean
+         , population : in~
+         ]
+    , "Rules" : V[SESSION*Rule]
+    COLS [ Name : name
+         , sign : sign
+         , Expression : rrexp
+         , Meaning : rrmean
+         , Purpose : rrpurpose
+         , Property : declaredthrough
+         ]
+--    , "All plugs" : V[ONE*Context];
+    ]
+INTERFACE Atoms FOR Stef : I[SESSION];'_SESSION'
+TABS[ Atoms : V[SESSION*Atom]
+    COLS [ "Atom" : I
+         , key    : key
+         , atomvalue : atomvalue
+         ]
+    , Pairs  : V[SESSION*Pair]
+    COLS [ "Pair" : I
+         , l : l
+         , r : r
+         , in : in
+         ]
+    , Relations : V[SESSION*Relation]
+    COLS [ "Relation" : I
+         , source : source
+         , target : target
+         ]
+    , Concepts : V[SESSION*Concept]
+    COLS [ "Concept" : I
+         , name : name[PlainConcept*ConceptName]
+         ]
+    ]
+    
+          
+          
+INTERFACE Pattern FOR Ampersand : I[Pattern]
+BOX [ Pattern : name
+    ]
+
+INTERFACE Concept FOR Ampersand : I[PlainConcept]
+BOX [ Concept : name
+    , "atoms with this as type" : type~
+    ]
+
+INTERFACE Gen FOR Ampersand : I[Gen]
+BOX [ gengen : gengen
+    , genspc : genspc
+    ]
+
+INTERFACE Declaration FOR Ampersand : I[Declaration]
+BOX [ name    : name
+    , sign    : sign
+    , decprL  : decprL
+    , decprM  : decprM
+    , decprR  : decprR
+    , meaning : decmean
+    , purpose : decpurpose
+    , population: in~
+    ]
+ENDCONTEXT
AmpersandData/FormalAmpersand/ASTdocumentation.adl view
@@ -3,9 +3,12 @@    Each concept of the RAP metamodel has its own section, where sections are separated by comments -}
 
 -- Context
+PURPOSE PATTERN Context
+{+The rules that govern contexts are brought together in one pattern,
+in order to formalize contexts and determine their meaning.
+-}
 CONCEPT Context "A context is a set of statements in a formal language that are true within that context."
-     --    "DatabaseDesign.Ampersand.Core.AbstractSyntaxTree.A_Context(ctxnm,ctxpats,ctxcs):svn1020"
-PURPOSE CONCEPT Context IN ENGLISH LATEX
+PURPOSE CONCEPT Context
 {+
 Contexts exist in Ampersand for the purpose of dealing with truth.
 Within one context there can be no contradictions.
@@ -30,15 +33,13 @@ For this reason, a context defines a language by means of concepts and relations, in which utterances can be made.
 We say that these utterances {\emph make sense} in that context.
 -}
-PURPOSE PATTERN Contexts IN ENGLISH LATEX
-{+The rules that govern contexts are brought together in one pattern,
-in order to formalize contexts and determine their meaning.
--}
 
--- Rule
+PURPOSE PATTERN Rules
+{+The rules that govern rules are brought together in one pattern,
+in order to formalize rules and determine their meaning.
+-}
 CONCEPT Rule "A rule is a statement that must be true in each context in which it is valid."
-  --    "DatabaseDesign.Ampersand.Core.AbstractSyntaxTree.Rule(rrnm,rrexp):svn1020"
-PURPOSE CONCEPT Rule IN ENGLISH LATEX
+PURPOSE CONCEPT Rule
 {+
 Rules are used as a concrete reason for people to act, feel or believe.
 In philosophy, this is called a 'norm'.
@@ -59,15 +60,13 @@ Outside its scope, a rule has no meaning.
 For example a rule may be valid in downtown St. Catharines, Ontario, but totally meaningless in Smalltown, NY that does not even have a St. Paul street.
 -}
-PURPOSE PATTERN Rules IN ENGLISH LATEX
-{+The rules that govern rules are brought together in one pattern,
-in order to formalize rules and determine their meaning.
--}
 
--- Pattern
+PURPOSE PATTERN Patterns
+{+The rules that govern patterns are brought together in one pattern,
+in order to formalize patterns and determine their meaning.
+-}
 CONCEPT Pattern "A pattern is a set of rules that describes a theme or a general reusable solution to a commonly occurring problem."
-     --    "DatabaseDesign.Ampersand.Core.AbstractSyntaxTree.Pattern(ptnm,ptdcs,ptgns,ptrls):svn1020"
-PURPOSE CONCEPT Pattern IN ENGLISH LATEX
+PURPOSE CONCEPT Pattern
 {+
 Patterns are used to isolate discussions about a specific theme to a particular group of stakeholders,
 who are competent to identify (define, select, invent, etc.) rules that define the theme.
@@ -84,16 +83,16 @@ The problem of identifying which persons have been using an information system can be solved by making rules
 about log-in, users and sessions.
 -}
-PURPOSE PATTERN Patterns IN ENGLISH LATEX
-{+The rules that govern patterns are brought together in one pattern,
-in order to formalize patterns and determine their meaning.
--}
 
 -- Expression
-CONCEPT ExpressionID "An expressionID identifies an expression with a context-dependent meaning e.g. a rule assertion, a signal relation, or a relation."
-CONCEPT Expression "An expression is a relation algebraic term, denoted in Ampersand syntax"
-        --    "DatabaseDesign.Ampersand.Input.ADL1.Parser.pExpr:svn1020"
-PURPOSE CONCEPT Expression IN ENGLISH LATEX
+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.
+-}
+CONCEPT ExpressionID "An expressionID identifies an expression with a context-dependent meaning e.g. a rule assertion, a signal relation, or a relation." TYPE "Text"
+CONCEPT Expression "An expression is a relation algebraic term, denoted in Ampersand syntax"  TYPE "Text"
+PURPOSE CONCEPT Expression
 {+
 Ampersand uses relation algebra to formalize phrases.
 The formalized phrases are called expressions.
@@ -107,17 +106,33 @@ The problem of identifying which persons have been using an information system can be solved by making rules
 about log-in, users and sessions.
 -}
-PURPOSE PATTERN Expressions IN ENGLISH LATEX
-{+The rules that govern expressions are brought together in one pattern,
-in order to formalize expressions and determine their meaning.
+ENDPATTERN
+
+PURPOSE PATTERN Specialization
+{+Let us briefly recall, by example, what specialization is all about.
+Citrus fruit comes in many colors: oranges are orange, lemons are yellow, limes are green, and grapefruits are red, yellow or a mixture of both.
+Based on such an observation, we might have a concept $\id{Citrus}$, with a property $\id{color}$.
+Since all limes are citrus fruits, we might have a concept $\id{Lime}$.
+Every instance of $\id{Lime}$ is a small green and very sour fruit. It is not just a $\id{Lime}$, but it is a $\id{Citrus}$ as well.
+This is called {\em specialization}.
+The reason we call \id{Lime} a specialization of \id{Citrus} is that every lime (i.e.\ each instance of \id{Lime}) has all the properties of a citrus
+and on top of that it has properties specific to limes.
+
+Specialization should be used on intrinsic properties only.
+Ask yourself: once a lime, always a lime? If the answer is yes (which sounds right to me), you can use specialization.
+Now ask yourself: once an employee, always an employee? The answer to this question is more likely to be no.
+Therefore, don't use specialization to say that an employee is a person.
 -}
 
 -- Concept
-CONCEPT A_Concept "A concept is a name for a category of similar objects."
- --    "DatabaseDesign.Ampersand.Core.AbstractSyntaxTree.A_Concept(cptnm,cptdf,cptos):svn1020"
-CONCEPT ConceptOne "ConceptOne, also known as ONE, is a predefined concept that has the role of universal singleton"
-CONCEPT PlainConcept "A concept is a name for a category of similar objects."
-PURPOSE CONCEPT PlainConcept IN ENGLISH LATEX
+PATTERN Concepts
+PURPOSE PATTERN Concepts
+{+The rules that govern concepts are brought together in one pattern,
+in order to formalize concepts and determine their meaning.
+-}
+--HJO, 20150420: In het documentatie bestand moet je eigenlijk geen definities opnemen. Die moeten elders --CONCEPT A_Concept "A concept is a name for a category of similar objects."
+--HJO, 20150420: In het documentatie bestand moet je eigenlijk geen definities opnemen. Die moeten elders ----CONCEPT ConceptOne "ConceptOne, also known as ONE, is a predefined concept that has the role of universal singleton"
+PURPOSE CONCEPT PlainConcept
 {+
 In order to reason about meaning,
 Ampersand has borrowed the idea of a "concept" from the field of semantics
@@ -132,35 +147,16 @@ The distinction between an object (Amsterdam) and the corresponding concept (City)
 has been studied for a long time [e.g.\ Frege, 1892] and is highly relevant for Ampersand.
 -}
-PURPOSE PATTERN Concepts IN ENGLISH LATEX
-{+The rules that govern concepts are brought together in one pattern,
-in order to formalize concepts and determine their meaning.
--}
+ENDPATTERN
 
--- Atom
-CONCEPT AtomID "An atomID is the identity of an atomic term."
-CONCEPT Atom "An atom is an indivisible (unstructured) data element, and an instance of a specific concept." TYPE "Blob"
-  --    "DatabaseDesign.Ampersand.Input.ADL1.UU_Scanner.pAtom:svn1020"
-CONCEPT AtomValue "An atom is the value of an atomic term." TYPE "Blob"
-  --    "DatabaseDesign.Ampersand.Input.ADL1.UU_Scanner.pAtom:svn1020"
-PURPOSE CONCEPT Atom IN ENGLISH LATEX
-{+
-Atoms are used to represent data. They are stored in relations that reside within a context.
-\subsubsection*{Example}
-For example, the atom ``Amsterdam'' is an instance of the concept ``City''.
-\subsubsection*{Explanation}
-Atoms populate relations.
-Ampersand works with binary relations, so you will find pairs of atoms in a relation.
-In an information system, the population of relations can change because of edit actions by users in user interfaces.
-This means that pairs are inserted into and deleted from relations as time goes by.
--}
-PURPOSE PATTERN Populations IN ENGLISH LATEX
+PATTERN Populations
+PURPOSE PATTERN Populations
 {+The rules that govern atoms, pairs, and populations are brought together in one pattern,
 in order to formalize them and determine their meaning.
 -}
 
 CONCEPT Population "The contents of a Concept or Relation"
-PURPOSE CONCEPT Population IN ENGLISH LATEX
+PURPOSE CONCEPT Population
 {+
 Populations are a means to specify a number of true statements that are stored in a relation.
 If an information system is generated, the population specified in an Ampersand script
@@ -183,27 +179,44 @@ 
 CONCEPT RelPopu "The content of a relation"
 CONCEPT CptPopu "The content of a concept"
-CONCEPT Pair "A pair of atomic terms as an instance of an element with a sign e.g. the population of a relation or the violations of a rule"
+CONCEPT PairID "A pairID is an identifier for a pair of atomic terms as an instance of an element with a sign e.g. the population of a relation or the violations of a rule"
 CONCEPT Blob "A blob is a pString expected to need more than 256 characters of reserved space." TYPE "Blob"
-  --    "DatabaseDesign.Ampersand.Input.ADL1.UU_Scanner.pString:svn1020"
 CONCEPT String "A string is a pString expected to be less than 256 characters."
-    --    "DatabaseDesign.Ampersand.Input.ADL1.UU_Scanner.pString:svn1020"
-CONCEPT Conid "A conid is an identifier starting with an uppercase"
-   --    "DatabaseDesign.Ampersand.Input.ADL1.UU_Scanner.pConid:svn1020"
-CONCEPT Varid "A varid is an identifier starting with a lowercase"
-   --    "DatabaseDesign.Ampersand.Input.ADL1.UU_Scanner.pVarid:svn1020"
-CONCEPT ADLid "An ADLid is an identifier of type pVarid <|> pConid <|> pString"
-   --    "DatabaseDesign.Ampersand.Input.ADL1.Parser.pADLid:svn1020"
+--HJO20150420: Uitgezet: CONCEPT Conid "A conid is an identifier starting with an uppercase"
+--HJO20150420: Uitgezet: CONCEPT Varid "A varid is an identifier starting with a lowercase"
+--HJO20150420: Uitgezet: CONCEPT ADLid "An ADLid is an identifier of type pVarid <|> pConid <|> pString"
 CONCEPT Gen "A gen, or generalization rule, is the is-a-relation between a more specific and a more generic concept."
- --    "DatabaseDesign.Ampersand.Core.AbstractSyntaxTree.A_Gen(genspc,gengen):svn1020"
 CONCEPT Sign "A sign is a relation type signature consisting of a source concept and a target concept."
-  --    "DatabaseDesign.Ampersand.Core.AbstractSyntaxTree.Sign:svn1020"
-CONCEPT PairID "A pairID is an identifier for a pair of atomic terms as an instance of an element with a sign e.g. the population of a relation or the violations of a rule"
-CONCEPT Declaration "A declaration is a declaration of a relation with a sign and properties of that relation"
-         --    "DatabaseDesign.Ampersand.Core.AbstractSyntaxTree.Declaration(decnm,decsgn,decprps):svn1020"
 CONCEPT PropertyRule "A property rule is a rule, that is a property of a user-declared relation"
-          --    "DatabaseDesign.Ampersand.ADL1.Rule.rulefromProp:svn1020"
-CONCEPT Property "..->.. or UNI<|>TOT<|>INJ<|>SUR<|>RFX<|>IRF<|>SYM<|>ASY<|>TRN<|>PROP"
-      --    "DatabaseDesign.Ampersand.ADL1.Prop.Prop(..):svn1020"
-CONCEPT Relation "A relation is a relation term in an expression linked to a user-declared relation"
+CONCEPT Property "UNI<|>TOT<|>INJ<|>SUR<|>RFX<|>IRF<|>SYM<|>ASY<|>TRN<|>PROP"
+CONCEPT Declaration "A declaration is a statement saying there exists a relation."
+CONCEPT Relation "A relation is a set of pairs."
+CONCEPT Pair "A pair is an element of a relation, which has a left atom and a right atom."
+ENDPATTERN
+
+PURPOSE PATTERN Plugs
+{+Atoms are stored in pairs, pairs are stored in relations, relations are stored in plugs, and plugs are stored in databases.
+To understand how (binary) relations are stored,
+you may perceive a plug as a database table, in which a number of rules are being maintained.
+
+Plugs are defined merely for reasons of efficient storage.
+Theoretically, each relation can be stored in a binary plug.
+In that situation, the system will work. Such a system is likely to contain more joins to be executed, so a performance problem lures.
+Ampersand tries to store multiple relations and concepts in one plug, in order to create tables with multiple columns, but with little data duplication.
+The way it works is easily visualized by perceiving each plug as a single worksheet in a spreadsheet.
+The first few colums are used as concept tables, in which concepts are stored that are related through generalization and specializations.
+The other columns are used to store relations.
+-}
+
+PURPOSE RULE "rule allocation"
+{+In order to maintain a rule, a plug must have access to the data necessary for detecting violations.
+Consequently, the information contents of a plug limits the number of rules it can maintain on its own.
+-}
+
+PURPOSE RULE "All isas in one plug"
+{+If every atom that is Lime is also Citrus, then creating a new limes must ensure that the newly made atom is a citrus too.
+Similarly, deleting the lime must ensure that the atom does not remain existent as a citrus.
+For this purpose, all concepts that are related through specialization or generalization are stored in the same plug.
+-}
+
 ENDCONTEXT
+ AmpersandData/FormalAmpersand/Atoms.adl view
@@ -0,0 +1,147 @@+CONTEXT AST IN ENGLISH
+
+PURPOSE PROCESS Atoms  --HJO: Door een of andere onverklaarbare reden mag je hier geen Atoms van maken, want dat wordt gezien als iets dubbel??
+{+The definition of atoms relates directly to the choice of Ampersand to use a representable heterogeneous relational algebra.
+This leads to populating relations with pairs, and making sure that the type of atoms is uniquely determined by the table in which the atom is stored.
+-}
+PROCESS Atoms
+PURPOSE CONCEPT Atom
+{+
+Atoms are used to represent data. They are stored in relations that reside within a context.
+\subsubsection*{Example}
+For example, the atom ``Amsterdam'' is an instance of the concept ``City''.
+\subsubsection*{Explanation}
+Atoms populate relations.
+Ampersand works with binary relations, so you will find pairs of atoms in a relation.
+In an information system, the population of relations can change because of edit actions by users in user interfaces.
+This means that pairs are inserted into and deleted from relations as time goes by.
+-}
+CONCEPT Atom "An atom is an indivisible (unstructured) data element, and an instance of a specific concept." TYPE "Blob"
+CONCEPT AtomValue "An atom is the value of an atomic term." TYPE "Blob"
+PURPOSE CONCEPT AtomID
+{+In order to represent atoms in a database, an identifier is used.
+This may even be an unintelligible, internal code that is never shown to a user.
+Its sole purpose is to identify an atom within the table that represents the database.
+-}
+CONCEPT AtomID "An atomID is the identity of an atomic term."
+
+RELATION key [Atom*AtomID] [UNI,TOT]
+MEANING "An internal storage code for this atom, used to identify the atom within a table."
+RELATION atomvalue[Atom*AtomValue] [UNI,TOT]
+MEANING "The value by which the atom is visible to users."
+RELATION source[Relation*Concept] [UNI,TOT] 
+RELATION target[Relation*Concept] [UNI,TOT] 
+ROLE Stef MAINTAINS "TOT source::Relation*Concept", "TOT target::Relation*Concept" --TODO: Moet helaas nu nog een signaalregel zijn. 
+
+RELATION in[Pair*Relation] [UNI]
+RELATION l[Pair*Atom] [UNI]
+RELATION r[Pair*Atom] [UNI]
+RELATION sub[Concept*Concept]
+MEANING "s sub g means that each element of concept s is an element of concept g as well."
+
+
+-- The following are derivable relations
+PURPOSE RULE "Def of type"
+{+Ampersand assigns precisely one type to every atom that resides in a relation.
+Note that anything that exists outside a relation, does therefore not have a type and can therefore not be an atom.
+-}
+RELATION type[Atom*Concept] [UNI]  --HJO: Was: [UNI,TOT]
+MEANING "The concept to which this atom belongs is called the type of an atom"
+RULE "Def of type" : type = l~;in;source \/ r~;in;target
+-- HJO @Stef: Bovenstaande is niet waterdicht. Het vereist dat zowel l als r SUR zijn. Zolang dat niet is gegarandeerd, is type niet TOT. Graag aanpassen...
+RELATION src[Pair*Concept] [UNI,TOT]
+ROLE Stef MAINTAINS "TOT src::Sign*Concept","TOT trg::Sign*Concept"
+RULE "Def of src" : src = in;source
+RELATION tgt[Pair*Concept] [UNI,TOT]
+RULE "Def of tgt" : tgt = in;target
+RELATION left[Pair*AtomValue] [UNI,TOT]
+ROLE Stef MAINTAINS "TOT left::Pair*AtomValue", "TOT rght::Pair*AtomValue", "TOT src::Pair*Concept", "TOT tgt::Pair*Concept"
+RULE "Def of left" : left = l;atomvalue
+ROLE Stef MAINTAINS "Def of left", "Def of rght", "Def of src", "Def of tgt", "Def of type"
+RELATION rght[Pair*AtomValue] [UNI,TOT]
+RULE "Def of rght" : rght = r;atomvalue
+
+PURPOSE RULE "typed atoms"
+{+In Ampersand, the type of an atom is determined by the relation in which it is stored.
+-}
+RULE "typed atoms" : in;in~ |- src;src~ /\ tgt;tgt~
+MEANING "Two pairs that are in the same relation have the same src and tgt concepts." 
+ROLE Stef MAINTAINS "typed atoms"  --HJO: Deze regel houdt nu nog niet, omdat er geen rekening is gehouden met classificaties. 
+PURPOSE RULE "identical atoms"
+{+The value and type are used to identify an atom.
+-}
+RULE "identical atoms" : atomvalue;atomvalue~ /\ type;type~ |- I[Atom]
+MEANING "Two atoms that have the same atomvalue and type are identical."
+
+{-The atomvalue and the location of an atom identify it.
+Here is the derivation:
+   atomvalue;atomvalue~ /\ l~;in;in~;l
+|-   { typed atoms }
+   atomvalue;atomvalue~ /\ l~;src;src~;l
+|-   { Def of src }
+   atomvalue;atomvalue~ /\ l~;in;source;source~;in~;l
+|-   { Def of type }
+   atomvalue;atomvalue~ /\ type;type~
+|-   { identical atoms }
+   I[Atom]
+So atomvalue;atomvalue~ /\ l~;in;in~;l |- I[Atom], which proves the point.
+Similarly, it can be proven that atomvalue;atomvalue~ /\ r~;in;in~;r |- I[Atom].
+-}
+
+{-The relation src is univalent, because both in and source are univalent
+Here is the derivation:
+   src~;src
+|-   { Def of src }
+   source~;in~;in;source
+|-   { in~;in |- I, because in is univalent }
+   source~;source
+|-   { source~;source |- I, because in is univalent }
+   I[Atom]
+So src~;src |- I[Atom], which means that src is univalent.
+Similarly, tgt is univalent
+-}
+
+PURPOSE RULE "specialized atoms (src)"
+{+The value and type are used to identify an atom.
+-}
+RULE "specialized atoms (src)" : in;source;sub |- (left;left~ /\ src;sub;src~);in;source
+MEANING "If a source atom is in a relation, its generalization is in the generalized relation as well."
+
+PURPOSE RULE "specialized atoms (tgt)"
+{+The value and type are used to identify an atom.
+-}
+RULE "specialized atoms (tgt)" : in;target;sub |- (rght;rght~ /\ tgt;sub;tgt~);in;target
+MEANING "If a target atom is in a relation, its generalization is in the generalized relation as well."
+
+ENDPROCESS
+
+{-
+Edit-functionaliteit en intersectie-types.
+
+De gebruiker van een Ampersand prototype kan in bepaalde gevallen een nieuw atoom maken door de naam van dat atoom in een veld in te vullen.
+Daarbij hoeft zij niet aan te geven tot welk concept dit atoom behoort, omdat de compiler aan elk veld in elke interface precies 1 concept toekent. 
+Het typesysteem zorgt dat dit concept eenduidig bepaald is. En dus hoeft de software van de user interface geen dynamische typetoekenning te doen.
+
+Toch?
+
+Stel ik heb een editbaar veld van het type Limoen, en een ander editbaar veld van het type Sinaasappel.
+Stel verder dat:
+
+CLASSIFY Limoen ISA Citrus
+CLASSIFY Sinaasappel ISA Citrus
+
+Omdat Citrus een generiek type is van Limoen, wordt het (door de gebruiker ingegeven) atoom l1 in de conceptentabel van Limoen en in de conceptentabel van Citrus opgenomen.
+Omdat Citrus ook een generiek type is van Sinaasappel, kan de gebruiker hetzelfde atoom l1 gebruiken om een sinaasappel te maken. Op vergelijkbare wijze wordt dit atoom opgenomen in de conceptentabel van Sinaasappel en van Citrus.
+Omdat l1 als sleutelveld in Citrus wordt gebruikt, zijn de limoen l1 en de sinaasappel l1 plotseling elkaars alias geworden.
+En dat mag alleen als er een intersectietype SchizoFruit bestaat, waarvoor CLASSIFY SchizoFruit IS Limoen/\Sinaasappel.
+Ziehier een probleem.
+
+Dit probleem heeft waarneembare consequenties voor de gebruiker.
+Stel je voor dat er een relatie "naam[Citrus*Tekst]" bestaat, waarvan bijvoorbeeld ("l1", "balletje") een element is. Dan geldt zowel voor de sinaasappel als voor de limoen dat de naam van l1 "balletje" is. Er is dus feitelijk sprake van een intersectie-type, zonder dat dat in het script is medegedeeld aan Ampersand.
+
+Dit probleem moet worden opgelost aan de database-kant, omdat we de auteur van de frontend hiermee niet willen lastigvallen. De implementatie zal dus moeten afdwingen dat limoenen en citroenen altijd een verschillende key hebben.
+Dit kan door het toevoegen van de regel:
+RULE type;(sub;sub~ /\ -(sub~;sub));type~ |- -(key;key~)
+-}
+
+ENDCONTEXT
AmpersandData/FormalAmpersand/FormalAmpersand.adl view
@@ -1,7 +1,8 @@ CONTEXT FormalAmpersand IN ENGLISH LATEX
 
 INCLUDE "AST.adl" 
-
+THEMES Plugs, Context, Specialization
+{-
 PURPOSE CONTEXT FormalAmpersand
 {+Formal Ampersand is the specification of Ampersand in Ampersand. It's main purpose is to act as a reference to the language. 
 -}
− AmpersandData/FormalAmpersand/Fspec.adl 
@@ -1,30 +0,0 @@-CONTEXT RAP
-INCLUDE "AST.adl"
-
-PATTERN Image
-imageurl :: Image*URL
-MEANING IN ENGLISH "The location of an image on the Internet."
-KEY Image: Image(PRIMHTML "<img src='", imageurl , PRIMHTML "'>")
-ENDPATTERN
-
-PATTERN Conceptual
-ptpic::Pattern*Image[UNI]
-MEANING IN ENGLISH "A conceptual diagram for a pattern."
-cptpic::Concept*Image[UNI]
-MEANING IN ENGLISH "A conceptual diagram for a concept."
-rrpic::Rule*Image[UNI]
-MEANING IN ENGLISH "A conceptual diagram for a rule."
-ENDPATTERN
-
-PATTERN RuleEnforcement
-SPEC Violation ISA PairID
-rrviols::Rule*Violation
-MEANING IN ENGLISH "The violations of a rule."
-ENDPATTERN
-
-PATTERN Misc
-CONCEPT PragmaSentence "An example sentence using the pragma of a relation declaration." TYPE "Blob"
-decexample :: Declaration * PragmaSentence
-MEANING IN ENGLISH "An example sentence using the pragma of a relation."
-ENDPATTERN
-ENDCONTEXT
+ AmpersandData/FormalAmpersand/Generics.adl view
@@ -0,0 +1,245 @@+CONTEXT Generics IN ENGLISH LATEX
+PURPOSE CONTEXT Generics
+{+This context specifies the administration that currrently is, and in future will have been, the contents of GENERICS.PHP-}
+
+CONCEPT MySQLQuery "" TYPE "Text"
+
+
+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'
+RELATION contextName[Context*ContextName] [UNI,TOT]   -- e.g. 'GRCengine';
+RELATION dbName[Context*DatabaseName] [UNI,TOT]   -- e.g. 'GRCengine';
+
+-- HJO20150206 @Rieks: Willen we hier nog iets met signalTableName, isDev, autoRefreshInterval?
+
+--! To be done !--
+--RELATION allSpecializations[CONTEXT*...] = // transitive, so including specializations of specializations
+--  array
+--    ();
+
+--[Relations]--
+--IDENT Relations: Relation(name,srcConcept,tgtConcept,allRelations~) -- the name of the relation must be unique; it is therefor not the same as a RAP:Declaration.
+RELATION allRelations[Context*Relation] [SUR,INJ] -- generics.php:$allRelations
+MEANING "Every relation belongs to a Context" -- For now, we assume there is one Context. 
+RELATION name[Relation*RelationName] [UNI,TOT]
+MEANING "Every relation has a name by which it can be referenced within its Context(s)."
+RELATION srcConcept[Relation*Concept] [UNI,TOT]
+MEANING "Every relation has one source Concept"
+RELATION tgtConcept[Relation*Concept] [UNI,TOT]
+MEANING "Every relation has one target Concept"
+RELATION table[Relation*DBTable] [UNI,TOT]
+MEANING "The population of a relation is stored in one database-table."
+RELATION srcCol[Relation*DBTableColumn] [UNI,TOT]
+MEANING "The source atoms of the population of a relation are stored in a database column"
+RELATION tgtCol[Relation*DBTableColumn] [UNI,TOT]
+MEANING "The target atoms of the population of a relation are stored in a database column"
+RELATION affectedInvConjunctIds[Relation*ConjunctID]
+MEANING "When a pair in a relation is edited (created, updated or deleted), an (invariant) conjunct may be affected"
+RELATION affectedSigConjunctIds[Relation*ConjunctID]
+MEANING "When a pair in a relation is edited (created, updated or deleted), a (signal) conjunct may be affected"
+
+--[Concepts]--
+RELATION allConcepts[Context*Concept] [SUR,INJ]
+-- Aanname: De smerige id van een Concept is gelijk aan de naam van dat Concept.
+RELATION name[Concept*ConceptName][TOT,UNI] 
+RELATION affectedInvConjunctIds[Concept*ConjunctID]
+MEANING "When an atom in a concept is edited (created, updated or deleted), a (invariant) conjunct may be affected"
+RELATION affectedSigConjunctIds[Concept*ConjunctID]
+MEANING "When an atom in a concept is edited (created, updated or deleted), a (signal) conjunct may be affected"
+RELATION conceptTableFields[Concept*TableColumn] [TOT] -- alleen 'ONE' overtreedt de TOTaliteit hier, maar ONE gaat er toch uit.
+MEANING "the database-table column of the concept"
+--[ConceptTables]--
+--MEANING "A ConceptTable is associated with a database-table"
+-- cols[ConceptTable*DBTableColumn] [TOT]
+--MEANING "A ConceptTable is associated with at least one database-table column"
+
+
+--[TableColumnInfo]--  -- HJO: Ik heb hier bewust moeten afwijken van huidige Generics.php, omdat er een concept tussen zit
+RELATION tableInfo[Context*DBTable] [SUR,INJ]  
+RELATION columninfo[DBTable*TableColumn] [SUR,INJ]
+RELATION concept[TableColumn*Concept] [UNI,TOT] -- name of concept in a column of a (broad) table
+RELATION unique[TableColumn*BOOLEAN] [UNI,TOT] -- is this column unique? ('true' or 'false')
+RELATION null[TableColumn*BOOLEAN] [UNI,TOT] -- can this column be 'NULL'? ('true' or 'false')
+
+
+--[Rules]--
+--IDENT Rules: Rule(ruleContext,ruleID)
+RELATION allRules[Context*Rule] [SUR,INJ] -- Rule is part of context
+RELATION name[Rule*RuleID] [UNI,TOT] -- e.g. 'ASY bfOUprop::BusinessFunction*BusinessFunction'
+RELATION ruleAdl[Rule*Adl] [UNI,TOT] -- e.g. 'bfOUprop~ /\\ bfOUprop |- I[BusinessFunction]'
+RELATION origin[Rule*Origin] [TOT] -- e.g. 'line 367:10, file "C:\\\\Ampersand\\\\Workspace\\\\NRM\\\\NRM-BasicProcesses.adl"'
+RELATION meaning[Rule*Meaning] -- e.g. 'bfOUprop[BusinessFunction] is antisymmetric'
+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 conjunctIds[Rule*ConjunctID] -- e.g. 'conj_159'
+RELATION pairView[Rule*PairView] -- e.g. 
+--                  array
+--                    ( array ( 'segmentType' => 'Text', 'Text' => '{EX} DelPair;rliAcceptableRiskLevel;RLI;')
+--                    , array ( 'segmentType' => 'Exp'
+--                            , 'srcOrTgt' => 'Src'
+--                            , 'expTgt' => 'RLI'
+--                            , 'expSQL' =>
+--                                '/* I[RLI] */
+--                                   SELECT `RLI` AS `src`, `RLI` AS `tgt`
+--                                   FROM `RLI`
+--                                   WHERE `RLI` IS NOT NULL'
+--                            )
+--                    , array ( 'segmentType' => 'Text', 'Text' => ';Risk;')
+--                    , array ( 'segmentType' => 'Exp'
+--                            , 'srcOrTgt' => 'Tgt'
+--                            , 'expTgt' => 'Risk'
+--                            , 'expSQL' =>
+--                                '/* I[Risk] */
+--                                   SELECT `Risk` AS `src`, `Risk` AS `tgt`
+--                                   FROM `Risk`
+--                                   WHERE `Risk` IS NOT NULL'
+--                            )
+--                    )
+--              )
+RELATION segment[PairView*PairViewSegment] [SUR,INJ]
+RELATION sequenceNr[PairViewSegment*Int] [UNI,TOT]
+RELATION segmentType[PairViewSegment*PairViewSegmentType]  [UNI,TOT]  -- 'Text' or 'Exp'
+RELATION text[PairViewSegment*String] [UNI] -- IFF segmentType == 'Text'
+RELATION srcOrTgt[PairViewSegment*SourceOrTarget] [UNI] -- 'Src' or 'Tgt'. -- IFF SegmentType == 'Exp'
+RELATION expTgt[PairViewSegment*Concept] [UNI] -- IFF SegmentType == 'Exp'
+RELATION expSQL[PairViewSegment*MySQLQuery] [UNI] -- IFF SegmentType == 'Exp'
+
+
+
+--[Conjuncts]--
+RELATION allConjuncts[Context*Conjunct] [SUR,INJ]
+RELATION signalRuleNames[Conjunct*Rule] -- e.g. 'Activation of Managed BFControls' -- this is a signal rule
+RELATION invariantRuleNames[Conjunct*Rule] -- similar, for invariant rules.
+RELATION violationsSQL[Conjunct*MySQLQuery] -- e.g. '/* case: (EIsc lst\\\'@(_:_:_))
+--                                       nhIsDashboard /\\\\ -I[NormHierarchy] ([NormHierarchy*NormHierarchy]) */
+--                                    SELECT DISTINCT isect0.`NormHierarchy` AS `src`, isect0.`tgt_nhIsDashboard` AS `tgt`
+--                                    FROM ( SELECT `NormHierarchy`, `tgt_nhIsDashboard`
+--                                           FROM `NormHierarchy` WHERE `NormHierarchy` IS NOT NULL  AND  `tgt_nhIsDashboard` IS NOT NULL) AS isect0
+--                                    WHERE isect0.NormHierarchy <> isect0.`tgt_nhIsDashboard` AND isect0.NormHierarchy IS NOT NULL AND isect0.`tgt_nhIsDashboard` IS NOT NULL'
+
+--[Roles]--
+
+RELATION allRoles[Context*Role] [SUR,INJ]
+RELATION name[Role*RoleName] [UNI,TOT]
+RELATION maintains[Role*Rule] -- e.g. ("ExecEngine", "Activeren van rollen") (was "ruleNames")
+
+--[
+--//RELATION generics_allViews is sorted from spec to gen such that the first match for a concept will be the most specific (e.g. see DatabaseUtils.getView()).
+--RELATION generics_allViews =
+--  array
+--    (   array ( 'label' => 'OrgUnits'
+--              , 'concept' => 'OrgUnit'
+--              , 'segments' =>
+--                  array
+--                    ( array ( 'segmentType' => 'Exp'
+--                            , 'label' => '1' // view exp: ouID
+--                            , 'expSQL' =>
+--                                'SELECT DISTINCT `OrgUnit` AS `src`, `tgt_ouID` AS `tgt`
+--                                 FROM `OrgUnit`
+--                                 WHERE `OrgUnit` IS NOT NULL AND `tgt_ouID` IS NOT NULL'
+--                            )
+--                    )
+--              )
+--    ,   array ( 'label' => 'Person'
+--              , 'concept' => 'Person'
+--              , 'segments' =>
+--                  array
+--                    ( array ( 'segmentType' => 'Exp'
+--                            , 'label' => '1' // view exp: personFirstName
+--                            , 'expSQL' =>
+--                                'SELECT DISTINCT `Person` AS `src`, `tgt_personFirstName` AS `tgt`
+--                                 FROM `Person`
+--                                 WHERE `Person` IS NOT NULL AND `tgt_personFirstName` IS NOT NULL'
+--                            )
+--                    , array ( 'segmentType' => 'Text', 'Text' => ' ')
+--                    , array ( 'segmentType' => 'Exp'
+--                            , 'label' => '3' // view exp: personLastName
+--                            , 'expSQL' =>
+--                                'SELECT DISTINCT `Person` AS `src`, `tgt_personLastName` AS `tgt`
+--                                 FROM `Person`
+--                                 WHERE `Person` IS NOT NULL AND `tgt_personLastName` IS NOT NULL'
+--                            )
+--                    )
+--              )
+
+--[InterfaceObjects]--
+--RELATION generics_allInterfaceObjects =
+--  array
+--    ( // Top-level interface RLI for all roles:
+--      'RLI' => 
+--        array ( 'name' => 'RLI'
+--              // Normalized interface expression (== expressionSQL): I[RLI]
+--              , 'interfaceRoles' => array ()
+--              , 'invConjunctIds' => array ()
+--              , 'sigConjunctIds' => array ()
+--              , 'relation' => '' // this interface expression does not represent a declared relation
+--              , 'relationIsFlipped' => ''
+--              , 'srcConcept' => 'RLI'
+--              , 'tgtConcept' => 'RLI'
+--              , 'expressionSQL' => '/* I[RLI] */
+--                                      SELECT `RLI` AS `src`, `RLI` AS `tgt`
+--                                      FROM `RLI`
+--                                      WHERE `RLI` IS NOT NULL'
+--              // Box
+--              , 'boxSubInterfaces' =>
+--                  array
+--                    ( array ( 'name' => 'Risk'
+--                            // Normalized interface expression (== expressionSQL): rliRisk
+--                            , 'relation' => 'rel_rliRisk_RLI_Risk' // this interface represents a declared relation
+--                            , 'relationIsEditable' => false
+--                            , 'relationIsFlipped' => False
+--                            , 'min' => 'Zero'
+--                            , 'max' => 'One'
+--                            , 'srcConcept' => 'RLI'
+--                            , 'tgtConcept' => 'Risk'
+--                            , 'expressionSQL' => 'SELECT DISTINCT `RLI` AS `src`, `tgt_rliRisk` AS `tgt`
+--                                                  FROM `RLI`
+--                                                  WHERE `RLI` IS NOT NULL AND `tgt_rliRisk` IS NOT NULL'
+--                            // No subinterfaces
+--                            )
+--                    , array ( 'name' => 'Kans'
+--                            // Normalized interface expression (== expressionSQL): rliLikelihood
+--                            , 'relation' => 'rel_rliLikelihood_RLI_Likelihood' // this interface represents a declared relation
+--                            , 'relationIsEditable' => false
+--                            , 'relationIsFlipped' => False
+--                            , 'min' => 'Zero'
+--                            , 'max' => 'One'
+--                            , 'srcConcept' => 'RLI'
+--                            , 'tgtConcept' => 'Likelihood'
+--                            , 'expressionSQL' => 'SELECT DISTINCT `RLI` AS `src`, `tgt_rliLikelihood` AS `tgt`
+--                                                  FROM `RLI`
+--                                                  WHERE `RLI` IS NOT NULL AND `tgt_rliLikelihood` IS NOT NULL'
+--                            // No subinterfaces
+--                            )
+--                    , array ( 'name' => 'Impact'
+--                            // Normalized interface expression (== expressionSQL): rliImpact
+--                            , 'relation' => 'rel_rliImpact_RLI_Impact' // this interface represents a declared relation
+--                            , 'relationIsEditable' => false
+--                            , 'relationIsFlipped' => False
+--                            , 'min' => 'Zero'
+--                            , 'max' => 'One'
+--                            , 'srcConcept' => 'RLI'
+--                            , 'tgtConcept' => 'Impact'
+--                            , 'expressionSQL' => 'SELECT DISTINCT `RLI` AS `src`, `tgt_rliImpact` AS `tgt`
+--                                                  FROM `RLI`
+--                                                  WHERE `RLI` IS NOT NULL AND `tgt_rliImpact` IS NOT NULL'
+--                            // No subinterfaces
+--                            )
+--                    , array ( 'name' => 'A-lvl'
+--                            // Normalized interface expression (== expressionSQL): rliAcceptableRiskLevel
+--                            , 'relation' => 'rel_rliAcceptableRiskLevel_RLI_Risk' // this interface represents a declared relation
+--                            , 'relationIsEditable' => false
+--                            , 'relationIsFlipped' => False
+--                            , 'min' => 'Zero'
+--                            , 'max' => 'One'
+--                            , 'srcConcept' => 'RLI'
+--                            , 'tgtConcept' => 'Risk'
+--                            , 'expressionSQL' => 'SELECT DISTINCT `RLI` AS `src`, `tgt_rliAcceptableRiskLevel` AS `tgt`
+--                                                  FROM `RLI`
+--                                                  WHERE `RLI` IS NOT NULL AND `tgt_rliAcceptableRiskLevel` IS NOT NULL'
+--                            // No subinterfaces
+--                            )
+--                    )
+--              )
+
+ENDCONTEXT
+ AmpersandData/FormalAmpersand/IS.adl view
@@ -0,0 +1,104 @@+CONTEXT RAP IN ENGLISH LATEX
+INCLUDE "ISdocumentation.adl"
+INCLUDE "IS.ifc"
+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 state[Query*State] [UNI,TOT]
+MEANING "Every query operates on a state, in which expressions 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]
+MEANING "When mentioning the result of executing a query, we mean the set of facts that was produced by executing that query."
+RELATION sat[State*Rule]
+MEANING "It makes sense to say that a state satisfies a rule, meaning that the rule is true in that state."
+RELATION pred[State*State] [UNI,IRF]
+MEANING "Each state except the initial state will have a predecessor. Two states that have the same predecessor are the same."
+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
+
+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."
+
+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."
+
+IDENT query : Query(exp, state)
+
+IDENT state : State(pred)
+
+ENDPATTERN
+
+PATTERN "Documentation"
+RELATION meaning[Concept*NatLang]
+MEANING "It makes sense to talk about the meaning of a concept. The meaning is a written statement in natural language."
+RULE conceptHasMeaning : I[Concept] |- meaning;meaning~
+MEANING "Every concept has a meaning"
+
+RELATION purpose[Concept*NatLang]
+MEANING "It makes sense to talk about the purpose of a concept. The purpose is a written statement in natural language."
+RULE conceptHasPurpose : I[Concept] |- purpose;purpose~
+MEANING "Every concept must have a purpose, written in natural language."
+
+RELATION reference[Concept*Reference]
+MEANING "A concept that originates from a written source can be referenced. The link between concept and reference makes it traceable."
+RULE conceptHasReference : I[Concept] |- reference;reference~
+MEANING "Every concept must be traceable to its origin(s)."
+
+RELATION meaning[Relation*NatLang]
+MEANING "It makes sense to talk about the meaning of a relation. The meaning is a written statement in natural language."
+RULE relationHasMeaning : I[Relation] |- meaning;meaning~
+MEANING "Every relation has a meaning"
+
+RELATION purpose[Relation*NatLang]
+MEANING "It makes sense to talk about the purpose of a relation. The purpose is a written statement in natural language."
+RULE relationHasPurpose : I[Relation] |- purpose;purpose~
+MEANING "Every relation must have a purpose, written in natural language."
+
+RELATION reference[Relation*Reference]
+MEANING "A relation that originates from a written source can be referenced. The link between relation and reference makes it traceable."
+RULE relationHasReference : I[Relation] |- reference;reference~
+MEANING "Every relation must be traceable to its origin(s)."
+
+RELATION meaning[Rule*NatLang]
+MEANING "It makes sense to talk about the meaning of a rule. The meaning is a written statement in natural language."
+RULE ruleHasMeaning : I[Rule] |- meaning;meaning~
+MEANING "Every rule has a meaning"
+
+RELATION purpose[Rule*NatLang]
+MEANING "It makes sense to talk about the purpose of a rule. The purpose is a written statement in natural language."
+RULE ruleHasPurpose : I[Rule] |- purpose;purpose~
+MEANING "Every rule must have a purpose, written in natural language."
+
+RELATION reference[Rule*Reference]
+MEANING "A rule that originates from a written source can be referenced. The link between rule and reference makes it traceable."
+RULE ruleHasReference : I[Rule] |- reference;reference~
+MEANING "Every rule must be traceable to its origin(s)."
+ENDPATTERN
+
+PATTERN "Enforcement"
+CONCEPT EnforcementType "Rules can be enforced either by humans or by computers. An enforcement type is used to distinguish between the two."
+CONCEPT RuleEnforcement "A rule can be enforced within a context, which means it is being kept without violations."
+RULE enforcementType : I[EnforcementType] = 'Human' \/ 'Computer'
+RELATION enforcement[RuleEnforcement*EnforcementType] [UNI,TOT]
+MEANING "For each rule enforcement, a way of enforcement is defined."
+RELATION rule[RuleEnforcement*Rule] [TOT]
+MEANING "The rule(s) being enforced are linked to the rule enforcement."
+RELATION valid[RuleEnforcement*Context] [TOT]
+MEANING "We can say that a rule is valid in a context, which means that the rule should not have any violations in that context."
+ENDPATTERN
+
+
+ENDCONTEXT
+ AmpersandData/FormalAmpersand/IS.ifc view
@@ -0,0 +1,15 @@+CONTEXT RAP IN ENGLISH LATEX
+
+INTERFACE ruleOverview : I[ONE]
+BOX [ rules : V[ONE*Rule]
+      BOX [ rule : I
+          , expression : characteristic
+          ]
+    ]
+
+INTERFACE newRule (characteristic, meaning["Rule"*"NatLang"], purpose["Rule"*"NatLang"]): I[Rule]
+BOX [ rule : I
+    , expression : characteristic
+    ]
+
+ENDCONTEXT
+ AmpersandData/FormalAmpersand/IS.pop view
@@ -0,0 +1,33 @@+CONTEXT RAP IN ENGLISH LATEX
+
+POPULATION characteristic[Rule*Expression] CONTAINS    -- [UNI,TOT]
+   [ ("def equivalued", "equivalued = state;state~ /\\ result<>result~")
+   ; ("def sat",        "sat = state~;true;exp;characteristic~"        )
+   ; ("def true",       "true = exp;signature;exp~;equivalued"         )
+   ]
+POPULATION exp[Query*Expression] CONTAINS    -- [UNI,TOT]
+   []
+POPULATION signature[Expression*Expression] CONTAINS    -- [UNI,TOT,RFX,TRN]
+   [ ("true = exp;signature;exp~;equivalued"         , "V[Query*Query]"     )
+   ; ("V[Query*Query]"                               , "V[Query*Query]"     )
+   ; ("V[State*Rule]"                                , "V[State*Rule]"      )
+   ; ("equivalued = state;state~ /\\ result<>result~", "V[Query*Query]"     )
+   ; ("sat = state~;true;exp;characteristic~"        , "V[State*Rule]"      )
+   ]
+POPULATION state[Query*State] CONTAINS    -- [UNI,TOT]
+   []
+POPULATION true[Query*Query] CONTAINS    -- [PROP]
+   []
+POPULATION result[Query*Statement] CONTAINS
+   []
+POPULATION sat[State*Rule] CONTAINS
+   []
+POPULATION pred[State*State] CONTAINS    -- [UNI,IRF]
+   [ ("2", "1")
+   ; ("3", "2")
+   ; ("4", "3")
+   ]
+POPULATION equivalued[Query*Query] CONTAINS    -- [RFX,TRN,ASY]
+   []
+
+ENDCONTEXT
+ AmpersandData/FormalAmpersand/ISdocumentation.adl view
@@ -0,0 +1,210 @@+CONTEXT RAP IN ENGLISH LATEX
+{- This file contains documentation of the information iystems pattern (IS) in LaTeX format.
+   Each concept has its own section, where sections are separated by comments -}
+
+PURPOSE PATTERN "Information Systems"
+{+The purpose of an information system is to support people (called {\em users})
+in a specific domain (called a {\em context})
+by disclosing and maintaining factual information (represented by {\em data}).
+For example, a customer relationship management (CRM) system for ECME Inc.\ should contain factual information, in order to be a reliable tool for people working for ECME.
+Its context is ECME Inc., in particular its customer base.
+Users are undoubtedly employees of ECME Inc., but each customer with access to this information is considered a user just as well.
+
+People use language in order to ask, to command, to state facts and in general to communicate things verbally.
+Since an information system is supposed to contain facts, we take a special interest in affirmative sentences.
+Affirmative sentences are characterized by being either true or false, e.g. ``Last Tuesday, Peter was in Amsterdam.''
+We call this a {\em statement}, and we call a true statement a {\em fact}.
+Thus, we can think of an information system as a device that contains and maintains facts about a particular domain.
+The set of facts that is contained in an information system is called the {\em contents} or {\em population} of that system.
+
+In designing an information system, 
+some definitions are needed to explain how and why users can trust the system.
+For we must keep in mind at all times that ECME Inc.\ (for example) wishes to rely on its CRM-system.
+So to what extent can we be sure that the system tells the truth about ECME's customers?
+-}
+
+PURPOSE CONCEPT Context
+{+The word context is used to delimit scope and provide a single truth within that scope.
+The truth consists of a (possibly infinite) number of true statements about the real world.
+To be precise: in order to provide a single truth, a context must contain only statements, which are true in the ``world out there''.
+If a context contains a mechanism to construct new facts from available facts, it is possible that it actually contains an infinite number of them.
+Consistency is required throughout the context, because an inconsistent system cannot hold any true facts.
+
+So what does it mean to a user, to have a system that contains true statements only?
+Most likely, users will learn to rely on information from that system, because it never lies to them.
+For example, bank customers will rarely doubt the balance shown by their electronic banking system,
+because they experience it to be correct all the time and they know that their bank goes to great lengths to keep it correct.
+Just for the record: there are enough unreliable information systems today.
+Information systems that users have leart to distrust, because it sometimes gives information that is not true in the real world.
+
+Just like in the real world, truth is confined to a context.
+That allows us, for example, to say ``Peter has scored ten hits'', and know that it is true in the context of his sports club, but that it is false in the context of his work as a professional musician.
+Every fact has a scope, e.g. the customer base of ECME Inc.
+
+In practice, a context can be associated with a single application, a group of applications, a company, or anything in which a single truth is required.
+-}
+CONCEPT Context "A context is a scope in which a single truth is defined."
+
+PURPOSE CONCEPT Statement
+{+An information system is limited to uttering affirmative sentences.
+For that purpose we define the word statement:
+-}
+CONCEPT Statement "A statement is an affirmative sentence."
+
+PURPOSE CONCEPT Concept
+{+In a world full of things, we use the word ``concept'' to name and characterize a set of things that are similar.
+We use the concept ``Table'' to denote the set of tables in a context. When asked: which tables are there, we can point at all available tables and conclude that each one is an instance of ``Table''.
+Similarly, we may use the concept ``Number'' to denote things such as 1, 2 or 101.
+Words such as ``Joy'' or ``Peace'' will not be used as a concept, as long as they do not represent a set of things. (Ask: Which joys are there? Which peaces are there?).
+-}
+CONCEPT Concept "A concept is a name to characterize a set of similar things."
+
+PURPOSE CONCEPT Rule
+{+Agreements made by people can be represented by a statement, which must be kept true.
+For example, if we agree to keep the desks in our office clean,
+the statement ``All desks are clean'' should be true all the time.
+Such agreements are known under many different names, such as ``rule'', ``commitment'', ``contract'', etcetera.
+-}
+CONCEPT Rule "A rule is a statement that must be kept true."
+
+PURPOSE CONCEPT State
+{+If an information system is to tell the truth, it must cope with truth that changes over time.
+For example, suppose that ECME's customer John Brown moves to another home.
+The system has to be told that John Brown has a new address, in order to remain a reliable truth-teller.
+So the set of facts contained by an information system must change over time, to keep up with the continuously changing
+truth\footnote{There is much more to be said about truth, for which we refer to the literature on language philosophy.
+For our purposes, we work with the idea that truth requires a context.} in the real world.
+-}
+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
+{+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}.
+-}
+CONCEPT Expression "An expression 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.
+That makes sense, because a statement can be true or false in natural language as well as formal language.
+If it is relevant to say that a statement is made in natural language, we will say so explicitly.
+
+Statements can be obtained from an information system by executing a query.
+Queries are meant to produce statements from the current state of an information system.
+-}
+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 exp[Query*Expression]
+{+Queries exist for the purpose of evaluating an expression 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 state[Query*State]
+{+When talking about the state on which the query has been executed,
+we mean the state that was current on the moment of execution.
+-}
+PURPOSE RELATION true[Query*Query]
+{+In order to define how to compute the truth (by executing queries), we define `true' as a property of queries.
+-}
+PURPOSE RELATION sat[State*Rule]
+{+In order to say that a set of facts is consistent with a rule, we introduce the notion of satisfaction.
+We will say that a state satisfies a rule, to indicate that it is true.
+-}
+PURPOSE RELATION pred[State*State]
+{+If we perceive an information system as a set of states, that changes over time, then it makes sense to talk about the predecessor of a state.
+As time passes by an ever growing sequence of states emerges.
+In order to obtain a linear (acyclic) notion of time, we must define that two states are the same if their predecessors are the same, and a state cannot be its own predecessor.
+-}
+PURPOSE RELATION result[Query*Statement]
+{+Every query results in a number of facts.
+-}
+PURPOSE RELATION equivalued[Query*Query]
+{+It makes sense to say that two queries are called equivalued.
+-}
+
+PURPOSE RULE "def equivalued"
+{+In order to define true queries, we must introduce the word equivalued.
+-}
+
+PURPOSE RULE "def sat"
+{+The meaning of the word satisfy is given by:
+-}
+
+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)}.
+-}
+
+--PURPOSE PATTERN "Documentation"
+--{+Documentation is required for human understanding of rules.
+--It explains why things exist and how things are expressed in natural language.
+---}
+PURPOSE RELATION meaning[Concept*NatLang]
+{+The meaning of a concept is described in natural language, because it must be discussed with business stakeholders.
+In the end, they must vouch for the correct wording of that concept.
+-}
+PURPOSE RELATION purpose[Concept*NatLang]
+{+The purpose of a concept is described to document why it exists.
+-}
+PURPOSE RELATION reference[Concept*Reference]
+{+The reference of a concept is required in order to know where that concept comes from.
+That helps to judge the relevance of that particular concept.
+-}
+PURPOSE RELATION meaning[Relation*NatLang]
+{+The meaning of a relation is described in natural language, because it must be discussed with business stakeholders.
+In the end, they must vouch for the correct wording of that relation.
+-}
+PURPOSE RELATION purpose[Relation*NatLang]
+{+The purpose of a relation is described to document why it exists.
+-}
+PURPOSE RELATION reference[Relation*Reference]
+{+The reference of a relation is required in order to know where that relation comes from.
+That helps to get consensus about the correct wording of statements made from this relation.
+-}
+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.
+-}
+PURPOSE RELATION purpose[Rule*NatLang]
+{+The purpose of a rule is described to document why it exists.
+-}
+PURPOSE RELATION reference[Rule*Reference]
+{+The reference of a rule is required in order to know where that rule comes from.
+That helps to judge the importance of following that particular rule.
+-}
+
+
+PURPOSE CONCEPT RuleEnforcement
+{+A rule enforcement is defined for the purpose of describing when a rule takes effect and in which context it does so.
+Only rules that are enforced have a noticeable effect in the context in which it is enforced.
+A rule that is enforced by a computer is enforced immediately.
+Immediate enforcement means that the computer ensures that the rule
+remains satisfied all the time, no matter what happens.
+Attempts to violate the rule will lead to appropriate error messages, but will not have any effect on the state of the system.
+A rule that is enforced by man may be violated temporarily, as long as needed for a person to bring the system in a state that satisfies the rule.
+That is called deferred enforcement, which means that people must ensure that the rule is satisfied.
+To help those people, the computer will signal them to let them know there is work to be done.
+Without enforcement, a rule stays without consequence for the business process at hand.
+That can be useful when a rule must become effective at a particular moment in time.
+It is also useful to describe laws of nature, for purposes of automated reasoning.
+-}
+PURPOSE CONCEPT EnforcementType
+{+We distinguish two types of enforcement: human and machine.
+Enforcement by machine is immediate; human enforcement is deferred and accompanied by appropriate signalling.
+-}
+
+PURPOSE RELATION enforcement[RuleEnforcement*EnforcementType]
+{+The enforcement of a rule is done either by human interaction or fully automated by a machine.
+In order to make this distinction, we must be able to tell the type of enforcement for each rule enforcement.
+-}
+
+PURPOSE RELATION rule[RuleEnforcement*Rule]
+{+To discuss the enforcement of a rule implies that for every rule enforcement, we know which rule we are talking about.
+-}
+
+ENDCONTEXT
AmpersandData/FormalAmpersand/RAP.adl view
@@ -1,4 +1,4 @@-CONTEXT RAP 
+CONTEXT RAP IN ENGLISH
 -- HJO, 20140212: Begin gemaakt met het 'ontmantelen' van dit bestand. Het is de bedoeling om het te splitsen in het 'core' deel van Ampersand (FormalAmpersand.adl) en het overige deel, dat nodig is voor de Repository tool (ADLTool.adl)
 
 INCLUDE "student_AST_interfaces.adl"
− AmpersandData/FormalAmpersand/admin_interfaces.adl 
@@ -1,20 +0,0 @@-CONTEXT Atlas
-INTERFACE "Files" FOR Admin: I[ONE]
-BOX ["loaded files": V[ONE*File];(sourcefile~;sourcefile \/ parseerror;parseerror~ \/ typeerror;typeerror~)
-    BOX ["name":filename
-        ,"dir":filepath
-        ,"created at":filetime
-        ,"first loaded with":firstloadedwith
-        ,"syntax error":parseerror BOX [act:pe_action,pos:pe_position,exp:pe_expecting]
-        ,"type error":typeerror BOX [msg:te_message]
-        ,"context" : sourcefile~ 
-        BOX ["name":ctxnm
-            ,"source files":(sourcefile \/ includes);filename
-            ,"number of rules":countrules
-            ,"number of declarations":countdecls
-            ,"number of concepts":countcpts] 
-    ]
-]
-ENDCONTEXT
-
-
AmpersandData/FormalAmpersand/student_AST_interfaces.adl view
@@ -1,4 +1,4 @@-CONTEXT RAP
+CONTEXT RAP IN ENGLISH
 INTERFACE "Atlas (Play)" FOR Student: I[ONE]
 BOX ["CONTEXT" : V[ONE*Context] BOX ["name":ctxnm,"number of RULEs":countrules,"number of relations":countdecls,"number of concepts":countcpts] 
     ,"PATTERNs" : V[ONE*Context];ctxpats
@@ -29,7 +29,7 @@     , "RULEs without MEANING": V[ONE*Rule];(-(rrmean;rrmean~) /\ I) -- -(V[ONE*Blob];rrmean~)
     , "populated relations": V[ONE*PairID];decpopu~
     , "unpopulated relations": V[ONE*Declaration];(-(decpopu;decpopu~) /\ I) -- -(V[ONE*PairID];decpopu~)
---INCORRECT    , "relations not in any RULE (provided that a RULE exists)": V[ONE*Rule];(I[Rule] /\ -I[PropertyRule]);-(rrexp;rels;reldcl)
+--INCORRECT    , "relations not in any RULE (provided that a RULE exists)": V[ONE*Rule];(I[Rule] /\ -I[PropertyRule]);-(rrexp;relsMentionedIn;reldcl)
     ]
 
 INTERFACE "Syntax error" FOR Student: I[ParseError]
@@ -170,7 +170,7 @@     ,"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 \/ trg))~
-    ,"used in RULEs": (relsgn;(src \/ trg))~;(rrexp;rels)~;(I[Rule] /\ -I[PropertyRule])
+    ,"used in RULEs": (relsgn;(src \/ trg))~;(rrexp;relsMentionedIn)~;(I[Rule] /\ -I[PropertyRule])
     ,"diagram" : cptpic
     ]
 INTERFACE "Atom"(cptos) FOR Student: I[Atom];atomvalue~
@@ -184,14 +184,14 @@     ,"properties" :decprps;declaredthrough
     ,"from PATTERN" :ptdcs~
     ,"POPULATION" :decpopu BOX ["source":left , "target":right] --select existing atoms only!
-    ,"used in RULEs": (rrexp;rels;reldcl)~;(I[Rule] /\ -I[PropertyRule])
+    ,"used in RULEs": (rrexp;relsMentionedIn;reldcl)~;(I[Rule] /\ -I[PropertyRule])
     ]
 INTERFACE "RULE" FOR Student: I[Rule]
 BOX ["PURPOSEs" :rrpurpose
     ,"MEANING" :rrmean
     ,"name" :rrnm
     ,"assertion" :rrexp
-    ,"uses":rrexp;rels BOX ["relation":reldcl, "with properties": reldcl;decprps;declaredthrough, "source":relsgn;src, "target":relsgn;trg]
+    ,"uses":rrexp;relsMentionedIn BOX ["relation":reldcl, "with properties": reldcl;decprps;declaredthrough, "source":relsgn;src, "target":relsgn;trg]
     ,"in PATTERN":ptrls~
     ,"diagram" : rrpic
     ]
− README.txt 
Setup.hs view
@@ -1,80 +1,206 @@-{-# OPTIONS_GHC -Wall #-}  -import Distribution.Simple-import Distribution.Simple.LocalBuildInfo-import Distribution.Simple.Setup-import Distribution.PackageDescription---import System.Time-import System.Process-import System.IO-import Control.Exception-import Data.List-import Data.Time.Clock-import Data.Time.Format-import System.Locale--main :: IO ()-main = defaultMainWithHooks (simpleUserHooks { buildHook = generateBuildInfoHook } )---- Before each build, generate a BuildInfo_Generated module that exports the project version from cabal,--- the current svn revision number and the build time.------ Note that in order for this Setup.hs to be used by cabal, the build-type should be Custom.--generateBuildInfoHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> BuildFlags -> IO ()-generateBuildInfoHook pd  lbi uh bf = - do { let cabalVersionStr = intercalate "." (map show . versionBranch . pkgVersion . package $ pd)--    ; svnRevisionStr <- do { r <- catch getSVNRevisionStr myHandler -                           ; if r == "" -                             then noSVNRevisionStr-                             else return r-                           }-    ; clockTime <- getCurrentTime -    ; let buildTimeStr = formatTime defaultTimeLocale "%d-%b-%y %H:%M:%S %Z" clockTime-    ; writeFile "src/lib/DatabaseDesign/Ampersand/Basics/BuildInfo_Generated.hs" $-        buildInfoModule cabalVersionStr svnRevisionStr buildTimeStr--    ; (buildHook simpleUserHooks) pd lbi uh bf -- start the build-    }- where myHandler :: IOException -> IO String-       myHandler err = do { print err-                          ; noSVNRevisionStr-                          }--buildInfoModule :: String -> String -> String -> String-buildInfoModule cabalVersion revision time = unlines- [ "module DatabaseDesign.Ampersand.Basics.BuildInfo_Generated (cabalVersionStr, svnRevisionStr, buildTimeStr) where"- , ""- , "-- This module is generated automatically by Setup.hs before building. Do not edit!"- , ""- , "{-# NOINLINE cabalVersionStr #-}" -- disable inlining to prevent recompilation of dependent modules on each build- , "cabalVersionStr :: String"- , "cabalVersionStr = \"" ++ cabalVersion ++ "\""- , ""- , "{-# NOINLINE svnRevisionStr #-}"- , "svnRevisionStr :: String"- , "svnRevisionStr = \"" ++ revision ++ "\""- , ""- , "{-# NOINLINE buildTimeStr #-}"- , "buildTimeStr :: String"- , "buildTimeStr = \"" ++ time ++ "\""- ]--getSVNRevisionStr :: IO String-getSVNRevisionStr = - do { (inh,outh,errh,proch) <- runInteractiveProcess "svnversion" ["."] Nothing Nothing-    ; hClose inh-    ; hClose errh-    ; version <- hGetContents outh-    ; _ <- seq version $ waitForProcess proch-    ; return (unwords . lines $ version)-    }--noSVNRevisionStr :: IO String-noSVNRevisionStr =- do { putStrLn "\n\n\nWARNING: Execution of 'svnversion' command failed."-    ; putStrLn $ "BuildInfo_Generated.hs will not contain revision information, and therefore\nneither will fatal error messages.\n"++-                 "Please find out why the command  'svnversion .' does not work.\n"++-                 "Otherwise (re-)install a subversion client (e.g. 'Slik SVN') that supports\nthe command-line 'svnversion'-command without interfering with your other SVN-clients.\n"-    ; return "??"-    }+{-# OPTIONS_GHC -Wall #-}  
+import Distribution.Simple
+import Distribution.Simple.LocalBuildInfo
+import Distribution.Simple.Setup
+import Distribution.PackageDescription
+import System.Process
+import System.Exit
+import Control.Exception
+import Data.List
+import Data.Either
+import Data.Char
+import qualified Data.ByteString.Char8 as BS
+import Data.Time.Clock
+import Data.Time.Format
+import Data.Time.LocalTime
+import System.Directory
+import System.FilePath
+import System.IO
+import System.Locale
+
+
+main :: IO ()
+main = defaultMainWithHooks (simpleUserHooks { buildHook = generateBuildInfoHook } )
+
+-- Before each build, generate a BuildInfo_Generated module that exports the project version from cabal,
+-- the current svn revision number and the build time.
+--
+-- Note that in order for this Setup.hs to be used by cabal, the build-type should be Custom.
+
+generateBuildInfoHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> BuildFlags -> IO ()
+generateBuildInfoHook pd  lbi uh bf = 
+ do { let cabalVersionStr = intercalate "." (map show . versionBranch . pkgVersion . package $ pd)
+
+    ; gitInfoStr <- getGitInfoStr
+    ; clockTime <- getCurrentTime >>= utcToLocalZonedTime 
+    ; let buildTimeStr = formatTime defaultTimeLocale "%d-%b-%y %H:%M:%S %Z" clockTime
+    ; writeFile (pathFromModuleName buildInfoModuleName) $
+        buildInfoModule cabalVersionStr gitInfoStr buildTimeStr
+    
+    ; generateStaticFileModule 
+
+    ; putStrLn ""
+    ; (buildHook simpleUserHooks) pd lbi uh bf -- start the build
+    }
+
+buildInfoModuleName :: String
+buildInfoModuleName = "Database.Design.Ampersand.Basics.BuildInfo_Generated"
+
+buildInfoModule :: String -> String -> String -> String
+buildInfoModule cabalVersion gitInfo time = unlines
+  [ "module "++buildInfoModuleName++"(cabalVersionStr, gitInfoStr, buildTimeStr) where" 
+  , ""
+  , "-- This module is generated automatically by Setup.hs before building. Do not edit!"
+  , ""
+  -- Workaround: break pragma start { - #, since it upsets Eclipse :-( 
+  , "{-"++"# NOINLINE cabalVersionStr #-}" -- disable inlining to prevent recompilation of dependent modules on each build
+  , "cabalVersionStr :: String"
+  , "cabalVersionStr = \"" ++ cabalVersion ++ "\""
+  , ""
+  , "{-"++"# NOINLINE gitInfoStr #-}"
+  , "gitInfoStr :: String"
+  , "gitInfoStr = \"" ++ gitInfo ++ "\""
+  , ""
+  , "{-"++"# NOINLINE buildTimeStr #-}"
+  , "buildTimeStr :: String"
+  , "buildTimeStr = \"" ++ time ++ "\""
+  , ""
+  ]
+    
+getGitInfoStr :: IO String
+getGitInfoStr = 
+ do { eSHA <- readProcessEither "git" ["rev-parse", "--short", "HEAD"] ""
+    ; eBranch <- readProcessEither "git" ["rev-parse", "--abbrev-ref", "HEAD"] ""
+    ; (exitCode, _, _) <- readProcessWithExitCode "git" ["diff", "--quiet"] ""
+    ; let isDirty = exitCode /= ExitSuccess -- exit code signals whether branch is dirty
+    ; case (eSHA, eBranch) of
+        (Right sha, Right branch) -> 
+         return $ strip branch ++ ":" ++ strip sha ++ (if isDirty then "*" else "")
+        _ ->
+         do { mapM_ print $ lefts [eSHA, eBranch] -- errors during git execution
+            ; warnNoCommitInfo
+            }
+    } `catch` \err ->  -- git failed to execute
+         do { print (err :: IOException)
+            ; warnNoCommitInfo
+            }
+ where strip str = reverse . dropWhile isSpace . reverse $ str
+
+       readProcessEither :: String -> [String] -> String -> IO (Either String String)
+       readProcessEither cmd args stdinStr = 
+        do { (exitCode,stdoutStr,stderrStr) <- readProcessWithExitCode cmd args stdinStr
+           ; case exitCode of
+               ExitSuccess   -> return $ Right stdoutStr
+               ExitFailure _ -> return $ Left stderrStr
+           }
+ 
+warnNoCommitInfo :: IO String
+warnNoCommitInfo =
+ do { putStrLn "\n\n\nWARNING: Execution of 'git' command failed."
+    ; putStrLn $ "BuildInfo_Generated.hs will not contain revision information, and therefore\nneither will fatal error messages.\n"++
+                 "Please check your installation\n"
+    ; return "no git info"
+    }
+
+
+{- For each file in the directory ampersand/static, we generate a StaticFile value,
+   which contains the information necessary for Ampersand to create the file at run-time.  
+   
+   To prevent compiling the generated module (which can get rather big) on each build, we compare the contents
+   the file we are about to generate with the contents of the already generated file and only write if there is a difference.
+   This complicates the build process, but seems the only way to handle large amounts of diverse static
+   files, until Cabal's data-files mechanism is updated to allow fully recursive patterns.
+   
+   TODO: creating the entire file may be somewhat time-consuming, if this is a problem on slower machines, we may want to cache the
+         timestamps+names in a file and only generate when there is a change. (using the timestamps from the previously
+         generated module file is not an option, as a Haskell read on that file is extremely slow)
+-}
+
+staticFileModuleName :: String
+staticFileModuleName = "Database.Design.Ampersand.Prototype.StaticFiles_Generated"
+
+generateStaticFileModule :: IO ()
+generateStaticFileModule =
+ do { previousModuleContents <- getPreviousStaticFileModuleContents sfModulePath
+    ; currentModuleContents <- readAllStaticFiles
+    
+    -- simply compare file contents to see if we need to write (to prevent re-compilation)
+    ; if previousModuleContents == currentModuleContents
+      then
+        putStrLn $ "Static files unchanged, no need to update "++sfModulePath
+      else
+       do { putStrLn $ "Static files have changed, updating "++sfModulePath
+          ; writeFile sfModulePath currentModuleContents
+          }
+    }
+ where sfModulePath = pathFromModuleName staticFileModuleName
+       
+getPreviousStaticFileModuleContents :: String -> IO String
+getPreviousStaticFileModuleContents sfModulePath = 
+  (withFile sfModulePath ReadMode $ \h ->
+   do { str <- hGetContents h
+      --; putStrLn $ "reading old file"      
+      ; length str `seq` return () -- lazy IO is :-(
+      --; putStrLn $ "Done"      
+      ; return str
+      }) `catch` \err ->  -- old generated module exists, but we can't read the file or read the contents
+   do { putStrLn $ "\n\n\nERROR: Cannot read previously generated " ++ sfModulePath ++ ":\n" ++
+                   show (err :: SomeException) ++ "\nTry to rebuild Ampersand, and if the error persist, please report this as a bug.\n"
+      ; return []
+      }
+        
+-- Scan static file directory and collect all files from oldFrontend and newFrontend
+readAllStaticFiles :: IO String
+readAllStaticFiles = 
+  do { oldStaticFiles <- readStaticFiles False "static/oldFrontend" "."
+     ; newStaticFiles <- readStaticFiles True  "static/newFrontend" "."
+     ; return $ mkStaticFileModule $ oldStaticFiles ++ newStaticFiles
+     }
+  
+readStaticFiles :: Bool -> FilePath -> FilePath -> IO [String]
+readStaticFiles isNewFrontend base fileOrDirPth = 
+  do { let path = combine base fileOrDirPth
+     ; isDir <- doesDirectoryExist path
+     ; if isDir then 
+        do { fOrDs <- getProperDirectoryContents path
+           ; fmap concat $ mapM (\fOrD -> readStaticFiles isNewFrontend base (combine fileOrDirPth fOrD)) fOrDs
+           }
+       else
+        do { timeStamp <- getModificationTime path
+           ; fileContents <- BS.readFile path 
+           ; return [ "SF "++show isNewFrontend++" "++show fileOrDirPth++" "++utcToEpochTime timeStamp ++
+                             " {-"++show timeStamp++" -} "++show (BS.unpack fileContents)
+                    ]
+           }
+     }
+  where utcToEpochTime :: UTCTime -> String
+        utcToEpochTime utcTime = formatTime defaultTimeLocale "%s" utcTime
+
+mkStaticFileModule :: [String] -> String
+mkStaticFileModule sfDeclStrs =
+  unlines staticFileModuleHeader ++ 
+  "  [ " ++ intercalate "\n  , " sfDeclStrs ++ "\n" ++
+  "  ]\n"
+           
+staticFileModuleHeader :: [String]
+staticFileModuleHeader =
+  [ "module "++staticFileModuleName++" where"
+  , ""
+  , "data StaticFile = SF { isNewFrontend     :: Bool"
+  , "                     , filePath          :: FilePath -- relative path, including extension"
+  , "                     , timeStamp         :: Integer  -- unix epoch time"
+  , "                     , contentString     :: String"
+  , "                     }"
+  , ""
+  , "{-"++"# NOINLINE allStaticFiles #-}" -- Workaround: break pragma start { - #, since it upsets Eclipse :-( 
+  , "allStaticFiles :: [StaticFile]"
+  , "allStaticFiles ="
+  ]
+
+          
+          
+getProperDirectoryContents :: FilePath -> IO [String]
+getProperDirectoryContents pth = fmap (filter (`notElem` [".","..",".svn"])) $ getDirectoryContents pth
+
+pathFromModuleName :: String -> String
+pathFromModuleName m = "src/" ++ [if c == '.' then '/' else c | c <- m] ++ ".hs"

ampersand.cabal view
@@ -1,5 +1,5 @@ name:           ampersand
-version:        3.0.2
+version:        3.0.3
 author:         Stef Joosten
 maintainer:     stef.joosten@ou.nl
 synopsis:       Toolsuite for automated design of business processes.
@@ -8,174 +8,187 @@ category:       Database Design
 stability:      alpha
 cabal-version:  >= 1.10
+tested-with:    GHC == 7.8.3
 build-type:     Custom
 license:        GPL
 license-file:   LICENSE
 copyright:      Stef Joosten
-bug-reports:    http://sourceforge.net/apps/trac/ampersand/report/12
-tested-with:    GHC == 7.6.3
+bug-reports:    https://sourceforge.net/p/ampersand/tickets/
+-- Recursive patterns such as static/* are not allowed in data-files. Hence we cannot use them for static files, as
+-- we would need to specify a pattern for each extension in each subdirectory.
 data-files:     
                 AmpersandData/Examples/Delivery/Delivery.adl, 
-                AmpersandData/FormalAmpersand/ADLTool.adl, 
-                AmpersandData/FormalAmpersand/admin_interfaces.adl, 
                 AmpersandData/FormalAmpersand/AST.adl, 
                 AmpersandData/FormalAmpersand/ASTdocumentation.adl, 
+                AmpersandData/FormalAmpersand/ASTInterface.ifc, 
+                AmpersandData/FormalAmpersand/Atoms.adl, 
                 AmpersandData/FormalAmpersand/FormalAmpersand.adl, 
-                AmpersandData/FormalAmpersand/Fspec.adl, 
+                AmpersandData/FormalAmpersand/Generics.adl, 
+                AmpersandData/FormalAmpersand/IS.adl, 
+                AmpersandData/FormalAmpersand/IS.ifc, 
+                AmpersandData/FormalAmpersand/IS.pop, 
+                AmpersandData/FormalAmpersand/ISdocumentation.adl, 
                 AmpersandData/FormalAmpersand/RAP.adl, 
                 AmpersandData/FormalAmpersand/README.txt, 
                 AmpersandData/FormalAmpersand/student_AST_interfaces.adl, 
                 outputTemplates/default.asciidoc, 
+                outputTemplates/default.beamer, 
                 outputTemplates/default.context, 
                 outputTemplates/default.docbook, 
+                outputTemplates/default.dokuwiki, 
+                outputTemplates/default.dzslides, 
+                outputTemplates/default.epub, 
+                outputTemplates/default.epub3, 
+                outputTemplates/default.haddock, 
                 outputTemplates/default.html, 
+                outputTemplates/default.html5, 
+                outputTemplates/default.icml, 
                 outputTemplates/default.latex, 
                 outputTemplates/default.man, 
                 outputTemplates/default.markdown, 
                 outputTemplates/default.mediawiki, 
                 outputTemplates/default.opendocument, 
+                outputTemplates/default.opml, 
                 outputTemplates/default.org, 
                 outputTemplates/default.plain, 
+                outputTemplates/default.revealjs, 
                 outputTemplates/default.rst, 
                 outputTemplates/default.rtf, 
                 outputTemplates/default.s5, 
+                outputTemplates/default.slideous, 
                 outputTemplates/default.slidy, 
                 outputTemplates/default.texinfo, 
                 outputTemplates/default.textile, 
-                LICENSE, 
-                README.txt
+                LICENSE
 
 source-repository head
-  type:      svn
-  location:  https://svn.code.sf.net/p/ampersand/code/trunk
+  type:      git
+  location:  https://github.com/AmpersandTarski/ampersand.git
 
-flag executable
-  description:  Build the ampersand executable.
-  default:      True
 
-flag library
-  description:  Build the ampersand library.
-  default:      True
-
-library
-  hs-source-dirs:    src/lib
-  build-depends:    graphviz >= 2999.16.0.0 && <= 2999.17,
-                    base >= 4.5.0.0 && < 5,
-                    containers >= 0.5,
-                    utf8-string >= 0.3.7 && < 0.4,
-                    bytestring >= 0.9.2.1,
-                    filepath >= 1.3.0.0 && < 1.4,
-                    pandoc-types >=1.12.3 && <1.13,
-                    pandoc >= 1.12.1 && < 1.13,
-                    mtl >= 2.1.1 && < 2.2,
-                    directory == 1.2.0.1,
-                    hashable >= 1.2 && < 1.3,
-                    time == 1.4.0.1,
-                    SpreadsheetML >= 0.1 && < 0.2,
-                    process >= 1.1.0.1 && < 1.2,
-                    split >= 0.1 && < 0.2,
-                    old-locale >= 1.0.0.4 && < 1.1,
-                    ConfigFile >= 1.1.1
-  exposed-modules:  DatabaseDesign.Ampersand
-  other-modules:    
-                    DatabaseDesign.Ampersand.ADL1,
-                    DatabaseDesign.Ampersand.ADL1.Disambiguate,
-                    DatabaseDesign.Ampersand.ADL1.ECArule,
-                    DatabaseDesign.Ampersand.ADL1.Expression,
-                    DatabaseDesign.Ampersand.ADL1.Lattices,
-                    DatabaseDesign.Ampersand.ADL1.P2A_Converters,
-                    DatabaseDesign.Ampersand.ADL1.Pair,
-                    DatabaseDesign.Ampersand.ADL1.Rule,
-                    DatabaseDesign.Ampersand.Basics,
-                    DatabaseDesign.Ampersand.Basics.Auxiliaries,
-                    DatabaseDesign.Ampersand.Basics.BuildInfo_Generated,
-                    DatabaseDesign.Ampersand.Basics.Collection,
-                    DatabaseDesign.Ampersand.Basics.String,
-                    DatabaseDesign.Ampersand.Basics.UTF8,
-                    DatabaseDesign.Ampersand.Basics.Version,
-                    DatabaseDesign.Ampersand.Classes,
-                    DatabaseDesign.Ampersand.Classes.ConceptStructure,
-                    DatabaseDesign.Ampersand.Classes.Populated,
-                    DatabaseDesign.Ampersand.Classes.Relational,
-                    DatabaseDesign.Ampersand.Classes.ViewPoint,
-                    DatabaseDesign.Ampersand.Components,
-                    DatabaseDesign.Ampersand.Core.AbstractSyntaxTree,
-                    DatabaseDesign.Ampersand.Core.ParseTree,
-                    DatabaseDesign.Ampersand.Core.Poset,
-                    DatabaseDesign.Ampersand.Core.Poset.Instances,
-                    DatabaseDesign.Ampersand.Core.Poset.Internal,
-                    DatabaseDesign.Ampersand.Fspec,
-                    DatabaseDesign.Ampersand.Fspec.FPA,
-                    DatabaseDesign.Ampersand.Fspec.Fspec,
-                    DatabaseDesign.Ampersand.Fspec.GenerateUML,
-                    DatabaseDesign.Ampersand.Fspec.Graphic.ClassDiagram,
-                    DatabaseDesign.Ampersand.Fspec.Graphic.Graphics,
-                    DatabaseDesign.Ampersand.Fspec.Motivations,
-                    DatabaseDesign.Ampersand.Fspec.Plug,
-                    DatabaseDesign.Ampersand.Fspec.ShowADL,
-                    DatabaseDesign.Ampersand.Fspec.ShowECA,
-                    DatabaseDesign.Ampersand.Fspec.ShowHS,
-                    DatabaseDesign.Ampersand.Fspec.ShowMeatGrinder,
-                    DatabaseDesign.Ampersand.Fspec.ShowXMLtiny,
-                    DatabaseDesign.Ampersand.Fspec.Switchboard,
-                    DatabaseDesign.Ampersand.Fspec.ToFspec.ADL2Fspec,
-                    DatabaseDesign.Ampersand.Fspec.ToFspec.ADL2Plug,
-                    DatabaseDesign.Ampersand.Fspec.ToFspec.Calc,
-                    DatabaseDesign.Ampersand.Fspec.ToFspec.NormalForms,
-                    DatabaseDesign.Ampersand.Input,
-                    DatabaseDesign.Ampersand.Input.ADL1.CtxError,
-                    DatabaseDesign.Ampersand.Input.ADL1.FilePos,
-                    DatabaseDesign.Ampersand.Input.ADL1.Parser,
-                    DatabaseDesign.Ampersand.Input.ADL1.UU_BinaryTrees,
-                    DatabaseDesign.Ampersand.Input.ADL1.UU_Parsing,
-                    DatabaseDesign.Ampersand.Input.ADL1.UU_Scanner,
-                    DatabaseDesign.Ampersand.Input.Parsing,
-                    DatabaseDesign.Ampersand.InputProcessing,
-                    DatabaseDesign.Ampersand.Misc,
-                    DatabaseDesign.Ampersand.Misc.Explain,
-                    DatabaseDesign.Ampersand.Misc.Languages,
-                    DatabaseDesign.Ampersand.Misc.Options,
-                    DatabaseDesign.Ampersand.Misc.TinyXML,
-                    DatabaseDesign.Ampersand.Output,
-                    DatabaseDesign.Ampersand.Output.Fspec2Excel,
-                    DatabaseDesign.Ampersand.Output.Fspec2Pandoc,
-                    DatabaseDesign.Ampersand.Output.PandocAux,
-                    DatabaseDesign.Ampersand.Output.PredLogic,
-                    DatabaseDesign.Ampersand.Output.Statistics,
-                    DatabaseDesign.Ampersand.Output.ToPandoc.ChapterConceptualAnalysis,
-                    DatabaseDesign.Ampersand.Output.ToPandoc.ChapterDataAnalysis,
-                    DatabaseDesign.Ampersand.Output.ToPandoc.ChapterDiagnosis,
-                    DatabaseDesign.Ampersand.Output.ToPandoc.ChapterECArules,
-                    DatabaseDesign.Ampersand.Output.ToPandoc.ChapterGlossary,
-                    DatabaseDesign.Ampersand.Output.ToPandoc.ChapterInterfaces,
-                    DatabaseDesign.Ampersand.Output.ToPandoc.ChapterIntroduction,
-                    DatabaseDesign.Ampersand.Output.ToPandoc.ChapterNatLangReqs,
-                    DatabaseDesign.Ampersand.Output.ToPandoc.ChapterProcessAnalysis,
-                    DatabaseDesign.Ampersand.Output.ToPandoc.ChapterSoftwareMetrics,
-                    DatabaseDesign.Ampersand.Output.ToPandoc.SharedAmongChapters,
-                    Paths_ampersand
-                    
-  default-language:  Haskell2010
-
-  if flag(library)
-    buildable:  True
-
-  else
-    buildable:  False
-
 executable ampersand
   main-is:           Main.hs
-  hs-source-dirs:    src/exec
-  build-depends:     ampersand == 3.0.2,
-                     graphviz >= 2999.16.0.0 && <= 2999.17,
-                     filepath >= 1.3.0.0 && < 1.4,
-                     base >= 4.5.0.0
+  hs-source-dirs:    src
   default-language:  Haskell2010
-  ghc-options:       -rtsopts
-  --inspired by http://stackoverflow.com/questions/7140732/haskell-space-overflow :
-                     -O2
-  if flag(executable)
-    buildable:  True
-  else
-    buildable:  False
-
+  ghc-options:       -rtsopts -Wall
+  build-depends:     HDBC == 2.4.*,
+                     HDBC-odbc == 2.3.*,
+                     HStringTemplate == 0.7.*,
+                     SpreadsheetML == 0.1.*,
+                     base >= 4.6 && < 5.0,
+                     bytestring == 0.10.*,
+                     containers == 0.5.*,
+                     csv == 0.1.*,
+                     directory == 1.2.*,
+                     filepath == 1.3.*,
+                     graphviz == 2999.17.*,
+                     hashable == 1.2.*,
+                     mtl == 2.1.*,
+                     old-locale == 1.0.*,
+                     old-time == 1.1.*,
+                     pandoc == 1.13.*,
+                     pandoc-types == 1.12.*,
+                     process == 1.2.*,
+                     simple-sql-parser >=0.4.1 && <0.5,
+                     split == 0.2.*,
+                     text == 1.1.*,
+                     time == 1.4.*,
+                     utf8-string == 0.3.*,
+                     uulib == 0.9.*
+        
+  other-modules:     
+                     Database.Design.Ampersand,
+                     Database.Design.Ampersand.ADL1,
+                     Database.Design.Ampersand.ADL1.Disambiguate,
+                     Database.Design.Ampersand.ADL1.ECArule,
+                     Database.Design.Ampersand.ADL1.Expression,
+                     Database.Design.Ampersand.ADL1.Lattices,
+                     Database.Design.Ampersand.ADL1.P2A_Converters,
+                     Database.Design.Ampersand.ADL1.Pair,
+                     Database.Design.Ampersand.ADL1.Rule,
+                     Database.Design.Ampersand.Basics,
+                     Database.Design.Ampersand.Basics.Auxiliaries,
+                     Database.Design.Ampersand.Basics.BuildInfo_Generated,
+                     Database.Design.Ampersand.Basics.Collection,
+                     Database.Design.Ampersand.Basics.String,
+                     Database.Design.Ampersand.Basics.Unique,
+                     Database.Design.Ampersand.Basics.UTF8,
+                     Database.Design.Ampersand.Basics.Version,
+                     Database.Design.Ampersand.Classes,
+                     Database.Design.Ampersand.Classes.ConceptStructure,
+                     Database.Design.Ampersand.Classes.Populated,
+                     Database.Design.Ampersand.Classes.Relational,
+                     Database.Design.Ampersand.Classes.ViewPoint,
+                     Database.Design.Ampersand.Components,
+                     Database.Design.Ampersand.Core.AbstractSyntaxTree,
+                     Database.Design.Ampersand.Core.ParseTree,
+                     Database.Design.Ampersand.Core.Poset,
+                     Database.Design.Ampersand.Core.Poset.Instances,
+                     Database.Design.Ampersand.Core.Poset.Internal,
+                     Database.Design.Ampersand.Core.ToMeta,
+                     Database.Design.Ampersand.FSpec,
+                     Database.Design.Ampersand.FSpec.Crud,
+                     Database.Design.Ampersand.FSpec.FPA,
+                     Database.Design.Ampersand.FSpec.FSpec,
+                     Database.Design.Ampersand.FSpec.FSpecAux,
+                     Database.Design.Ampersand.FSpec.GenerateUML,
+                     Database.Design.Ampersand.FSpec.Graphic.ClassDiagram,
+                     Database.Design.Ampersand.FSpec.Graphic.Graphics,
+                     Database.Design.Ampersand.FSpec.Motivations,
+                     Database.Design.Ampersand.FSpec.Plug,
+                     Database.Design.Ampersand.FSpec.ShowADL,
+                     Database.Design.Ampersand.FSpec.ShowECA,
+                     Database.Design.Ampersand.FSpec.ShowHS,
+                     Database.Design.Ampersand.FSpec.ShowMeatGrinder,
+                     Database.Design.Ampersand.FSpec.ShowXMLtiny,
+                     Database.Design.Ampersand.FSpec.Switchboard,
+                     Database.Design.Ampersand.FSpec.ToFSpec.ADL2FSpec,
+                     Database.Design.Ampersand.FSpec.ToFSpec.ADL2Plug,
+                     Database.Design.Ampersand.FSpec.ToFSpec.Calc,
+                     Database.Design.Ampersand.FSpec.ToFSpec.CreateFspec,
+                     Database.Design.Ampersand.FSpec.ToFSpec.NormalForms,
+                     Database.Design.Ampersand.Input,
+                     Database.Design.Ampersand.Input.ADL1.CtxError,
+                     Database.Design.Ampersand.Input.ADL1.FilePos,
+                     Database.Design.Ampersand.Input.ADL1.Parser,
+                     Database.Design.Ampersand.Input.ADL1.UU_BinaryTrees,
+                     Database.Design.Ampersand.Input.ADL1.UU_Scanner,
+                     Database.Design.Ampersand.Input.Parsing,
+                     Database.Design.Ampersand.Misc,
+                     Database.Design.Ampersand.Misc.Explain,
+                     Database.Design.Ampersand.Misc.Languages,
+                     Database.Design.Ampersand.Misc.Options,
+                     Database.Design.Ampersand.Misc.TinyXML,
+                     Database.Design.Ampersand.Output,
+                     Database.Design.Ampersand.Output.FSpec2Excel,
+                     Database.Design.Ampersand.Output.FSpec2Pandoc,
+                     Database.Design.Ampersand.Output.PandocAux,
+                     Database.Design.Ampersand.Output.PredLogic,
+                     Database.Design.Ampersand.Output.Statistics,
+                     Database.Design.Ampersand.Output.ToPandoc.ChapterConceptualAnalysis,
+                     Database.Design.Ampersand.Output.ToPandoc.ChapterDataAnalysis,
+                     Database.Design.Ampersand.Output.ToPandoc.ChapterDiagnosis,
+                     Database.Design.Ampersand.Output.ToPandoc.ChapterECArules,
+                     Database.Design.Ampersand.Output.ToPandoc.ChapterFunctionPointAnalysis,
+                     Database.Design.Ampersand.Output.ToPandoc.ChapterGlossary,
+                     Database.Design.Ampersand.Output.ToPandoc.ChapterInterfaces,
+                     Database.Design.Ampersand.Output.ToPandoc.ChapterIntroduction,
+                     Database.Design.Ampersand.Output.ToPandoc.ChapterNatLangReqs,
+                     Database.Design.Ampersand.Output.ToPandoc.ChapterProcessAnalysis,
+                     Database.Design.Ampersand.Output.ToPandoc.ChapterSoftwareMetrics,
+                     Database.Design.Ampersand.Output.ToPandoc.SharedAmongChapters,
+                     Database.Design.Ampersand.Prototype.Apps,
+                     Database.Design.Ampersand.Prototype.Apps.RAP,
+                     Database.Design.Ampersand.Prototype.AutoInstaller,
+                     Database.Design.Ampersand.Prototype.CoreImporter,
+                     Database.Design.Ampersand.Prototype.GenBericht,
+                     Database.Design.Ampersand.Prototype.Generate,
+                     Database.Design.Ampersand.Prototype.GenFrontend,
+                     Database.Design.Ampersand.Prototype.Installer,
+                     Database.Design.Ampersand.Prototype.ObjBinGen,
+                     Database.Design.Ampersand.Prototype.PHP,
+                     Database.Design.Ampersand.Prototype.ProtoUtil,
+                     Database.Design.Ampersand.Prototype.StaticFiles_Generated,
+                     Database.Design.Ampersand.Prototype.ValidateEdit,
+                     Database.Design.Ampersand.Prototype.ValidateSQL,
+                     Paths_ampersand

outputTemplates/default.asciidoc view
@@ -1,26 +1,26 @@-$if(titleblock)$-$title$-$for(author)$-:author: $author$-$endfor$-$if(date)$-:date: $date$-$endif$-$if(toc)$-:toc:-$endif$--$endif$-$for(header-includes)$-$header-includes$--$endfor$-$for(include-before)$-$include-before$--$endfor$-$body$-$for(include-after)$--$include-after$-$endfor$+$if(titleblock)$
+$title$
+$for(author)$
+:author: $author$
+$endfor$
+$if(date)$
+:date: $date$
+$endif$
+$if(toc)$
+:toc:
+$endif$
+
+$endif$
+$for(header-includes)$
+$header-includes$
+
+$endfor$
+$for(include-before)$
+$include-before$
+
+$endfor$
+$body$
+$for(include-after)$
+
+$include-after$
+$endfor$

+ outputTemplates/default.beamer view
@@ -0,0 +1,177 @@+\documentclass[$if(fontsize)$$fontsize$,$endif$$if(handout)$handout,$endif$$if(beamer)$ignorenonframetext,$endif$$for(classoption)$$classoption$$sep$,$endfor$]{$documentclass$}
+$if(theme)$
+\usetheme{$theme$}
+$endif$
+$if(colortheme)$
+\usecolortheme{$colortheme$}
+$endif$
+$if(fonttheme)$
+\usefonttheme{$fonttheme$}
+$endif$
+\setbeamertemplate{caption}[numbered]
+\setbeamertemplate{caption label separator}{:}
+\setbeamercolor{caption name}{fg=normal text.fg}
+\usepackage{amssymb,amsmath}
+\usepackage{ifxetex,ifluatex}
+\usepackage{fixltx2e} % provides \textsubscript
+\usepackage{lmodern}
+\ifxetex
+  \usepackage{fontspec,xltxtra,xunicode}
+  \defaultfontfeatures{Mapping=tex-text,Scale=MatchLowercase}
+  \newcommand{\euro}{€}
+\else
+  \ifluatex
+    \usepackage{fontspec}
+    \defaultfontfeatures{Mapping=tex-text,Scale=MatchLowercase}
+    \newcommand{\euro}{€}
+  \else
+    \usepackage[T1]{fontenc}
+    \usepackage[utf8]{inputenc}
+    $if(euro)$
+      \usepackage{eurosym}
+    $endif$
+  \fi
+\fi
+% use upquote if available, for straight quotes in verbatim environments
+\IfFileExists{upquote.sty}{\usepackage{upquote}}{}
+% use microtype if available
+\IfFileExists{microtype.sty}{\usepackage{microtype}}{}
+$if(natbib)$
+\usepackage{natbib}
+\bibliographystyle{plainnat}
+$endif$
+$if(biblatex)$
+\usepackage{biblatex}
+$if(biblio-files)$
+\bibliography{$biblio-files$}
+$endif$
+$endif$
+$if(listings)$
+\usepackage{listings}
+$endif$
+$if(lhs)$
+\lstnewenvironment{code}{\lstset{language=Haskell,basicstyle=\small\ttfamily}}{}
+$endif$
+$if(highlighting-macros)$
+$highlighting-macros$
+$endif$
+$if(verbatim-in-note)$
+\usepackage{fancyvrb}
+$endif$
+$if(tables)$
+\usepackage{longtable,booktabs}
+\usepackage{caption}
+% These lines are needed to make table captions work with longtable:
+\makeatletter
+\def\fnum@table{\tablename~\thetable}
+\makeatother
+$endif$
+$if(url)$
+\usepackage{url}
+$endif$
+$if(graphics)$
+\usepackage{graphicx}
+\makeatletter
+\def\maxwidth{\ifdim\Gin@nat@width>\linewidth\linewidth\else\Gin@nat@width\fi}
+\def\maxheight{\ifdim\Gin@nat@height>\textheight0.8\textheight\else\Gin@nat@height\fi}
+\makeatother
+% Scale images if necessary, so that they will not overflow the page
+% margins by default, and it is still possible to overwrite the defaults
+% using explicit options in \includegraphics[width, height, ...]{}
+\setkeys{Gin}{width=\maxwidth,height=\maxheight,keepaspectratio}
+$endif$
+
+% Comment these out if you don't want a slide with just the
+% part/section/subsection/subsubsection title:
+\AtBeginPart{
+  \let\insertpartnumber\relax
+  \let\partname\relax
+  \frame{\partpage}
+}
+\AtBeginSection{
+  \let\insertsectionnumber\relax
+  \let\sectionname\relax
+  \frame{\sectionpage}
+}
+\AtBeginSubsection{
+  \let\insertsubsectionnumber\relax
+  \let\subsectionname\relax
+  \frame{\subsectionpage}
+}
+
+$if(strikeout)$
+\usepackage[normalem]{ulem}
+% avoid problems with \sout in headers with hyperref:
+\pdfstringdefDisableCommands{\renewcommand{\sout}{}}
+$endif$
+\setlength{\parindent}{0pt}
+\setlength{\parskip}{6pt plus 2pt minus 1pt}
+\setlength{\emergencystretch}{3em}  % prevent overfull lines
+$if(numbersections)$
+$else$
+\setcounter{secnumdepth}{0}
+$endif$
+$if(verbatim-in-note)$
+\VerbatimFootnotes % allows verbatim text in footnotes
+$endif$
+$if(lang)$
+\usepackage[$lang$]{babel}
+$endif$
+$for(header-includes)$
+$header-includes$
+$endfor$
+
+$if(title)$
+\title{$title$}
+$endif$
+$if(subtitle)$
+\subtitle{$subtitle$}
+$endif$
+$if(author)$
+\author{$for(author)$$author$$sep$ \and $endfor$}
+$endif$
+\date{$date$}
+
+\begin{document}
+$if(title)$
+\frame{\titlepage}
+$endif$
+
+$for(include-before)$
+$include-before$
+
+$endfor$
+$if(toc)$
+\begin{frame}
+\tableofcontents[hideallsubsections]
+\end{frame}
+
+$endif$
+$body$
+
+$if(natbib)$
+$if(biblio-files)$
+$if(biblio-title)$
+$if(book-class)$
+\renewcommand\bibname{$biblio-title$}
+$else$
+\renewcommand\refname{$biblio-title$}
+$endif$
+$endif$
+\begin{frame}[allowframebreaks]{$biblio-title$}
+\bibliography{$biblio-files$}
+\end{frame}
+
+$endif$
+$endif$
+$if(biblatex)$
+\begin{frame}[allowframebreaks]{$biblio-title$}
+\printbibliography[heading=none]
+\end{frame}
+
+$endif$
+$for(include-after)$
+$include-after$
+
+$endfor$
+\end{document}

outputTemplates/default.context view
@@ -1,84 +1,87 @@-\enableregime[utf]  % use UTF-8--\setupcolors[state=start]-\setupinteraction[state=start, color=middleblue] % needed for hyperlinks--\setuppapersize[letter][letter]  % use letter paper-\setuplayout[width=middle, backspace=1.5in, cutspace=1.5in,-             height=middle, header=0.75in, footer=0.75in] % page layout-\setuppagenumbering[location={footer,center}]  % number pages-\setupbodyfont[11pt]  % 11pt font-\setupwhitespace[medium]  % inter-paragraph spacing--\setuphead[section][style=\tfc]-\setuphead[subsection][style=\tfb]-\setuphead[subsubsection][style=\bf]--% define descr (for definition lists)-\definedescription[descr][-  headstyle=bold,style=normal,align=left,location=hanging,-  width=broad,margin=1cm]--% prevent orphaned list intros-\setupitemize[autointro]--% define defaults for bulleted lists -\setupitemize[1][symbol=1][indentnext=no]-\setupitemize[2][symbol=2][indentnext=no]-\setupitemize[3][symbol=3][indentnext=no]-\setupitemize[4][symbol=4][indentnext=no]--\setupthinrules[width=15em]  % width of horizontal rules--% for block quotations-\unprotect--\startvariables all-blockquote: blockquote-\stopvariables--\definedelimitedtext-[\v!blockquote][\v!quotation]--\setupdelimitedtext-[\v!blockquote]-[\c!left=,-\c!right=,-before={\blank[medium]},-after={\blank[medium]},-]--\protect-$for(header-includes)$-$header-includes$-$endfor$--\starttext-$if(title)$-\startalignment[center]-  \blank[2*big]-  {\tfd $title$}-$if(author)$-  \blank[3*medium]-  {\tfa $for(author)$$author$$sep$\crlf $endfor$}-$endif$-$if(date)$-  \blank[2*medium]-  {\tfa $date$}-$endif$-  \blank[3*medium]-\stopalignment-$endif$-$for(include-before)$-$include-before$-$endfor$-$if(toc)$-\placecontent-$endif$--$body$--$for(include-after)$-$include-after$-$endfor$-\stoptext+\startmode[*mkii]
+  \enableregime[utf-8]  
+  \setupcolors[state=start]
+\stopmode
+$if(mainlang)$
+\mainlanguage[$mainlang$]
+$endif$
+
+% Enable hyperlinks
+\setupinteraction[state=start, color=middleblue]
+
+\setuppapersize [$if(papersize)$$papersize$$else$letter$endif$][$if(papersize)$$papersize$$else$letter$endif$]
+\setuplayout    [width=middle,  backspace=1.5in, cutspace=1.5in,
+                 height=middle, topspace=0.75in, bottomspace=0.75in]
+
+\setuppagenumbering[location={footer,center}]
+
+\setupbodyfont[11pt]
+
+\setupwhitespace[medium]
+
+\setuphead[chapter]      [style=\tfd]
+\setuphead[section]      [style=\tfc]
+\setuphead[subsection]   [style=\tfb]
+\setuphead[subsubsection][style=\bf]
+
+$if(number-sections)$
+$else$
+\setuphead[chapter, section, subsection, subsubsection][number=no]
+$endif$
+
+\definedescription
+  [description]
+  [headstyle=bold, style=normal, location=hanging, width=broad, margin=1cm]
+
+\setupitemize[autointro]    % prevent orphan list intro
+\setupitemize[indentnext=no]
+
+\setupfloat[figure][default={here,nonumber}]
+\setupfloat[table][default={here,nonumber}]
+
+\setupthinrules[width=15em] % width of horizontal rules
+
+\setupdelimitedtext
+  [blockquote]
+  [before={\blank[medium]},
+   after={\blank[medium]},
+   indentnext=no,
+  ]
+
+$if(toc)$
+\setupcombinedlist[content][list={$placelist$}]
+
+$endif$
+$for(header-includes)$
+$header-includes$
+$endfor$
+
+\starttext
+$if(title)$
+\startalignment[center]
+  \blank[2*big]
+  {\tfd $title$}
+$if(author)$
+  \blank[3*medium]
+  {\tfa $for(author)$$author$$sep$\crlf $endfor$}
+$endif$
+$if(date)$
+  \blank[2*medium]
+  {\tfa $date$}
+$endif$
+  \blank[3*medium]
+\stopalignment
+$endif$
+$for(include-before)$
+$include-before$
+$endfor$
+$if(toc)$
+\placecontent
+$endif$
+
+$body$
+
+$for(include-after)$
+$include-after$
+$endfor$
+\stoptext

outputTemplates/default.docbook view
@@ -1,23 +1,32 @@-<?xml version="1.0" encoding="utf-8" ?>-<!DOCTYPE article PUBLIC "-//OASIS//DTD DocBook XML V4.4//EN"-                  "http://www.oasis-open.org/docbook/xml/4.4/docbookx.dtd">-<article>-  <articleinfo>-    <title>$title$</title>-$for(author)$-    <author>-      $author$-    </author>-$endfor$-$if(date)$-    <date>$date$</date>-$endif$-  </articleinfo>-$for(include-before)$-$include-before$-$endfor$-$body$-$for(include-after)$-$include-after$-$endfor$-</article>+<?xml version="1.0" encoding="utf-8" ?>
+$if(mathml)$
+<!DOCTYPE article PUBLIC "-//OASIS//DTD DocBook EBNF Module V1.1CR1//EN"
+                  "http://www.oasis-open.org/docbook/xml/mathml/1.1CR1/dbmathml.dtd">
+$else$
+<!DOCTYPE article PUBLIC "-//OASIS//DTD DocBook XML V4.5//EN"
+                  "http://www.oasis-open.org/docbook/xml/4.5/docbookx.dtd">
+$endif$
+<article>
+  <articleinfo>
+    <title>$title$</title>
+$if(author)$
+    <authorgroup>
+$for(author)$
+      <author>
+        $author$
+      </author>
+$endfor$
+    </authorgroup>
+$endif$
+$if(date)$
+    <date>$date$</date>
+$endif$
+  </articleinfo>
+$for(include-before)$
+$include-before$
+$endfor$
+$body$
+$for(include-after)$
+$include-after$
+$endfor$
+</article>

+ outputTemplates/default.dokuwiki view
@@ -0,0 +1,13 @@+$for(include-before)$
+$include-before$
+
+$endfor$
+$if(toc)$
+__TOC__
+
+$endif$
+$body$
+$for(include-after)$
+
+$include-after$
+$endfor$

+ outputTemplates/default.dzslides view
@@ -0,0 +1,123 @@+<!DOCTYPE html>
+<head>
+<meta charset="utf-8">
+$for(author-meta)$
+  <meta name="author" content="$author-meta$" />
+$endfor$
+$if(date-meta)$
+  <meta name="dcterms.date" content="$date-meta$" />
+$endif$
+  <title>$if(title-prefix)$$title-prefix$ - $endif$$pagetitle$</title>
+  <style type="text/css">code{white-space: pre;}</style>
+$if(highlighting-css)$
+  <style type="text/css">
+$highlighting-css$
+  </style>
+$endif$
+$if(css)$
+$for(css)$
+  <link rel="stylesheet" href="$css$" $if(html5)$$else$type="text/css" $endif$/>
+$endfor$
+$else$
+<style>
+  html { background-color: black; }
+  body { background-color: white; border-radius: 12px}
+  /* A section is a slide. It's size is 800x600, and this will never change */
+  section {
+      font-family: Arial, serif;
+      font-size: 20pt;
+    }
+  address, blockquote, dl, fieldset, form, h1, h2, h3, h4, h5, h6, hr, ol, p, pre, table, ul, dl { padding: 10px 20px 10px 20px; }
+  h1, h2, h3 {
+    text-align: center;
+    margin: 10pt 10pt 20pt 10pt;
+  }
+  ul, ol {
+    margin: 10px 10px 10px 50px;
+  }
+  section.titleslide h1 { margin-top: 200px; }
+  h1.title { margin-top: 150px; }
+  h1 { font-size: 180%; }
+  h2 { font-size: 120%; }
+  h3 { font-size: 100%; }
+  q { quotes: "“" "”" "‘" "’"; }
+  blockquote { font-style: italic }
+  /* Figures are displayed full-page, with the caption on
+     top of the image/video */
+  figure {
+    background-color: black;
+  }
+  figcaption {
+    margin: 70px;
+  }
+  footer {
+    position: absolute;
+    bottom: 0;
+    width: 100%;
+    padding: 40px;
+    text-align: right;
+    background-color: #F3F4F8;
+    border-top: 1px solid #CCC;
+  }
+
+  /* Transition effect */
+  /* Feel free to change the transition effect for original
+     animations. See here:
+     https://developer.mozilla.org/en/CSS/CSS_transitions
+     How to use CSS3 Transitions: */
+  section {
+      -moz-transition: left 400ms linear 0s;
+      -webkit-transition: left 400ms linear 0s;
+      -ms-transition: left 400ms linear 0s;
+      transition: left 400ms linear 0s;
+  }
+
+  /* Before */
+  section { left: -150%; }
+  /* Now */
+  section[aria-selected] { left: 0; }
+  /* After */
+  section[aria-selected] ~ section { left: +150%; }
+
+  /* Incremental elements */
+
+  /* By default, visible */
+  .incremental > * { opacity: 1; }
+
+  /* The current item */
+  .incremental > *[aria-selected] { color: red; opacity: 1; }
+
+  /* The items to-be-selected */
+  .incremental > *[aria-selected] ~ * { opacity: 0.2; }
+</style>
+$endif$
+$if(math)$
+  $math$
+$endif$
+$for(header-includes)$
+  $header-includes$
+$endfor$
+</head>
+<body>
+$if(title)$
+<section class="title">
+  <h1 class="title">$title$</h1>
+$if(subtitle)$
+  <h1 class="subtitle">$subtitle$</h1>
+$endif$
+$for(author)$
+  <h2 class="author">$author$</h2>
+$endfor$
+  <h3 class="date">$date$</h3>
+</section>
+$endif$
+$for(include-before)$
+$include-before$
+$endfor$
+$body$
+$for(include-after)$
+$include-after$
+$endfor$
+$dzslides-core$
+</body>
+</html>

+ outputTemplates/default.epub view
@@ -0,0 +1,50 @@+<?xml version="1.0" encoding="UTF-8"?>
+<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.1//EN" "http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd">
+<html xmlns="http://www.w3.org/1999/xhtml"$if(lang)$ xml:lang="$lang$"$endif$>
+<head>
+  <meta http-equiv="Content-Type" content="text/html; charset=utf-8" />
+  <meta http-equiv="Content-Style-Type" content="text/css" />
+  <meta name="generator" content="pandoc" />
+  <title>$pagetitle$</title>
+$if(highlighting-css)$
+  <style type="text/css">
+$highlighting-css$
+  </style>
+$endif$
+$for(css)$
+  <link rel="stylesheet" type="text/css" href="$css$" />
+$endfor$
+</head>
+<body$if(coverpage)$ id="cover"$endif$>
+$if(titlepage)$
+$for(title)$
+$if(title.text)$
+  <h1 class="$title.type$">$title.text$</h1>
+$else$
+  <h1 class="title">$title$</h1>
+$endif$
+$endfor$
+$if(subtitle)$
+  <h1 class="subtitle">$subtitle$</h1>
+$endif$
+$for(author)$
+  <h2 class="author">$author$</h2>
+$endfor$
+$for(creator)$
+  <h2 class="$creator.type$">$creator.text$</h2>
+$endfor$
+$if(publisher)$
+  <p class="publisher">$publisher$</p>
+$endif$
+$if(date)$
+  <p class="date">$date$</p>
+$endif$
+$if(rights)$
+  <p class="rights">$rights$</p>
+$endif$
+$else$
+$body$
+$endif$
+</body>
+</html>
+

+ outputTemplates/default.epub3 view
@@ -0,0 +1,56 @@+<?xml version="1.0" encoding="UTF-8"?>
+<!DOCTYPE html>
+<html xmlns="http://www.w3.org/1999/xhtml" xmlns:epub="http://www.idpf.org/2007/ops"$if(lang)$ xml:lang="$lang$"$endif$>
+<head>
+  <meta charset="utf-8" />
+  <meta name="generator" content="pandoc" />
+  <title>$pagetitle$</title>
+$if(quotes)$
+  <style type="text/css">
+    q { quotes: "“" "”" "‘" "’"; }
+  </style>
+$endif$
+$if(highlighting-css)$
+  <style type="text/css">
+$highlighting-css$
+  </style>
+$endif$
+$for(css)$
+  <link rel="stylesheet" type="text/css" href="$css$" />
+$endfor$
+</head>
+<body$if(coverpage)$ id="cover"$endif$>
+$if(titlepage)$
+<section epub:type="titlepage">
+$for(title)$
+$if(title.type)$
+  <h1 class="$title.type$">$title.text$</h1>
+$else$
+  <h1 class="title">$title$</h1>
+$endif$
+$endfor$
+$if(subtitle)$
+  <h1 class="subtitle">$subtitle$</h1>
+$endif$
+$for(author)$
+  <h2 class="author">$author$</h2>
+$endfor$
+$for(creator)$
+  <h2 class="$creator.type$">$creator.text$</h2>
+$endfor$
+$if(publisher)$
+  <p class="publisher">$publisher$</p>
+$endif$
+$if(date)$
+  <p class="date">$date$</p>
+$endif$
+$if(rights)$
+  <p class="rights">$rights$</p>
+$endif$
+</section>
+$else$
+$body$
+$endif$
+</body>
+</html>
+

+ outputTemplates/default.haddock view
@@ -0,0 +1,1 @@+$body$

outputTemplates/default.html view
@@ -1,60 +1,61 @@-$if(html5)$-<!DOCTYPE html>-<html $if(lang)$ lang="$lang$"$endif$>-$else$-<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">-<html xmlns="http://www.w3.org/1999/xhtml" $if(lang)$ lang="$lang$"-	xml:lang="$lang$"$endif$>-$endif$-<head>-$if(html5)$-<meta charset="utf-8" />-$else$-<meta http-equiv="Content-Type" content="text/html; charset=utf-8" />-$endif$-<meta name="generator" content="pandoc" />-$for(author)$-<meta name="author" content="$author$" />-$endfor$ $if(date)$-<meta name="date" content="$date$" />-$endif$-<title>$if(title-prefix)$$title-prefix$ --	$endif$$if(pagetitle)$$pagetitle$$endif$</title> $if(html5)$-<!--[if lt IE 9]>-    <script src="http://html5shim.googlecode.com/svn/trunk/html5.js"></script>-  <![endif]-->-$endif$ $if(highlighting-css)$-<style type="text/css">-/*<![CDATA[*/-$-highlighting-css-$-/*]]>*/-</style>-$endif$ $for(css)$-<link rel="stylesheet" href="$css$" $if(html5)$$else$type="text/css" $endif$/>-$endfor$ $if(math)$ $if(html5)$ $else$ $math$ $endif$ $endif$-$for(header-includes)$ $header-includes$ $endfor$-</head>-<body>-	$for(include-before)$ $include-before$ $endfor$ $if(title)$ $if(html5)$-	<header>-		$else$-		<div id="$idprefix$header">-			$endif$-			<h1 class="title">$title$</h1>-			$for(author)$-			<h3 class="author">$author$</h3>-			$endfor$ $if(date)$-			<h4 class="date">$date$</h4>-			$endif$ $if(html5)$-	</header>-	$else$-	</div>-	$endif$ $endif$ $if(toc)$ $if(html5)$-	<nav id="$idprefix$TOC">$toc$</nav>-	$else$-	<div id="$idprefix$TOC">$toc$</div>-	$endif$ $endif$ $body$ $for(include-after)$ $include-after$ $endfor$-</body>-</html>+<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
+<html xmlns="http://www.w3.org/1999/xhtml"$if(lang)$ lang="$lang$" xml:lang="$lang$"$endif$>
+<head>
+  <meta http-equiv="Content-Type" content="text/html; charset=utf-8" />
+  <meta http-equiv="Content-Style-Type" content="text/css" />
+  <meta name="generator" content="pandoc" />
+$for(author-meta)$
+  <meta name="author" content="$author-meta$" />
+$endfor$
+$if(date-meta)$
+  <meta name="date" content="$date-meta$" />
+$endif$
+  <title>$if(title-prefix)$$title-prefix$ - $endif$$pagetitle$</title>
+  <style type="text/css">code{white-space: pre;}</style>
+$if(quotes)$
+  <style type="text/css">q { quotes: "“" "”" "‘" "’"; }</style>
+$endif$
+$if(highlighting-css)$
+  <style type="text/css">
+$highlighting-css$
+  </style>
+$endif$
+$for(css)$
+  <link rel="stylesheet" href="$css$" $if(html5)$$else$type="text/css" $endif$/>
+$endfor$
+$if(math)$
+  $math$
+$endif$
+$for(header-includes)$
+  $header-includes$
+$endfor$
+</head>
+<body>
+$for(include-before)$
+$include-before$
+$endfor$
+$if(title)$
+<div id="$idprefix$header">
+<h1 class="title">$title$</h1>
+$if(subtitle)$
+<h1 class="subtitle">$subtitle$</h1>
+$endif$
+$for(author)$
+<h2 class="author">$author$</h2>
+$endfor$
+$if(date)$
+<h3 class="date">$date$</h3>
+$endif$
+</div>
+$endif$
+$if(toc)$
+<div id="$idprefix$TOC">
+$toc$
+</div>
+$endif$
+$body$
+$for(include-after)$
+$include-after$
+$endfor$
+</body>
+</html>

+ outputTemplates/default.html5 view
@@ -0,0 +1,64 @@+<!DOCTYPE html>
+<html$if(lang)$ lang="$lang$"$endif$>
+<head>
+  <meta charset="utf-8">
+  <meta name="generator" content="pandoc">
+  <meta name="viewport" content="width=device-width, initial-scale=1.0, user-scalable=yes">
+$for(author-meta)$
+  <meta name="author" content="$author-meta$">
+$endfor$
+$if(date-meta)$
+  <meta name="dcterms.date" content="$date-meta$">
+$endif$
+  <title>$if(title-prefix)$$title-prefix$ - $endif$$pagetitle$</title>
+  <style type="text/css">code{white-space: pre;}</style>
+  <!--[if lt IE 9]>
+    <script src="http://html5shim.googlecode.com/svn/trunk/html5.js"></script>
+  <![endif]-->
+$if(quotes)$
+  <style type="text/css">q { quotes: "“" "”" "‘" "’"; }</style>
+$endif$
+$if(highlighting-css)$
+  <style type="text/css">
+$highlighting-css$
+  </style>
+$endif$
+$for(css)$
+  <link rel="stylesheet" href="$css$">
+$endfor$
+$if(math)$
+  $math$
+$endif$
+$for(header-includes)$
+  $header-includes$
+$endfor$
+</head>
+<body>
+$for(include-before)$
+$include-before$
+$endfor$
+$if(title)$
+<header>
+<h1 class="title">$title$</h1>
+$if(subtitle)$
+<h1 class="subtitle">$subtitle$</h1>
+$endif$
+$for(author)$
+<h2 class="author">$author$</h2>
+$endfor$
+$if(date)$
+<h3 class="date">$date$</h3>
+$endif$
+</header>
+$endif$
+$if(toc)$
+<nav id="$idprefix$TOC">
+$toc$
+</nav>
+$endif$
+$body$
+$for(include-after)$
+$include-after$
+$endfor$
+</body>
+</html>

+ outputTemplates/default.icml view
@@ -0,0 +1,43 @@+<?xml version="1.0" encoding="UTF-8" standalone="yes"?>
+<?aid style="50" type="snippet" readerVersion="6.0" featureSet="513" product="8.0(370)" ?>
+<?aid SnippetType="InCopyInterchange"?>
+<Document DOMVersion="8.0" Self="pandoc_doc">
+    <RootCharacterStyleGroup Self="pandoc_character_styles">
+      <CharacterStyle Self="$$ID/NormalCharacterStyle" Name="Default" />
+      $charStyles$ 
+    </RootCharacterStyleGroup>
+    <RootParagraphStyleGroup Self="pandoc_paragraph_styles">
+      <ParagraphStyle Self="$$ID/NormalParagraphStyle" Name="$$ID/NormalParagraphStyle"
+          SpaceBefore="6" SpaceAfter="6"> <!-- paragraph spacing -->
+        <Properties>
+          <TabList type="list">
+            <ListItem type="record">
+              <Alignment type="enumeration">LeftAlign</Alignment>
+              <AlignmentCharacter type="string">.</AlignmentCharacter>
+              <Leader type="string"></Leader>
+              <Position type="unit">10</Position> <!-- first tab stop -->
+            </ListItem>
+          </TabList>
+        </Properties>
+      </ParagraphStyle>
+      $parStyles$ 
+    </RootParagraphStyleGroup>
+    <RootTableStyleGroup Self="pandoc_table_styles">
+      <TableStyle Self="TableStyle/Table" Name="Table" />
+    </RootTableStyleGroup>
+    <RootCellStyleGroup Self="pandoc_cell_styles">
+      <CellStyle Self="CellStyle/Cell" AppliedParagraphStyle="ParagraphStyle/$$ID/[No paragraph style]" Name="Cell" />
+    </RootCellStyleGroup>
+  <Story Self="pandoc_story"
+      TrackChanges="false"
+      StoryTitle="$if(title-prefix)$$title-prefix$ - $endif$$pagetitle$"
+      AppliedTOCStyle="n"
+      AppliedNamedGrid="n" >
+    <StoryPreference OpticalMarginAlignment="true" OpticalMarginSize="12" />
+
+<!-- body needs to be non-indented, otherwise code blocks are indented too far -->
+$body$
+
+  </Story>
+  $hyperlinks$
+</Document>

outputTemplates/default.latex view
@@ -1,20 +1,28 @@-\documentclass[$if(fontsize)$$fontsize$,$endif$$if(lang)$$lang$,$endif$]{$documentclass$}
-\usepackage[T1]{fontenc}
+\documentclass[$if(fontsize)$$fontsize$,$endif$$if(lang)$$lang$,$endif$$if(papersize)$$papersize$,$endif$$for(classoption)$$classoption$$sep$,$endfor$]{$documentclass$}
+$if(fontfamily)$
+\usepackage{$fontfamily$}
+$else$
 \usepackage{lmodern}
+$endif$
+$if(linestretch)$
+\usepackage{setspace}
+\setstretch{$linestretch$}
+$endif$
 \usepackage{amssymb,amsmath}
 \usepackage{ifxetex,ifluatex}
 \usepackage{fixltx2e} % provides \textsubscript
-% use microtype if available
-\IfFileExists{microtype.sty}{\usepackage{microtype}}{}
 \ifnum 0\ifxetex 1\fi\ifluatex 1\fi=0 % if pdftex
+  \usepackage[T1]{fontenc}
   \usepackage[utf8]{inputenc}
 $if(euro)$
   \usepackage{eurosym}
 $endif$
 \else % if luatex or xelatex
-  \usepackage{fontspec}
   \ifxetex
+    \usepackage{mathspec}
     \usepackage{xltxtra,xunicode}
+  \else
+    \usepackage{fontspec}
   \fi
   \defaultfontfeatures{Mapping=tex-text,Scale=MatchLowercase}
   \newcommand{\euro}{€}
@@ -25,18 +33,33 @@     \setsansfont{$sansfont$}
 $endif$
 $if(monofont)$
-    \setmonofont{$monofont$}
+    \setmonofont[Mapping=tex-ansi]{$monofont$}
 $endif$
 $if(mathfont)$
-    \setmathfont{$mathfont$}
+    \setmathfont(Digits,Latin,Greek){$mathfont$}
 $endif$
 \fi
+% use upquote if available, for straight quotes in verbatim environments
+\IfFileExists{upquote.sty}{\usepackage{upquote}}{}
+% use microtype if available
+\IfFileExists{microtype.sty}{%
+\usepackage{microtype}
+\UseMicrotypeSet[protrusion]{basicmath} % disable protrusion for tt fonts
+}{}
 $if(geometry)$
 \usepackage[$for(geometry)$$geometry$$sep$,$endfor$]{geometry}
 $endif$
+$if(lang)$
+\ifxetex
+  \usepackage{polyglossia}
+  \setmainlanguage{$mainlang$}
+\else
+  \usepackage[$lang$]{babel}
+\fi
+$endif$
 $if(natbib)$
 \usepackage{natbib}
-\bibliographystyle{plainnat}
+\bibliographystyle{$if(biblio-style)$$biblio-style$$else$plainnat$endif$}
 $endif$
 $if(biblatex)$
 \usepackage{biblatex}
@@ -55,31 +78,21 @@ $endif$
 $if(verbatim-in-note)$
 \usepackage{fancyvrb}
-$endif$
-$if(fancy-enums)$
-% Redefine labelwidth for lists; otherwise, the enumerate package will cause
-% markers to extend beyond the left margin.
-\makeatletter\AtBeginDocument{%
-  \renewcommand{\@listi}
-    {\setlength{\labelwidth}{4em}}
-}\makeatother
-\usepackage{enumerate}
+\VerbatimFootnotes
 $endif$
 $if(tables)$
-\usepackage{ctable}
-\usepackage{float} % provides the H option for float placement
+\usepackage{longtable,booktabs}
 $endif$
 $if(graphics)$
 \usepackage{graphicx}
-% We will generate all images so they have a width \maxwidth. This means
-% that they will get their normal width if they fit onto the page, but
-% are scaled down if they would overflow the margins.
 \makeatletter
-\def\maxwidth{\ifdim\Gin@nat@width>\linewidth\linewidth
-\else\Gin@nat@width\fi}
+\def\maxwidth{\ifdim\Gin@nat@width>\linewidth\linewidth\else\Gin@nat@width\fi}
+\def\maxheight{\ifdim\Gin@nat@height>\textheight\textheight\else\Gin@nat@height\fi}
 \makeatother
-\let\Oldincludegraphics\includegraphics
-\renewcommand{\includegraphics}[1]{\Oldincludegraphics[width=\maxwidth]{#1}}
+% Scale images if necessary, so that they will not overflow the page
+% margins by default, and it is still possible to overwrite the defaults
+% using explicit options in \includegraphics[width, height, ...]{}
+\setkeys{Gin}{width=\maxwidth,height=\maxheight,keepaspectratio}
 $endif$
 \ifxetex
   \usepackage[setpagesize=false, % page size defined by xetex
@@ -89,13 +102,14 @@   \usepackage[unicode=true]{hyperref}
 \fi
 \hypersetup{breaklinks=true,
-            bookmarks=true,
             pdfauthor={$author-meta$},
             pdftitle={$title-meta$},
             colorlinks=true,
+            citecolor=$if(citecolor)$$citecolor$$else$blue$endif$,
             urlcolor=$if(urlcolor)$$urlcolor$$else$blue$endif$,
             linkcolor=$if(linkcolor)$$linkcolor$$else$magenta$endif$,
             pdfborder={0 0 0}}
+\urlstyle{same}  % don't use monospace font for urls
 $if(links-as-notes)$
 % Make links footnotes instead of hotlinks:
 \renewcommand{\href}[2]{#2\footnote{\url{#1}}}
@@ -109,34 +123,34 @@ \setlength{\parskip}{6pt plus 2pt minus 1pt}
 \setlength{\emergencystretch}{3em}  % prevent overfull lines
 $if(numbersections)$
+\setcounter{secnumdepth}{5}
 $else$
 \setcounter{secnumdepth}{0}
 $endif$
 $if(verbatim-in-note)$
 \VerbatimFootnotes % allows verbatim text in footnotes
 $endif$
-$if(lang)$
-\ifxetex
-  \usepackage{polyglossia}
-  \setmainlanguage{$mainlang$}
-\else
-  \usepackage[$lang$]{babel}
-\fi
-$endif$
-$for(header-includes)$
-$header-includes$
-$endfor$
 
 $if(title)$
-\title{$title$}
+\title{$title$$if(subtitle)$\\\vspace{0.5em}{\large $subtitle$}$endif$}
 $endif$
+$if(author)$
 \author{$for(author)$$author$$sep$ \and $endfor$}
+$endif$
 \date{$date$}
+$for(header-includes)$
+$header-includes$
+$endfor$
 
 \begin{document}
 $if(title)$
 \maketitle
 $endif$
+$if(abstract)$
+\begin{abstract}
+$abstract$
+\end{abstract}
+$endif$
 
 $for(include-before)$
 $include-before$
@@ -145,8 +159,15 @@ $if(toc)$
 {
 \hypersetup{linkcolor=black}
+\setcounter{tocdepth}{$toc-depth$}
 \tableofcontents
 }
+$endif$
+$if(lot)$
+\listoftables
+$endif$
+$if(lof)$
+\listoffigures
 $endif$
 $body$
 

outputTemplates/default.man view
@@ -1,18 +1,18 @@-$if(has-tables)$-.\"t-$endif$-.TH $title$ $section$ "$date$" $description$-$for(header-includes)$-$header-includes$-$endfor$-$for(include-before)$-$include-before$-$endfor$-$body$-$for(include-after)$-$include-after$-$endfor$-$if(author)$-.SH AUTHORS-$for(author)$$author$$sep$; $endfor$.-$endif$+$if(has-tables)$
+.\"t
+$endif$
+.TH "$title$" "$section$" "$date$" "$footer$" "$header$"
+$for(header-includes)$
+$header-includes$
+$endfor$
+$for(include-before)$
+$include-before$
+$endfor$
+$body$
+$for(include-after)$
+$include-after$
+$endfor$
+$if(author)$
+.SH AUTHORS
+$for(author)$$author$$sep$; $endfor$.
+$endif$

outputTemplates/default.markdown view
@@ -1,23 +1,21 @@-$if(titleblock)$-% $title$-% $for(author)$$author$$sep$; $endfor$-% $date$--$endif$-$for(header-includes)$-$header-includes$--$endfor$-$for(include-before)$-$include-before$--$endfor$-$if(toc)$-$toc$--$endif$-$body$-$for(include-after)$--$include-after$-$endfor$+$if(titleblock)$
+$titleblock$
+
+$endif$
+$for(header-includes)$
+$header-includes$
+
+$endfor$
+$for(include-before)$
+$include-before$
+
+$endfor$
+$if(toc)$
+$toc$
+
+$endif$
+$body$
+$for(include-after)$
+
+$include-after$
+$endfor$

outputTemplates/default.mediawiki view
@@ -1,13 +1,13 @@-$for(include-before)$-$include-before$--$endfor$-$if(toc)$-__TOC__--$endif$-$body$-$for(include-after)$--$include-after$-$endfor$+$for(include-before)$
+$include-before$
+
+$endfor$
+$if(toc)$
+__TOC__
+
+$endif$
+$body$
+$for(include-after)$
+
+$include-after$
+$endfor$

outputTemplates/default.opendocument view
@@ -1,27 +1,30 @@-<?xml version="1.0" encoding="utf-8" ?>-<office:document-content xmlns:office="urn:oasis:names:tc:opendocument:xmlns:office:1.0" xmlns:style="urn:oasis:names:tc:opendocument:xmlns:style:1.0" xmlns:text="urn:oasis:names:tc:opendocument:xmlns:text:1.0" xmlns:table="urn:oasis:names:tc:opendocument:xmlns:table:1.0" xmlns:draw="urn:oasis:names:tc:opendocument:xmlns:drawing:1.0" xmlns:fo="urn:oasis:names:tc:opendocument:xmlns:xsl-fo-compatible:1.0" xmlns:xlink="http://www.w3.org/1999/xlink" xmlns:dc="http://purl.org/dc/elements/1.1/" xmlns:meta="urn:oasis:names:tc:opendocument:xmlns:meta:1.0" xmlns:number="urn:oasis:names:tc:opendocument:xmlns:datastyle:1.0" xmlns:svg="urn:oasis:names:tc:opendocument:xmlns:svg-compatible:1.0" xmlns:chart="urn:oasis:names:tc:opendocument:xmlns:chart:1.0" xmlns:dr3d="urn:oasis:names:tc:opendocument:xmlns:dr3d:1.0" xmlns:math="http://www.w3.org/1998/Math/MathML" xmlns:form="urn:oasis:names:tc:opendocument:xmlns:form:1.0" xmlns:script="urn:oasis:names:tc:opendocument:xmlns:script:1.0" xmlns:ooo="http://openoffice.org/2004/office" xmlns:ooow="http://openoffice.org/2004/writer" xmlns:oooc="http://openoffice.org/2004/calc" xmlns:dom="http://www.w3.org/2001/xml-events" xmlns:xforms="http://www.w3.org/2002/xforms" xmlns:xsd="http://www.w3.org/2001/XMLSchema" xmlns:xsi="http://www.w3.org/2001/XMLSchema-instance" office:version="1.0">-  $automatic-styles$-$for(header-includes)$-  $header-includes$-$endfor$  -<office:body>-<office:text>-$if(title)$-<text:h text:style-name="Heading_20_1" text:outline-level="1">$title$</text:h>-$endif$-$for(author)$-<text:p text:style-name="Author">$author$</text:p>-$endfor$-$if(date)$-<text:p text:style-name="Date">$date$</text:p>-$endif$-$for(include-before)$-$include-before$-$endfor$-$body$-$for(include-after)$-$include-after$-$endfor$-</office:text>-</office:body>-</office:document-content>+<?xml version="1.0" encoding="utf-8" ?>
+<office:document-content xmlns:office="urn:oasis:names:tc:opendocument:xmlns:office:1.0" xmlns:style="urn:oasis:names:tc:opendocument:xmlns:style:1.0" xmlns:text="urn:oasis:names:tc:opendocument:xmlns:text:1.0" xmlns:table="urn:oasis:names:tc:opendocument:xmlns:table:1.0" xmlns:draw="urn:oasis:names:tc:opendocument:xmlns:drawing:1.0" xmlns:fo="urn:oasis:names:tc:opendocument:xmlns:xsl-fo-compatible:1.0" xmlns:xlink="http://www.w3.org/1999/xlink" xmlns:dc="http://purl.org/dc/elements/1.1/" xmlns:meta="urn:oasis:names:tc:opendocument:xmlns:meta:1.0" xmlns:number="urn:oasis:names:tc:opendocument:xmlns:datastyle:1.0" xmlns:svg="urn:oasis:names:tc:opendocument:xmlns:svg-compatible:1.0" xmlns:chart="urn:oasis:names:tc:opendocument:xmlns:chart:1.0" xmlns:dr3d="urn:oasis:names:tc:opendocument:xmlns:dr3d:1.0" xmlns:math="http://www.w3.org/1998/Math/MathML" xmlns:form="urn:oasis:names:tc:opendocument:xmlns:form:1.0" xmlns:script="urn:oasis:names:tc:opendocument:xmlns:script:1.0" xmlns:ooo="http://openoffice.org/2004/office" xmlns:ooow="http://openoffice.org/2004/writer" xmlns:oooc="http://openoffice.org/2004/calc" xmlns:dom="http://www.w3.org/2001/xml-events" xmlns:xforms="http://www.w3.org/2002/xforms" xmlns:xsd="http://www.w3.org/2001/XMLSchema" xmlns:xsi="http://www.w3.org/2001/XMLSchema-instance" office:version="1.2">
+  <office:font-face-decls>
+    <style:font-face style:name="Courier New" style:font-family-generic="modern" style:font-pitch="fixed" svg:font-family="'Courier New'" />
+  </office:font-face-decls>
+  $automatic-styles$
+$for(header-includes)$
+  $header-includes$
+$endfor$
+<office:body>
+<office:text>
+$if(title)$
+<text:h text:style-name="Title">$title$</text:h>
+$endif$
+$for(author)$
+<text:p text:style-name="Author">$author$</text:p>
+$endfor$
+$if(date)$
+<text:p text:style-name="Date">$date$</text:p>
+$endif$
+$for(include-before)$
+$include-before$
+$endfor$
+$body$
+$for(include-after)$
+$include-after$
+$endfor$
+</office:text>
+</office:body>
+</office:document-content>

+ outputTemplates/default.opml view
@@ -0,0 +1,11 @@+<?xml version="1.0" encoding="UTF-8"?>
+<opml version="2.0">
+  <head>
+    <title>$title$</title>
+    <dateModified>$date$</dateModified>
+    <ownerName>$for(author)$$author$$sep$; $endfor$</ownerName>
+  </head>
+  <body>
+$body$
+  </body>
+</opml>

outputTemplates/default.org view
@@ -1,24 +1,24 @@-$if(title)$-$title$--$endif$-$if(author)$-#+AUTHOR: $for(author)$$author$$sep$; $endfor$-$endif$-$if(date)$-#+DATE: $date$--$endif$-$for(header-includes)$-$header-includes$--$endfor$-$for(include-before)$-$include-before$--$endfor$-$body$-$for(include-after)$--$include-after$-$endfor$+$if(title)$
+#+TITLE: $title$
+
+$endif$
+$if(author)$
+#+AUTHOR: $for(author)$$author$$sep$; $endfor$
+$endif$
+$if(date)$
+#+DATE: $date$
+
+$endif$
+$for(header-includes)$
+$header-includes$
+
+$endfor$
+$for(include-before)$
+$include-before$
+
+$endfor$
+$body$
+$for(include-after)$
+
+$include-after$
+$endfor$

outputTemplates/default.plain view
@@ -1,23 +1,21 @@-$if(titleblock)$-$title$-$for(author)$$author$$sep$; $endfor$-$date$--$endif$-$for(header-includes)$-$header-includes$--$endfor$-$for(include-before)$-$include-before$--$endfor$-$if(toc)$-$toc$--$endif$-$body$-$for(include-after)$--$include-after$-$endfor$+$if(titleblock)$
+$titleblock$
+
+$endif$
+$for(header-includes)$
+$header-includes$
+
+$endfor$
+$for(include-before)$
+$include-before$
+
+$endfor$
+$if(toc)$
+$toc$
+
+$endif$
+$body$
+$for(include-after)$
+
+$include-after$
+$endfor$

+ outputTemplates/default.revealjs view
@@ -0,0 +1,108 @@+<!DOCTYPE html>
+<html$if(lang)$ lang="$lang$"$endif$>
+<head>
+  <meta charset="utf-8">
+  <meta name="generator" content="pandoc">
+$for(author-meta)$
+  <meta name="author" content="$author-meta$" />
+$endfor$
+$if(date-meta)$
+  <meta name="dcterms.date" content="$date-meta$" />
+$endif$
+  <title>$if(title-prefix)$$title-prefix$ - $endif$$pagetitle$</title>
+  <meta name="apple-mobile-web-app-capable" content="yes" />
+  <meta name="apple-mobile-web-app-status-bar-style" content="black-translucent" />
+  <meta name="viewport" content="width=device-width, initial-scale=1.0, maximum-scale=1.0, user-scalable=no">
+  <link rel="stylesheet" href="$revealjs-url$/css/reveal.min.css"/>
+    <style type="text/css">code{white-space: pre;}</style>
+$if(highlighting-css)$
+    <style type="text/css">
+$highlighting-css$
+    </style>
+$endif$
+$if(css)$
+$for(css)$
+    <link rel="stylesheet" href="$css$"/>
+$endfor$
+$else$
+    <link rel="stylesheet" href="$revealjs-url$/css/theme/simple.css" id="theme">
+$endif$
+    <!-- If the query includes 'print-pdf', include the PDF print sheet -->
+    <script>
+      if( window.location.search.match( /print-pdf/gi ) ) {
+        var link = document.createElement( 'link' );
+        link.rel = 'stylesheet';
+        link.type = 'text/css';
+        link.href = '$revealjs-url$/css/print/pdf.css';
+        document.getElementsByTagName( 'head' )[0].appendChild( link );
+      }
+    </script>
+    <!--[if lt IE 9]>
+    <script src="$revealjs-url$/lib/js/html5shiv.js"></script>
+    <![endif]-->
+$if(math)$
+    $math$
+$endif$
+$for(header-includes)$
+    $header-includes$
+$endfor$
+</head>
+<body>
+$for(include-before)$
+$include-before$
+$endfor$
+  <div class="reveal">
+    <div class="slides">
+
+$if(title)$
+<section>
+    <h1 class="title">$title$</h1>
+$if(subtitle)$
+  <h1 class="subtitle">$subtitle$</h1>
+$endif$
+$for(author)$
+    <h2 class="author">$author$</h2>
+$endfor$
+    <h3 class="date">$date$</h3>
+</section>
+$endif$
+$if(toc)$
+<section id="$idprefix$TOC">
+$toc$
+</section>
+$endif$
+
+$body$
+    </div>
+  </div>
+
+
+  <script src="$revealjs-url$/lib/js/head.min.js"></script>
+  <script src="$revealjs-url$/js/reveal.min.js"></script>
+
+  <script>
+
+      // Full list of configuration options available here:
+      // https://github.com/hakimel/reveal.js#configuration
+      Reveal.initialize({
+        controls: true,
+        progress: true,
+        history: true,
+        center: true,
+        theme: $if(theme)$'$theme$'$else$Reveal.getQueryHash().theme$endif$, // available themes are in /css/theme
+        transition: $if(transition)$'$transition$'$else$Reveal.getQueryHash().transition || 'default'$endif$, // default/cube/page/concave/zoom/linear/fade/none
+
+        // Optional libraries used to extend on reveal.js
+        dependencies: [
+          { src: '$revealjs-url$/lib/js/classList.js', condition: function() { return !document.body.classList; } },
+          { src: '$revealjs-url$/plugin/zoom-js/zoom.js', async: true, condition: function() { return !!document.body.classList; } },
+          { src: '$revealjs-url$/plugin/notes/notes.js', async: true, condition: function() { return !!document.body.classList; } },
+//          { src: '$revealjs-url$/plugin/search/search.js', async: true, condition: function() { return !!document.body.classList; }, }
+//          { src: '$revealjs-url$/plugin/remotes/remotes.js', async: true, condition: function() { return !!document.body.classList; } }
+]});
+    </script>
+  $for(include-after)$
+  $include-after$
+  $endfor$
+  </body>
+</html>

outputTemplates/default.rst view
@@ -1,39 +1,42 @@-$if(title)$-$title$--$endif$-$for(author)$-:Author: $author$-$endfor$-$if(date)$-:Date:   $date$-$endif$-$if(author)$--$else$-$if(date)$--$endif$-$endif$-$if(math)$-.. role:: math(raw)-   :format: html latex--$endif$-$for(include-before)$-$include-before$--$endfor$-$if(toc)$-.. contents::--$endif$-$for(header-includes)$-$header-includes$--$endfor$-$body$-$for(include-after)$--$include-after$-$endfor$+$if(title)$
+$title$
+
+$endif$
+$for(author)$
+:Author: $author$
+$endfor$
+$if(date)$
+:Date:   $date$
+$endif$
+$if(author)$
+
+$else$
+$if(date)$
+
+$endif$
+$endif$
+$if(math)$
+.. role:: math(raw)
+   :format: html latex
+..
+
+$endif$
+$for(include-before)$
+$include-before$
+
+$endfor$
+$if(toc)$
+.. contents::
+   :depth: $toc-depth$
+..
+
+$endif$
+$for(header-includes)$
+$header-includes$
+
+$endfor$
+$body$
+$for(include-after)$
+
+$include-after$
+$endfor$

outputTemplates/default.rtf view
@@ -1,27 +1,30 @@-{\rtf1\ansi\deff0{\fonttbl{\f0 \fswiss Helvetica;}{\f1 Courier;}}-{\colortbl;\red255\green0\blue0;\red0\green0\blue255;}-\widowctrl\hyphauto-$for(header-includes)$-$header-includes$-$endfor$--$if(title)$-{\pard \qc \f0 \sa180 \li0 \fi0 \b \fs36 $title$\par}-$endif$-$for(author)$-{\pard \qc \f0 \sa180 \li0 \fi0  $author$\par}-$endfor$-$if(date)$-{\pard \qc \f0 \sa180 \li0 \fi0  $date$\par}-$endif$-$if(spacer)$-{\pard \ql \f0 \sa180 \li0 \fi0 \par}-$endif$-$for(include-before)$-$include-before$-$endfor$-$body$-$for(include-after)$-$include-after$-$endfor$-}+{\rtf1\ansi\deff0{\fonttbl{\f0 \fswiss Helvetica;}{\f1 Courier;}}
+{\colortbl;\red255\green0\blue0;\red0\green0\blue255;}
+\widowctrl\hyphauto
+$for(header-includes)$
+$header-includes$
+$endfor$
+
+$if(title)$
+{\pard \qc \f0 \sa180 \li0 \fi0 \b \fs36 $title$\par}
+$endif$
+$for(author)$
+{\pard \qc \f0 \sa180 \li0 \fi0  $author$\par}
+$endfor$
+$if(date)$
+{\pard \qc \f0 \sa180 \li0 \fi0  $date$\par}
+$endif$
+$if(spacer)$
+{\pard \ql \f0 \sa180 \li0 \fi0 \par}
+$endif$
+$if(toc)$
+$toc$
+$endif$
+$for(include-before)$
+$include-before$
+$endfor$
+$body$
+$for(include-after)$
+$include-after$
+$endfor$
+}

outputTemplates/default.s5 view
@@ -1,69 +1,70 @@-<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">-<html xmlns="http://www.w3.org/1999/xhtml">-<head>-  <meta http-equiv="Content-Type" content="text/html; charset=utf-8" />-  <meta name="generator" content="pandoc" />-$for(author)$-  <meta name="author" content="$author$" />-$endfor$-$if(date)$-  <meta name="date" content="$date$" />-$endif$-  <title>$if(title-prefix)$$title-prefix$ - $endif$$if(pagetitle)$$pagetitle$$endif$</title>-  <!-- configuration parameters -->-  <meta name="defaultView" content="slideshow" />-  <meta name="controlVis" content="hidden" />-$if(highlighting-css)$-  <style type="text/css">-$highlighting-css$-  </style>-$endif$-$for(css)$-  <link rel="stylesheet" href="$css$" type="text/css" />-$endfor$-$if(s5includes)$-$s5includes$-$else$-  <!-- style sheet links -->-  <link rel="stylesheet" href="$s5-url$/slides.css" type="text/css" media="projection" id="slideProj" />-  <link rel="stylesheet" href="$s5-url$/outline.css" type="text/css" media="screen" id="outlineStyle" />-  <link rel="stylesheet" href="$s5-url$/print.css" type="text/css" media="print" id="slidePrint" />-  <link rel="stylesheet" href="$s5-url$/opera.css" type="text/css" media="projection" id="operaFix" />-  <!-- S5 JS -->-  <script src="$s5-url$/slides.js" type="text/javascript"></script>-$endif$-$if(math)$-  $math$-$endif$-$for(header-includes)$-  $header-includes$-$endfor$-</head>-<body>-$for(include-before)$-$include-before$-$endfor$-<div class="layout">-<div id="controls"></div>-<div id="currentSlide"></div>-<div id="header"></div>-<div id="footer">-  <h1>$date$</h1>-  <h2>$title$</h2>-</div>-</div>-<div class="presentation">-$if(title)$-<div class="slide">-  <h1>$title$</h1>-  <h3>$for(author)$$author$$sep$<br/>$endfor$</h3>-  <h4>$date$</h4>-</div>-$endif$-$body$-$for(include-after)$-$include-after$-$endfor$-</div>-</body>-</html>+<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
+<html xmlns="http://www.w3.org/1999/xhtml">
+<head>
+  <meta http-equiv="Content-Type" content="text/html; charset=utf-8" />
+  <meta http-equiv="Content-Style-Type" content="text/css" />
+  <meta name="generator" content="pandoc" />
+$for(author-meta)$
+  <meta name="author" content="$author-meta$" />
+$endfor$
+$if(date-meta)$
+  <meta name="date" content="$date-meta$" />
+$endif$
+  <title>$if(title-prefix)$$title-prefix$ - $endif$$pagetitle$</title>
+  <style type="text/css">code{white-space: pre;}</style>
+  <!-- configuration parameters -->
+  <meta name="defaultView" content="slideshow" />
+  <meta name="controlVis" content="hidden" />
+$if(highlighting-css)$
+  <style type="text/css">
+$highlighting-css$
+  </style>
+$endif$
+$for(css)$
+  <link rel="stylesheet" href="$css$" type="text/css" />
+$endfor$
+  <!-- style sheet links -->
+  <link rel="stylesheet" href="$s5-url$/slides.css" type="text/css" media="projection" id="slideProj" />
+  <link rel="stylesheet" href="$s5-url$/outline.css" type="text/css" media="screen" id="outlineStyle" />
+  <link rel="stylesheet" href="$s5-url$/print.css" type="text/css" media="print" id="slidePrint" />
+  <link rel="stylesheet" href="$s5-url$/opera.css" type="text/css" media="projection" id="operaFix" />
+  <!-- S5 JS -->
+  <script src="$s5-url$/slides.js" type="text/javascript"></script>
+$if(math)$
+  $math$
+$endif$
+$for(header-includes)$
+  $header-includes$
+$endfor$
+</head>
+<body>
+$for(include-before)$
+$include-before$
+$endfor$
+<div class="layout">
+<div id="controls"></div>
+<div id="currentSlide"></div>
+<div id="header"></div>
+<div id="footer">
+  <h1>$date$</h1>
+  <h2>$title$</h2>
+</div>
+</div>
+<div class="presentation">
+$if(title)$
+<div class="titleslide slide">
+  <h1>$title$</h1>
+$if(subtitle)$
+  <h1 class="subtitle">$subtitle$</h1>
+$endif$
+  <h2>$for(author)$$author$$sep$<br/>$endfor$</h2>
+  <h3>$date$</h3>
+</div>
+$endif$
+$body$
+$for(include-after)$
+$include-after$
+$endfor$
+</div>
+</body>
+</html>

+ outputTemplates/default.slideous view
@@ -0,0 +1,79 @@+<?xml version="1.0" encoding="utf-8"?>
+<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN"
+ "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
+<html xmlns="http://www.w3.org/1999/xhtml"$if(lang)$ lang="$lang$" xml:lang="$lang$"$endif$>
+<head>
+  <meta http-equiv="Content-Type" content="text/html; charset=utf-8" />
+  <meta http-equiv="Content-Style-Type" content="text/css" />
+  <meta name="generator" content="pandoc" />
+$for(author-meta)$
+  <meta name="author" content="$author-meta$" />
+$endfor$
+$if(date-meta)$
+  <meta name="date" content="$date-meta$" />
+$endif$
+  <title>$if(title-prefix)$$title-prefix$ - $endif$$pagetitle$</title>
+  <style type="text/css">code{white-space: pre;}</style>
+$if(highlighting-css)$
+  <style type="text/css">
+$highlighting-css$
+  </style>
+$endif$
+  <link rel="stylesheet" type="text/css" media="screen, projection, print"
+    href="$slideous-url$/slideous.css" />
+$for(css)$
+  <link rel="stylesheet" type="text/css" media="screen, projection, print"
+   href="$css$" />
+$endfor$
+$if(math)$
+  $math$
+$endif$
+$for(header-includes)$
+  $header-includes$
+$endfor$
+  <script src="$slideous-url$/slideous.js"
+    charset="utf-8" type="text/javascript"></script>
+$if(duration)$
+  <meta name="duration" content="$duration$" />
+$endif$
+</head>
+<body>
+$for(include-before)$
+$include-before$
+$endfor$
+<div id="statusbar">
+<span style="float:right;">
+<span style="margin-right:4em;font-weight:bold;"><span id="slideidx"></span> of {$$slidecount}</span>
+<button id="homebutton" title="first slide">1</button>
+<button id="prevslidebutton" title="previous slide">&laquo;</button>
+<button id="previtembutton" title="previous item">&lsaquo;</button>
+<button id="nextitembutton" title="next item">&rsaquo;</button>
+<button id="nextslidebutton" title="next slide">&raquo;</button>
+<button id="endbutton" title="last slide">{$$slidecount}</button>
+<button id="incfontbutton" title="content">A+</button>
+<button id="decfontbutton" title="first slide">A-</button>
+<select id="tocbox" size="1"><option></option></select>
+</span>
+<span id="eos">&frac12;</span>
+<span title="{$$location}, {$$date}">{$$title}, {$$author}</span>
+</div>
+$if(title)$
+<div class="slide titlepage">
+  <h1 class="title">$title$</h1>
+$if(subtitle)$
+  <h1 class="subtitle">$subtitle$</h1>
+$endif$
+  <p class="author">
+$for(author)$$author$$sep$<br/>$endfor$
+  </p>
+$if(date)$
+  <p class="date">$date$</p>
+$endif$
+</div>
+$endif$
+$body$
+$for(include-after)$
+$include-after$
+$endfor$
+</body>
+</html>

outputTemplates/default.slidy view
@@ -1,76 +1,63 @@-<?xml version="1.0" encoding="utf-8"?>-<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN"- "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">-<html xmlns="http://www.w3.org/1999/xhtml" lang="en" xml:lang="en">-<head>-  <meta http-equiv="Content-Type" content="text/html; charset=utf-8" />-  <meta name="generator" content="pandoc" />-$for(author)$-  <meta name="author" content="$author$" />-$endfor$-$if(date)$-  <meta name="date" content="$date$" />-$endif$-$if(highlighting-css)$-  <title>$if(title-prefix)$$title-prefix$ - $endif$$if(pagetitle)$$pagetitle$$endif$</title>-  <style type="text/css">-/*<![CDATA[*/-$highlighting-css$-/*]]>*/-  </style>-$endif$-$if(slidy-css)$-  <style type="text/css">-/*<![CDATA[*/-$slidy-css$-/*]]>*/-  </style>-$else$-  <link rel="stylesheet" type="text/css" media="screen, projection, print"-    href="$slidy-url$/styles/slidy.css" />-$endif$-$for(css)$-  <link rel="stylesheet" type="text/css" media="screen, projection, print"-   href="$css$" />-$endfor$-$if(math)$-  $math$-$endif$-$for(header-includes)$-  $header-includes$-$endfor$-$if(slidy-js)$-<script type="text/javascript" charset="utf-8">-/*<![CDATA[*/-$slidy-js$-/*]]>*/-</script>-$else$-  <script src="$slidy-url$/scripts/slidy.js.gz"-    charset="utf-8" type="text/javascript"></script>-$endif$-$if(duration)$-  <meta name="duration" content="$duration$" />-$endif$-</head>-<body>-$for(include-before)$-$include-before$-$endfor$-$if(title)$-<div class="slide titlepage">-  <h1 class="title">$title$</h1>-  <p class="author">-$for(author)$$author$$sep$<br/>$endfor$-  </p>-$if(date)$-  <p class="date">$date$</p>-$endif$-</div>-$endif$-$body$-$for(include-after)$-$include-after$-$endfor$-</body>-</html>+<?xml version="1.0" encoding="utf-8"?>
+<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN"
+ "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
+<html xmlns="http://www.w3.org/1999/xhtml"$if(lang)$ lang="$lang$" xml:lang="$lang$"$endif$>
+<head>
+  <meta http-equiv="Content-Type" content="text/html; charset=utf-8" />
+  <meta http-equiv="Content-Style-Type" content="text/css" />
+  <meta name="generator" content="pandoc" />
+$for(author-meta)$
+  <meta name="author" content="$author-meta$" />
+$endfor$
+$if(date-meta)$
+  <meta name="date" content="$date-meta$" />
+$endif$
+  <title>$if(title-prefix)$$title-prefix$ - $endif$$pagetitle$</title>
+  <style type="text/css">code{white-space: pre;}</style>
+$if(highlighting-css)$
+  <style type="text/css">
+$highlighting-css$
+  </style>
+$endif$
+  <link rel="stylesheet" type="text/css" media="screen, projection, print"
+    href="$slidy-url$/styles/slidy.css" />
+$for(css)$
+  <link rel="stylesheet" type="text/css" media="screen, projection, print"
+   href="$css$" />
+$endfor$
+$if(math)$
+  $math$
+$endif$
+$for(header-includes)$
+  $header-includes$
+$endfor$
+  <script src="$slidy-url$/scripts/slidy.js"
+    charset="utf-8" type="text/javascript"></script>
+$if(duration)$
+  <meta name="duration" content="$duration$" />
+$endif$
+</head>
+<body>
+$for(include-before)$
+$include-before$
+$endfor$
+$if(title)$
+<div class="slide titlepage">
+  <h1 class="title">$title$</h1>
+$if(subtitle)$
+  <h1 class="subtitle">$subtitle$</h1>
+$endif$
+  <p class="author">
+$for(author)$$author$$sep$<br/>$endfor$
+  </p>
+$if(date)$
+  <p class="date">$date$</p>
+$endif$
+</div>
+$endif$
+$body$
+$for(include-after)$
+$include-after$
+$endfor$
+</body>
+</html>

outputTemplates/default.texinfo view
@@ -1,64 +1,64 @@-\input texinfo-@documentencoding utf-8-$for(header-includes)$-$header-includes$-$endfor$--$if(strikeout)$-@macro textstrikeout{text}-~~\text\~~-@end macro--$endif$-$if(subscript)$-@macro textsubscript{text}-@iftex-@textsubscript{\text\}-@end iftex-@ifnottex-_@{\text\@}-@end ifnottex-@end macro--$endif$-$if(superscript)$-@macro textsuperscript{text}-@iftex-@textsuperscript{\text\}-@end iftex-@ifnottex-^@{\text\@}-@end ifnottex-@end macro--$endif$-@ifnottex-@paragraphindent 0-@end ifnottex-$if(titlepage)$-@titlepage-@title $title$-$for(author)$-@author $author$-$endfor$-$if(date)$-$date$-$endif$-@end titlepage--$endif$-$for(include-before)$-$include-before$--$endfor$-$if(toc)$-@contents--$endif$-$body$-$for(include-after)$--$include-after$-$endfor$--@bye+\input texinfo
+@documentencoding UTF-8
+$for(header-includes)$
+$header-includes$
+$endfor$
+
+$if(strikeout)$
+@macro textstrikeout{text}
+~~\text\~~
+@end macro
+
+$endif$
+$if(subscript)$
+@macro textsubscript{text}
+@iftex
+@textsubscript{\text\}
+@end iftex
+@ifnottex
+_@{\text\@}
+@end ifnottex
+@end macro
+
+$endif$
+$if(superscript)$
+@macro textsuperscript{text}
+@iftex
+@textsuperscript{\text\}
+@end iftex
+@ifnottex
+^@{\text\@}
+@end ifnottex
+@end macro
+
+$endif$
+@ifnottex
+@paragraphindent 0
+@end ifnottex
+$if(titlepage)$
+@titlepage
+@title $title$
+$for(author)$
+@author $author$
+$endfor$
+$if(date)$
+$date$
+$endif$
+@end titlepage
+
+$endif$
+$for(include-before)$
+$include-before$
+
+$endfor$
+$if(toc)$
+@contents
+
+$endif$
+$body$
+$for(include-after)$
+
+$include-after$
+$endfor$
+
+@bye

outputTemplates/default.textile view
@@ -1,9 +1,9 @@-$for(include-before)$-$include-before$--$endfor$-$body$-$for(include-after)$--$include-after$-$endfor$+$for(include-before)$
+$include-before$
+
+$endfor$
+$body$
+$for(include-after)$
+
+$include-after$
+$endfor$

+ src/Database/Design/Ampersand.hs view
@@ -0,0 +1,110 @@+module Database.Design.Ampersand
+   ( -- Data Constructors:
+     A_Context
+   , P_Context(..), P_Population(..), PairView(..), PairViewSegment(..), SrcOrTgt(..), P_Rule(..), Term(..), TermPrim(..), P_NamedRel(..), P_Sign(..), P_Concept(..), P_Declaration(..), P_Pattern(..), P_Gen(..)
+   , P_Markup(..), PRef2Obj(..), PPurpose(..), PMeaning(..), Meta(..), MetaObj(..)
+   , A_Concept(..), A_Gen(..)
+   , Sign(..), ConceptDef(..), ConceptStructure(..)
+   , Activity(..)
+   , AMeaning(..)
+   , Quad(..), Conjunct(..)
+   , Fswitchboard(..), ECArule(..), Event(..), InsDel(..) -- (required for --haskell output)
+   , Pattern(..)
+   , Declaration(..)
+   , IdentityDef(..)
+   , ViewDef(..)
+   , IdentitySegment(..)
+   , ViewSegment(..)
+   , Expression(..)
+   , Population(..)
+   , FSpec(..), concDefs
+   , PlugSQL(..), SqlField(..), SqlType(..), PlugInfo(..)
+   , PAclause(..)
+   , Rule(..)
+   , Prop(..), RuleOrigin(..)
+   , Lang(..)
+   , SqlFieldUsage(..)
+   , DnfClause(..)
+   , Options(..), DocTheme(..)
+   , Picture(..), writePicture , PictureReq(..), makePicture
+   , FilePos(..), Origin(..), Pos(Pos)
+   , mkPair
+   -- * Classes:
+   , Association(..), flp
+   , Collection(..)
+   , Named(..)
+   , ObjectDef(..)
+   , Relational(..)
+   , Interface(..)
+   , getInterfaceByName
+   , SubInterface(..)
+   , Object(..)
+   , Plugable(..)
+   , Motivated(..)
+   , Traced(..)
+   , Language(..)
+   , ShowHS(..), ShowHSName(..), haskellIdentifier
+   -- * Functions on concepts
+   , (<==>),meet,join,sortWith,atomsOf
+   , smallerConcepts, largerConcepts, rootConcepts
+   -- * Functions on relations
+   -- * Functions on rules
+   -- * Functions on expressions:
+   , conjNF, disjNF, simplify
+   , cfProof,dfProof,normPA
+   , lookupCpt
+   , showPrf
+   , notCpl, isCpl, isPos, isNeg, foldrMapExpression
+      , (.==.), (.|-.), (./\.), (.\/.), (.-.), (./.), (.\.), (.<>.), (.:.), (.!.), (.*.)
+   , deMorganERad, deMorganECps, deMorganEUni, deMorganEIsc
+   , exprUni2list, exprIsc2list, exprCps2list, exprRad2list, exprPrd2list
+   -- * Functions with plugs:
+--   , showPlug, plugFields, tblcontents, plugpath, fldauto, requires, requiredFields, isPlugIndex
+   , showPlug, plugFields, tblcontents, fldauto
+   -- * Parser related stuff
+   , parseADL1pExpr, CtxError
+   , createFSpec
+   , getGeneralizations, getSpecializations
+    -- * Type checking and calculus
+   , Guarded(..), pCtx2aCtx
+   , makeFSpec, getPopulationsFrom
+    -- * Generators of output
+   , generateAmpersandOutput
+   -- * Prettyprinters
+   , ShowADL(..), showSQL, showSign
+   -- * Functions with Options
+   , getOptions
+   , verboseLn, verbose
+   , FileFormat(..),helpNVersionTexts
+   -- * Other functions
+   , eqCl, showErr, unCap,upCap,escapeNonAlphaNum, fatalMsg
+   , ampersandVersionStr, ampersandVersionWithoutBuildTimeStr
+   , Database.Design.Ampersand.Basics.putStr
+   , Database.Design.Ampersand.Basics.hGetContents
+   , Database.Design.Ampersand.Basics.hPutStr
+   , Database.Design.Ampersand.Basics.hPutStrLn
+   , Database.Design.Ampersand.Basics.readFile
+   , Database.Design.Ampersand.Basics.writeFile
+   , fst3, snd3, thd3
+   , blockParenthesize, addToLastLine, indent 
+   , trace, showTrace, showTraceTag
+   -- * Stuff that should probably not be in the prototype
+   , A_Markup(..), blocks2String, aMarkup2String, PandocFormat(..), Meaning(..)
+   , rulefromProp
+   , fullContents, Paire, srcPaire,trgPaire
+   , Purpose(..), ExplObj(..)
+   )
+where
+import Database.Design.Ampersand.Core.AbstractSyntaxTree
+import Database.Design.Ampersand.FSpec.FSpec
+import Database.Design.Ampersand.ADL1
+import Database.Design.Ampersand.Classes
+import Database.Design.Ampersand.Basics
+import Database.Design.Ampersand.FSpec
+import Database.Design.Ampersand.Input
+import Database.Design.Ampersand.Misc
+import Database.Design.Ampersand.Components
+import Database.Design.Ampersand.ADL1.Expression (isPos,isNeg,foldrMapExpression)
+import Database.Design.Ampersand.FSpec.ToFSpec.ADL2Plug (showPlug)
+import Database.Design.Ampersand.FSpec.ToFSpec.NormalForms
+import Database.Design.Ampersand.ADL1.P2A_Converters
+ src/Database/Design/Ampersand/ADL1.hs view
@@ -0,0 +1,72 @@+module Database.Design.Ampersand.ADL1
+   ( module Database.Design.Ampersand.Core.ParseTree
+   , module Database.Design.Ampersand.Core.AbstractSyntaxTree
+   , module Database.Design.Ampersand.ADL1.Expression
+   , module Database.Design.Ampersand.ADL1.ECArule
+   , module Database.Design.Ampersand.ADL1.Rule
+   )
+where
+import Database.Design.Ampersand.Core.ParseTree (
+           PPurpose(..), PRef2Obj(..)
+         , Paire, Pairs, mkPair , srcPaire, trgPaire
+         , Label(..)
+         , FilePos(..), Origin(..), Pos(..), Traced(..)
+         , Prop(..)
+         , P_Concept(..)
+         , P_Sign(..)
+         , P_Context(..), mergeContexts
+         , Meta(..)
+         , MetaObj(..)
+         , P_RoleRelation(..), P_RoleRule(..)
+         , P_Pattern(..)
+         , PairView(..), PairViewSegment(..)
+         , SrcOrTgt(..)
+         , P_Rule(..)
+         , P_IdentDef, P_IdentSegment
+         , P_ViewDef, P_ViewSegment
+         , P_Population(..)
+         , P_ObjectDef
+         , P_Interface(..)
+         , P_SubInterface
+         , Term(..)
+         , TermPrim(..), P_NamedRel(..)
+         , P_Gen(..)
+         , P_Declaration(..)
+         , ConceptDef(..)
+         , gen_concs
+         )
+import Database.Design.Ampersand.Core.AbstractSyntaxTree (
+          A_Concept(..)
+         ,Sign(..),showSign,GenR()
+         , (<==>),meet,join
+         ,A_Context(..)
+         ,Association(..)
+         ,Expression(..)
+         ,A_Gen(..)
+         ,A_Markup(..)
+         ,IdentityDef(..)
+         ,IdentitySegment(..)
+         ,ViewDef(..)
+         ,ViewSegment(..)
+         ,ObjectDef(..)
+         ,SubInterface(..)
+         ,Declaration(..),decusr
+         ,Interface(..)
+         ,Pattern(..)
+         ,Rule(..)
+         ,RuleType(..)
+         ,A_RoleRelation(..)
+         ,Population(..)
+         ,Purpose(..), ExplObj(..)
+         , (.==.), (.|-.), (./\.), (.\/.), (.-.), (./.), (.\.), (.<>.), (.:.), (.!.), (.*.)
+         )
+import Database.Design.Ampersand.ADL1.Expression
+         ( notCpl, isCpl, deMorganERad, deMorganECps, deMorganEUni, deMorganEIsc
+         , exprIsc2list, exprUni2list, exprCps2list, exprRad2list, exprPrd2list
+         , insParentheses)
+import Database.Design.Ampersand.ADL1.ECArule (
+         isAll, isCHC, isBlk, isNop, isDo, eventsFrom)
+import Database.Design.Ampersand.ADL1.Rule (
+          rulefromProp, ruleviolations
+         ,consequent,antecedent,hasantecedent)
+

+ src/Database/Design/Ampersand/ADL1/Disambiguate.hs view
@@ -0,0 +1,274 @@+{-# OPTIONS_GHC -Wall #-}
+module Database.Design.Ampersand.ADL1.Disambiguate(disambiguate, DisambPrim(..),pCpt2aCpt) where
+import Database.Design.Ampersand.Core.ParseTree
+import Database.Design.Ampersand.Core.AbstractSyntaxTree hiding (sortWith, maxima, greatest)
+import Database.Design.Ampersand.Basics (fatalMsg)
+import Control.Applicative
+import Data.Traversable
+import qualified Data.Set as Set
+
+fatal :: Int -> String -> a
+fatal = fatalMsg "ADL1.Disambiguate"
+
+findConcept :: String -> A_Concept
+-- SJC: ONE should be tokenized, so it cannot occur as a string
+-- especially because we require that concepts are identifiable by their name
+-- hence if this line would change the semantics, we have either
+-- (1) made a programming error in the call of findConcept (in which case you should call findConceptOrONE instead)
+-- (2) made an error in the tokenizer/parser
+findConcept "ONE" = fatal 200 "ONE is not a valid name for a concept"
+findConcept x = 
+   PlainConcept { cptnm = x
+                }
+
+
+-- this is *only* used internally!
+data D_Concept
+ = MustBe A_Concept
+ | MayBe  A_Concept 
+ deriving (Show, Eq)
+
+data Constraints = Cnstr {sourceConstraintsOf :: [D_Concept]
+                         ,targetConstraintsOf :: [D_Concept]
+                         }deriving Show
+
+class Traversable d => Disambiguatable d where
+-- To make something Disambiguatable, do the following:
+-- (1) Make sure the type of the Disambiguatable thing has a type variable.
+--     Suppose "Thing" should become disambiguatable, then "Thing" has "TermPrim" inside somewhere.
+--     Change "data Thing =" into "data ThingPolymorphic a =", and change occurences of "TermPrim" into "a".
+--     We changed "Thing" into "ThingPolymorphic" so we can create a type instance for "Thing":
+--     type Thing = ThingPolymorphic TermPrim
+--     This makes sure that "Thing" is the exact same type before and after this change.
+-- (2) Make ThingPolymorphic an instance of Traversable. The default "deriving Traversable" should be fine.
+-- (3) Make ThingPolymorphic an instance of Disambiguatable. It is your responsibility to prevent loops here. The instance looks like this:
+--     disambInfo (Thing1 x y z) td = (Thing1 x' y' z', (bottomUpSourceTypes,bottomUpTargetTypes))
+--      where (x',resultingTypesForX) = disambInfo x' topDownTypesForX
+--            (y',resultingTypesForY) = disambInfo y' topDownTypesForY
+--            (z',resultingTypesForZ) = disambInfo z' topDownTypesForZ
+--     The variables topDownTypesFor... may depend on td,
+--     the variables bottomUpSourceTypes and bottomUpTargetTypes may depend on resultingTypesFor...
+--     Closing the loop (at the top of the structure) is done in the function "disambiguationStep".
+--     Note that disambInfo actually performs two separate functions in one go: one to go top down, the other to go bottom up.
+--     The top-down function may use parts of the bottom-up function, but not the other way around.
+--     A nice example to look at is PCps:
+--         disambInfo (PCps o a b) (ia1,ib1) = ( PCps o a' b', (ia, ib) )
+--          where (a', (ia,ic1)) = disambInfo a (ia1,ic2) -- here ic2 is top-down, so that is ok
+--                (b', (ic2,ib)) = disambInfo b (ic1,ib1)
+  disambInfo :: d (TermPrim,DisambPrim)  --the thing that is disabmiguated
+   -> Constraints -- the inferred types (from the environment = top down) 
+   -> ( d ((TermPrim,DisambPrim), Constraints) -- only the environment for the term (top down)
+      , Constraints -- the inferred type, bottom up (not including the environment, that is: not using the second argument: prevent loops!)
+      )
+  disambiguate :: 
+                (TermPrim -> (TermPrim, DisambPrim)) -- disambiguation function
+                -> d TermPrim -- object to be disambiguated
+                -> d (TermPrim, DisambPrim) -- disambiguated object
+  disambiguate termPrimDisAmb x = fixpoint disambiguationStep (Change (fmap termPrimDisAmb x) False)
+    where
+     fixpoint :: (a -> Change a) -- function for computing a fixpoint
+              -> (Change a) -- has the fixpoint been reached?
+              -> a
+     fixpoint _ (Change a True)  = a
+     fixpoint f (Change a False) = fixpoint f (f a)
+
+  disambiguationStep :: d (TermPrim, DisambPrim) -> Change (d (TermPrim, DisambPrim))
+  disambiguationStep thing = traverse performUpdate withInfo
+      where (withInfo, _) = disambInfo thing noConstraints
+
+noConstraints :: Constraints
+noConstraints = Cnstr [][]  
+
+--TODO: Rename to a more meaningfull name
+fullConstraints :: Constraints -> Constraints
+fullConstraints cs = Cnstr { sourceConstraintsOf = sourceConstraintsOf cs ++ targetConstraintsOf cs
+                           , targetConstraintsOf = sourceConstraintsOf cs ++ targetConstraintsOf cs
+                           }
+                           
+propagateConstraints :: Constraints -> Constraints -> Constraints
+propagateConstraints topDown bottomUp 
+  = Cnstr{sourceConstraintsOf = sourceConstraintsOf topDown ++ sourceConstraintsOf bottomUp
+         ,targetConstraintsOf = targetConstraintsOf topDown ++ targetConstraintsOf bottomUp
+         }
+instance Disambiguatable P_IdentDf where
+  disambInfo (P_Id o nm c []) _ = ( P_Id o nm c [], noConstraints)
+  disambInfo (P_Id o nm c (a:lst)) _     = (P_Id o nm c (a':lst'), Cnstr (sourceConstraintsOf aRestr++sourceConstraintsOf nxt) [])
+       where (a', aRestr)            = disambInfo a (Cnstr [MustBe (pCpt2aCpt c)] [])
+             (P_Id _ _ _ lst', nxt)  = disambInfo (P_Id o nm c lst) (Cnstr [MustBe (pCpt2aCpt c)] [])
+instance Disambiguatable P_IdentSegmnt where
+  disambInfo (P_IdentExp v) x = (P_IdentExp v', rt)
+     where (v',rt) = disambInfo v x
+instance Disambiguatable P_Rule where
+  disambInfo (P_Ru nm expr fps mean msg Nothing) x
+   = (P_Ru nm exp' fps mean msg Nothing, rt)
+   where (exp',rt) = disambInfo expr x
+  disambInfo (P_Ru nm expr fps mean msg (Just viol)) x
+   = (P_Ru nm exp' fps mean msg (Just viol'), rt)
+   where (exp',rt) = disambInfo expr x
+         (PairViewTerm viol',_) -- SJ 20131123: disambiguation does not depend on the contents of this pairview, but must come from outside...
+          = (disambInfo (PairViewTerm viol) rt)
+instance Disambiguatable PairViewTerm where
+  disambInfo (PairViewTerm (PairView lst)) x
+   = (PairViewTerm (PairView [pv' | pv <- lst, let (PairViewSegmentTerm pv',_) = disambInfo (PairViewSegmentTerm pv) x])
+     , noConstraints) -- unrelated
+instance Disambiguatable PairViewSegmentTerm where
+  disambInfo (PairViewSegmentTerm (PairViewText orig s)) _ = (PairViewSegmentTerm (PairViewText orig s), noConstraints)
+  disambInfo (PairViewSegmentTerm (PairViewExp orig st a)) constraints = (PairViewSegmentTerm (PairViewExp orig st res), rt)
+    where (res,rt) = disambInfo a (Cnstr (case st of 
+                                            Src -> sourceConstraintsOf constraints
+                                            Tgt -> targetConstraintsOf constraints) [])
+instance Disambiguatable P_ViewD where
+  disambInfo (P_Vd { vd_pos  = o
+                   , vd_lbl  = s
+                   , vd_cpt  = c
+                   , vd_isDefault = d
+                   , vd_html = h
+                   , vd_ats  = a
+                   }) _ = ( P_Vd o s c d h (map (\x -> fst (disambInfo x constraints)) a)
+                          , constraints
+                          )
+   where constraints = Cnstr [MustBe (pCpt2aCpt c)] []
+
+instance Disambiguatable P_ViewSegmt where
+  disambInfo (P_ViewText a) _ = (P_ViewText a,noConstraints)
+  disambInfo (P_ViewHtml a) _ = (P_ViewHtml a,noConstraints)
+  disambInfo (P_ViewExp a) i = (P_ViewExp a',r)
+    where (a',r) = disambInfo a i
+
+instance Disambiguatable P_SubIfc where
+  disambInfo (P_InterfaceRef a b) _      = (P_InterfaceRef a b,noConstraints)
+  disambInfo (P_Box o cl []   ) _        = (P_Box o cl [],noConstraints)
+  disambInfo (P_Box o cl (a:lst)) env1  = 
+     (P_Box o cl' (a':lst'),Cnstr (sourceConstraintsOf envA++sourceConstraintsOf envB) [])
+   where (a', envA)              = disambInfo a                (Cnstr (sourceConstraintsOf envB++sourceConstraintsOf env1) [])
+         (P_Box _ cl' lst',envB) = disambInfo (P_Box o cl lst) (Cnstr (sourceConstraintsOf env1++sourceConstraintsOf envA) [])
+
+instance Disambiguatable P_ObjDef where
+  disambInfo (P_Obj a b c -- term/expression
+                        v
+                        d -- (potential) subobject
+                        f)
+                        env -- from the environment, only the source is important
+   = (P_Obj a b c' v d' f, Cnstr (sourceConstraintsOf env2) [] -- only source information should be relevant
+     )
+    where
+     (d', env1)
+      = case d of
+           Nothing -> (Nothing,noConstraints)
+           Just si -> (\(x,y)->(Just x,y)) $ disambInfo si (Cnstr (targetConstraintsOf env2) [])
+     (c', env2)
+      = disambInfo c (Cnstr (sourceConstraintsOf env) (sourceConstraintsOf env1))
+instance Disambiguatable Term where
+  disambInfo (PFlp o a  ) env1 = ( PFlp o a', Cnstr (targetConstraintsOf envA)(sourceConstraintsOf envA) )
+   where (a', envA) = disambInfo a (Cnstr (targetConstraintsOf env1)(sourceConstraintsOf env1))
+  disambInfo (PCpl o a  ) env1 = ( PCpl o a', envA )
+   where (a', envA) = disambInfo a env1
+  disambInfo (PBrk o a  ) env1 = ( PBrk o a', envA )
+   where (a', envA) = disambInfo a env1
+  disambInfo (PKl0 o a  ) env1 = ( PKl0 o a', fullConstraints envA )
+   where (a', envA) = disambInfo a (fullConstraints env1)
+  disambInfo (PKl1 o a  ) env1 = ( PKl1 o a', fullConstraints envA )
+   where (a', envA) = disambInfo a (fullConstraints env1)
+  disambInfo (PEqu o a b) env1 = ( PEqu o a' b', propagateConstraints envA envB )
+   where (a', envA) = disambInfo a (propagateConstraints env1 envB)
+         (b', envB) = disambInfo b (propagateConstraints env1 envA)
+  disambInfo (PImp o a b) env1 = ( PImp o a' b', propagateConstraints envA envB )
+   where (a', envA) = disambInfo a (propagateConstraints env1 envB)
+         (b', envB) = disambInfo b (propagateConstraints env1 envA)
+  disambInfo (PIsc o a b) env1 = ( PIsc o a' b', propagateConstraints envA envB )
+   where (a', envA) = disambInfo a (propagateConstraints env1 envB)
+         (b', envB) = disambInfo b (propagateConstraints env1 envA)
+  disambInfo (PUni o a b) env1 = ( PUni o a' b', propagateConstraints envA envB )
+   where (a', envA) = disambInfo a (propagateConstraints env1 envB)
+         (b', envB) = disambInfo b (propagateConstraints env1 envA)
+  disambInfo (PDif o a b) env1 = ( PDif o a' b', propagateConstraints envA envB )
+   where (a', envA) = disambInfo a (propagateConstraints env1 envB)
+         (b', envB) = disambInfo b (propagateConstraints env1 envA)
+  disambInfo (PLrs o a b) env1 = ( PLrs o a' b', Cnstr (sourceConstraintsOf envA) (sourceConstraintsOf envB) )
+   where (a', envA) = disambInfo a (Cnstr (sourceConstraintsOf env1) (targetConstraintsOf envB))
+         (b', envB) = disambInfo b (Cnstr (targetConstraintsOf env1) (targetConstraintsOf envA))
+  disambInfo (PRrs o a b) env1 = ( PRrs o a' b', Cnstr (targetConstraintsOf envA) (targetConstraintsOf envB) )
+   where (a', envA) = disambInfo a (Cnstr (sourceConstraintsOf envB) (sourceConstraintsOf env1))
+         (b', envB) = disambInfo b (Cnstr (sourceConstraintsOf envA) (targetConstraintsOf env1))
+  disambInfo (PDia o a b) env1 = ( PDia o a' b', Cnstr (sourceConstraintsOf envA) (sourceConstraintsOf envB))
+   where (a', envA) = disambInfo a (Cnstr (sourceConstraintsOf env1) (targetConstraintsOf envB))
+         (b', envB) = disambInfo b (Cnstr (targetConstraintsOf env1) (targetConstraintsOf envA))
+  disambInfo (PCps o a b) env1 = ( PCps o a' b', Cnstr (sourceConstraintsOf envA) (targetConstraintsOf envB) )
+   where (a', envA) = disambInfo a (Cnstr (sourceConstraintsOf env1) (sourceConstraintsOf envB))
+         (b', envB) = disambInfo b (Cnstr (targetConstraintsOf envA) (targetConstraintsOf env1))
+  disambInfo (PRad o a b) env1 = ( PRad o a' b', Cnstr (sourceConstraintsOf envA) (targetConstraintsOf envB) )
+   where (a', envA) = disambInfo a (Cnstr (sourceConstraintsOf env1) (sourceConstraintsOf envB))
+         (b', envB) = disambInfo b (Cnstr (targetConstraintsOf envA) (targetConstraintsOf env1))
+  disambInfo (PPrd o a b) env1 = ( PPrd o a' b', Cnstr (sourceConstraintsOf envA) (targetConstraintsOf envB) )
+   where (a', envA) = disambInfo a (Cnstr (sourceConstraintsOf env1) (sourceConstraintsOf envB))
+         (b', envB) = disambInfo b (Cnstr (targetConstraintsOf envA) (targetConstraintsOf env1))
+  disambInfo (Prim (a,b)) st = (Prim ((a,b), st), Cnstr (getDConcepts source b) (getDConcepts target b))
+
+getDConcepts :: (Expression -> A_Concept) -> DisambPrim -> [D_Concept]
+getDConcepts sot (Rel lst) = map (MayBe . sot) lst
+getDConcepts sot (Known e) = [MustBe (sot e)]
+getDConcepts _ _ = []
+
+data DisambPrim
+ = Rel [Expression] -- It is an expression, we don't know which, but it's going to be one of these (usually this is a list of relations)
+ | Ident -- identity, and we know nothing about its type
+ | Vee -- vee, type unknown
+ | Mp1 String -- an atom, type unknown
+ | Known Expression -- It is an expression, and we know exactly which. That is: disambiguation was succesful here
+ deriving Show  -- Here, deriving Show serves debugging purposes only.
+
+performUpdate :: ((t, DisambPrim),
+                     Constraints)
+                     -> Change (t, DisambPrim)
+performUpdate ((t,unkn), Cnstr srcs' tgts')
+ = case unkn of
+     Known _ -> pure (t,unkn)
+     Rel xs  -> determineBySize (\x -> if length x == length xs then pure (Rel xs) else impure (Rel x))
+                ((findMatch' (mustBeSrc,mustBeTgt) xs `orWhenEmpty` findMatch' (mayBeSrc,mayBeTgt) xs)
+                 `orWhenEmpty` xs)
+     Ident   -> determineBySize suggest (map EDcI     (Set.toList possibleConcs))
+     Mp1 s   -> determineBySize suggest (map (EMp1 s) (Set.toList possibleConcs))
+     Vee     -> determineBySize (const (pure unkn))
+                  [EDcV (Sign a b) | a<-Set.toList mustBeSrc, b<-Set.toList mustBeTgt]
+ where
+   suggest [] = pure unkn
+   suggest lst = impure (Rel lst) -- TODO: find out whether it is equivalent to put "pure" here (which could be faster).
+   possibleConcs = (mustBeSrc `isc` mustBeTgt) `orWhenEmptyS`
+                   (mustBeSrc `uni` mustBeTgt) `orWhenEmptyS`
+                   (mayBeSrc  `isc` mayBeTgt ) `orWhenEmptyS`
+                   (mayBeSrc  `uni` mayBeTgt )
+   findMatch' (a,b) = findMatch (Set.toList a,Set.toList b)
+   findMatch ([],[]) _ = []
+   findMatch ([],tgts) lst
+    = [x | x<-lst, target x `elem` tgts]
+   findMatch (srcs,[]) lst
+    = [x | x<-lst, source x `elem` srcs]
+   findMatch (srcs,tgts) lst
+    = [x | x<-lst, source x `elem` srcs, target x `elem` tgts]
+   mustBeSrc = mustBe srcs'
+   mustBeTgt = mustBe tgts'
+   mayBeSrc = mayBe srcs'
+   mayBeTgt = mayBe tgts'
+   mustBe xs = Set.fromList [x | (MustBe x) <- xs]
+   mayBe  xs = Set.fromList [x | (MayBe x) <- xs]
+   orWhenEmptyS a b = if (Set.null a) then b else a
+   orWhenEmpty a b = if (null a) then b else a
+   determineBySize _   [a] = impure (t,Known a)
+   determineBySize err lst = fmap ((,) t) (err lst)
+   impure x = Change x False
+   isc = Set.intersection
+   uni = Set.union
+
+pCpt2aCpt :: P_Concept -> A_Concept
+pCpt2aCpt pc
+    = case pc of
+        PCpt{} -> findConcept (p_cptnm pc)
+        P_Singleton -> ONE
+
+data Change a = Change a Bool
+instance Functor Change where
+ fmap f (Change a b) = Change (f a) b
+instance Applicative Change where
+ (<*>) (Change f b) (Change a b2) = Change (f a) (b && b2)
+ pure a = Change a True
+

+ src/Database/Design/Ampersand/ADL1/ECArule.hs view
@@ -0,0 +1,73 @@+module Database.Design.Ampersand.ADL1.ECArule ( isAll
+                                             , isCHC
+                                             , isBlk
+                                             , isNop
+                                             , isDo
+                                             , eventsFrom
+                                             )
+where
+import Database.Design.Ampersand.Core.AbstractSyntaxTree
+import Database.Design.Ampersand.Basics     (fatalMsg)
+
+  --   Ampersand derives the process logic from the static logic by interpreting an expression in relation algebra as an invariant.
+  --   So how does Ampersand derive dynamic behaviour from static rules? An example may clarify this:
+  --   Suppose you have large shoes that do not fit through your trousers in any way.
+  --   Does this have any consequences for the process of dressing in the morning?
+  --   Well sure it has!
+  --   Since your shoes won't fit through your trousers, you must first put on your trousers, and then put on your shoes.
+  --   So the order of putting on trousers and putting on shoes is dictated by the (static) fact that your shoes are too big to fit through your trousers.
+  --   When undressing, the order is reversed: you must take off your shoes before taking off your trousers.
+  --   This example ilustrates how the order of activities is restricted by an invariant property.
+  --   So it is possible to derive some dynamic behaviour from static properties.
+  --   The following datatypes form a process algebra.
+fatal :: Int -> String -> a
+fatal = fatalMsg "ADL1.ECArule"
+
+isAll :: PAclause -> Bool
+isAll ALL{} = True
+isAll _     = False
+
+isCHC :: PAclause -> Bool
+isCHC CHC{} = True
+isCHC _     = False
+
+isBlk :: PAclause -> Bool
+isBlk Blk{} = True
+isBlk _     = False
+
+isNop :: PAclause -> Bool
+isNop Nop{} = True
+isNop _     = False
+
+isDo :: PAclause -> Bool
+isDo Do{}   = True
+isDo _      = False
+
+{-
+             | Do  { paSrt :: InsDel                     -- do Insert or Delete
+                    , paTo :: Declaration                 -- into toExpr    or from toExpr
+                    , paDelta :: Expression               -- delta
+                    , paMotiv :: [(Expression,[Rule] )]
+
+              | New { paCpt :: A_Concept                  -- make a new instance of type c
+                    , paCl :: String->PAclause            -- to be done after creating the concept
+                    , paMotiv :: [(Expression,[Rule] )]
+                    }
+              | Rmv { paCpt :: A_Concept                  -- Remove an instance of type c
+                    , paCl :: String->PAclause            -- to be done afteremoving the concept
+                    , paMotiv :: [(Expression,[Rule] )]
+                    }
+-}
+
+-- | eventsFrom is written for constructing switchboard diagrams.
+eventsFrom :: PAclause -> [Event]   -- gather all Do's from a PAclause
+eventsFrom p@CHC{}          = concatMap eventsFrom (paCls p)
+eventsFrom p@GCH{}          = concatMap eventsFrom [ paClause | (_,_,paClause)<-paGCls p]
+eventsFrom p@ALL{}          = concatMap eventsFrom (paCls p)
+eventsFrom (Do tOp dcl _ _) = [On tOp dcl]
+eventsFrom p@New{}          = On Ins (Isn (paCpt p)): eventsFrom (paCl p "x")
+eventsFrom p@Rmv{}          = On Del (Isn (paCpt p)): eventsFrom (paCl p "x")
+eventsFrom Nop{}            = []
+eventsFrom Blk{}            = []
+eventsFrom Let{}            = fatal 56 "eventsFrom not defined for `Let` constructor of PAclause"
+eventsFrom Ref{}            = fatal 57 "eventsFrom not defined for `Ref` constructor of PAclause"

+ src/Database/Design/Ampersand/ADL1/Expression.hs view
@@ -0,0 +1,217 @@+{-# LANGUAGE TypeSynonymInstances , OverlappingInstances #-}
+module Database.Design.Ampersand.ADL1.Expression (
+                       subst
+                      ,foldlMapExpression,foldrMapExpression
+                      ,primitives,isMp1, isEEps
+                      ,isPos,isNeg, deMorganERad, deMorganECps, deMorganEUni, deMorganEIsc, notCpl, isCpl
+                      ,exprIsc2list, exprUni2list, exprCps2list, exprRad2list, exprPrd2list
+                      ,insParentheses)
+where
+import Database.Design.Ampersand.Basics (uni)
+import Database.Design.Ampersand.Core.AbstractSyntaxTree
+--import Debug.Trace
+
+-- fatal :: Int -> String -> a
+-- fatal = fatalMsg "ADL1.Expression"
+
+-- | subst is used to replace each occurrence of a relation
+--   with an expression. The parameter expr will therefore be applied to an
+--   expression of the form Erel rel.
+subst :: (Declaration,Expression) -> Expression -> Expression
+subst (decl,expr) = subs
+     where
+       subs (EEqu (l,r)) = EEqu (subs l,subs r)
+       subs (EImp (l,r)) = EImp (subs l,subs r)
+       subs (EIsc (l,r)) = EIsc (subs l,subs r)
+       subs (EUni (l,r)) = EUni (subs l,subs r)
+       subs (EDif (l,r)) = EDif (subs l,subs r)
+       subs (ELrs (l,r)) = ELrs (subs l,subs r)
+       subs (ERrs (l,r)) = ERrs (subs l,subs r)
+       subs (EDia (l,r)) = EDia (subs l,subs r)
+       subs (ECps (l,r)) = ECps (subs l,subs r)
+       subs (ERad (l,r)) = ERad (subs l,subs r)
+       subs (EPrd (l,r)) = EPrd (subs l,subs r)
+       subs (EKl0 e    ) = EKl0 (subs e)
+       subs (EKl1 e    ) = EKl1 (subs e)
+       subs (EFlp e    ) = EFlp (subs e)
+       subs (ECpl e    ) = ECpl (subs e)
+       subs (EBrk e)     = EBrk (subs e)
+       subs e@(EDcD d  ) | d==decl   = expr
+                         | otherwise = e
+       subs e@EDcI{}     = e
+       subs e@EEps{}     = e
+       subs e@EDcV{}     = e
+       subs e@EMp1{}     = e
+
+foldlMapExpression :: (a -> r -> a) -> (Declaration->r) -> a -> Expression -> a
+foldlMapExpression f = foldrMapExpression f' where f' x y = f y x
+
+foldrMapExpression :: (r -> a -> a) -> (Declaration->r) -> a -> Expression -> a
+foldrMapExpression f g a (EEqu (l,r)) = foldrMapExpression f g (foldrMapExpression f g a l) r
+foldrMapExpression f g a (EImp (l,r)) = foldrMapExpression f g (foldrMapExpression f g a l) r
+foldrMapExpression f g a (EIsc (l,r)) = foldrMapExpression f g (foldrMapExpression f g a l) r
+foldrMapExpression f g a (EUni (l,r)) = foldrMapExpression f g (foldrMapExpression f g a l) r
+foldrMapExpression f g a (EDif (l,r)) = foldrMapExpression f g (foldrMapExpression f g a l) r
+foldrMapExpression f g a (ELrs (l,r)) = foldrMapExpression f g (foldrMapExpression f g a l) r
+foldrMapExpression f g a (ERrs (l,r)) = foldrMapExpression f g (foldrMapExpression f g a l) r
+foldrMapExpression f g a (EDia (l,r)) = foldrMapExpression f g (foldrMapExpression f g a l) r
+foldrMapExpression f g a (ECps (l,r)) = foldrMapExpression f g (foldrMapExpression f g a l) r
+foldrMapExpression f g a (ERad (l,r)) = foldrMapExpression f g (foldrMapExpression f g a l) r
+foldrMapExpression f g a (EPrd (l,r)) = foldrMapExpression f g (foldrMapExpression f g a l) r
+foldrMapExpression f g a (EKl0 e)     = foldrMapExpression f g a                         e
+foldrMapExpression f g a (EKl1 e)     = foldrMapExpression f g a                         e
+foldrMapExpression f g a (EFlp e)     = foldrMapExpression f g a                         e
+foldrMapExpression f g a (ECpl e)     = foldrMapExpression f g a                         e
+foldrMapExpression f g a (EBrk e)     = foldrMapExpression f g a                         e
+foldrMapExpression f g a (EDcD d)     = f (g d) a
+foldrMapExpression _ _ a  EDcI{}      = a
+foldrMapExpression _ _ a  EEps{}      = a
+foldrMapExpression _ _ a  EDcV{}      = a
+foldrMapExpression _ _ a  EMp1{}      = a
+
+primitives :: Expression -> [Expression]
+primitives expr =
+  case expr of
+    (EEqu (l,r)) -> primitives l `uni` primitives r
+    (EImp (l,r)) -> primitives l `uni` primitives r
+    (EIsc (l,r)) -> primitives l `uni` primitives r
+    (EUni (l,r)) -> primitives l `uni` primitives r
+    (EDif (l,r)) -> primitives l `uni` primitives r
+    (ELrs (l,r)) -> primitives l `uni` primitives r
+    (ERrs (l,r)) -> primitives l `uni` primitives r
+    (EDia (l,r)) -> primitives l `uni` primitives r
+    (ECps (l,r)) -> primitives l `uni` primitives r
+    (ERad (l,r)) -> primitives l `uni` primitives r
+    (EPrd (l,r)) -> primitives l `uni` primitives r
+    (EKl0 e)     -> primitives e
+    (EKl1 e)     -> primitives e
+    (EFlp e)     -> primitives e
+    (ECpl e)     -> primitives e
+    (EBrk e)     -> primitives e
+    EDcD{}       -> [expr]
+    EDcI{}       -> [expr]
+    EEps{}       -> []  -- Since EEps is inserted for typing reasons only, we do not consider it a primitive..
+    EDcV{}       -> [expr]
+    EMp1{}       -> [expr]
+
+-- | The rule of De Morgan requires care with respect to the complement.
+--   The following function provides a function to manipulate with De Morgan correctly.
+deMorganERad :: Expression -> Expression
+deMorganERad (ECpl (ERad (l,r)))
+  = notCpl (deMorganERad l) .:. notCpl (deMorganERad r)
+deMorganERad (ERad (l,r))
+  = notCpl (notCpl (deMorganERad l) .:. notCpl (deMorganERad r))
+deMorganERad e = e
+deMorganECps :: Expression -> Expression
+deMorganECps (ECpl (ECps (l,r)))
+  = notCpl (deMorganECps l) .!. notCpl (deMorganECps r)
+deMorganECps (ECps (l,r))
+  = notCpl (notCpl (deMorganECps l) .!. notCpl (deMorganECps r))
+deMorganECps e = e
+deMorganEUni :: Expression -> Expression
+deMorganEUni (ECpl (EUni (l,r)))
+  = notCpl (deMorganEUni l) ./\. notCpl (deMorganEUni r)
+deMorganEUni (EUni (l,r))
+  = notCpl (notCpl (deMorganEUni l) ./\. notCpl (deMorganEUni r))
+deMorganEUni e = e
+deMorganEIsc :: Expression -> Expression
+deMorganEIsc (ECpl (EIsc (l,r)))
+  = notCpl (deMorganEIsc l) .\/. notCpl (deMorganEIsc r)
+deMorganEIsc (EIsc (l,r))
+  = notCpl (notCpl (deMorganEIsc l) .\/. notCpl (deMorganEIsc r))
+deMorganEIsc e = e
+
+notCpl :: Expression -> Expression
+notCpl (ECpl e) = e
+notCpl e = ECpl e
+
+isCpl :: Expression -> Bool
+isCpl (ECpl{}) = True
+isCpl _ = False
+
+isPos :: Expression -> Bool
+isPos (ECpl{}) = False
+isPos _ = True
+isNeg :: Expression -> Bool
+isNeg = not . isPos
+
+isMp1 :: Expression -> Bool
+isMp1 EMp1{} = True
+isMp1 _ = False
+
+isEEps :: Expression -> Bool
+isEEps EEps{} = True
+isEEps _ = False
+
+exprIsc2list, exprUni2list, exprCps2list, exprRad2list, exprPrd2list :: Expression -> [Expression]
+exprIsc2list (EIsc (l,r)) = exprIsc2list l++exprIsc2list r
+exprIsc2list r            = [r]
+exprUni2list (EUni (l,r)) = exprUni2list l++exprUni2list r
+exprUni2list r            = [r]
+exprCps2list (ECps (l,r)) = exprCps2list l++exprCps2list r
+exprCps2list r            = [r]
+exprRad2list (ERad (l,r)) = exprRad2list l++exprRad2list r
+exprRad2list r            = [r]
+exprPrd2list (EPrd (l,r)) = exprPrd2list l++exprPrd2list r
+exprPrd2list r            = [r]
+
+insParentheses :: Expression -> Expression
+insParentheses expr = insPar 0 expr
+   where
+     wrap :: Integer -> Integer -> Expression -> Expression
+     wrap i j e' = if i<=j then e' else EBrk (insPar 0 e')
+     insPar :: Integer -> Expression -> Expression
+     insPar i  (EEqu (l,r)) = wrap i 0 (insPar 1 l .==. insPar 1 r)
+     insPar i  (EImp (l,r)) = wrap i 0 (insPar 1 l .|-. insPar 1 r)
+     insPar i x@EIsc{}      = wrap i 2 (foldr1 (./\.) [insPar 3 e | e<-exprIsc2list x ])
+     insPar i x@EUni{}      = wrap i 2 (foldr1 (.\/.) [insPar 3 e | e<-exprUni2list x ])
+     insPar i  (EDif (l,r)) = wrap i 4 (insPar 5 l .-. insPar 5 r)
+     insPar i  (ELrs (l,r)) = wrap i 6 (insPar 7 l ./. insPar 7 r)
+     insPar i  (ERrs (l,r)) = wrap i 6 (insPar 7 l .\. insPar 7 r)
+     insPar i  (EDia (l,r)) = wrap i 6 (insPar 7 l .<>. insPar 7 r)
+     insPar i x@ECps{}      = wrap i 8 (foldr1 (.:.) [insPar 9 e | e<-exprCps2list x ])
+     insPar i x@ERad{}      = wrap i 8 (foldr1 (.!.) [insPar 9 e | e<-exprRad2list x ])
+     insPar i x@EPrd{}      = wrap i 8 (foldr1 (.*.) [insPar 9 e | e<-exprPrd2list x ])
+     insPar _  (EKl0 e)     = EKl0 (insPar 10 e)
+     insPar _  (EKl1 e)     = EKl1 (insPar 10 e)
+     insPar _  (EFlp e)     = EFlp (insPar 10 e)
+     insPar _  (ECpl e)     = ECpl (insPar 10 e)
+     insPar i  (EBrk e)     = insPar i e
+     insPar _  x            = x
+
+{-
+   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
+-}
+

+ src/Database/Design/Ampersand/ADL1/Lattices.hs view
@@ -0,0 +1,293 @@+module Database.Design.Ampersand.ADL1.Lattices (findExact,findSubsets,optimize1,Op1EqualitySystem,addEquality,emptySystem,FreeLattice(..),getGroups,isInSystem) where
+import qualified Data.IntMap as IntMap
+import qualified Data.Map as Map
+import qualified Data.Set as Set
+import qualified Data.IntSet as IntSet
+import Data.List (sort, partition)
+
+-- optimisations possible for the EqualitySystem(s):
+-- (1) apply optimize1 inline, that is: don't use EqualitySystem but use ES1 instead
+-- (2) include the transitively dependent rules recursively
+data EqualitySystem a
+ = ES (Map.Map a Int) -- whatever this is a system of
+      (IntMap.IntMap  -- map for: whenever you encounter this element i in your set y
+         [( IntSet.IntSet -- when you find this set (that is: if it is a subset of y)
+          , IntSet.IntSet -- add this set
+          )]
+      )
+
+emptySystem :: EqualitySystem a
+emptySystem = ES Map.empty IntMap.empty
+
+isInSystem :: (Ord a) => Op1EqualitySystem a -> a -> Bool
+isInSystem (ES1 t _ _) a = Map.member a t
+
+-- | getGroups: create groups of concepts (type variable: concept).
+--   1. Each concept is in precisely one group.
+--   2. Two concepts are in the same group if there is a path of classify-rules between those concepts.
+--   The purpose of this is to know whether two concepts are comparable or not. Atoms of concepts within a group can be compared.
+--   Atoms of concepts in different groups may never be compared.
+getGroups :: (Ord concept, SetLike set) => Op1EqualitySystem concept -> [set concept]
+getGroups (ES1 tran _ imap)
+ = [fromList [a | (a,i) <- Map.toList tran, not . IntSet.null $ IntSet.intersection i r] | r <- IntMap.elems res]
+ where
+   iml :: [(Int,[(IntSet.IntSet,IntSet.IntSet)])]
+   iml = IntMap.toList imap
+   (_, _, res) = foldr getLists (0, IntMap.empty, IntMap.empty) ([(IntSet.insert a (IntSet.union b c)) | (a,bc) <- iml, (b,c)<-bc] ++ Map.elems tran)
+   getLists :: IntSet.IntSet -> (Int, IntMap.IntMap Int, IntMap.IntMap (IntSet.IntSet)) -> (Int, IntMap.IntMap Int, IntMap.IntMap (IntSet.IntSet))
+   getLists im (acc, allElems, rev) -- TODO: this might be made more efficiently by using Array as the last element
+    = if not (IntMap.null overlap) then
+       (acc, newElems, newRev)
+      else (acc+1, IntMap.union (IntMap.fromSet (const acc) im) allElems, IntMap.insert acc im rev)
+    where
+      overlap = IntMap.intersection allElems (IntMap.fromSet id im) -- overlap between im and the previously treated elements
+      oldKeys = IntMap.elems overlap -- sets to which the overlapping items belong
+      newKey = head oldKeys -- get any key name
+      oldKeySet = IntSet.fromList oldKeys -- remove duplicates, provide efficient lookup
+      -- newRev' is all items that will remain the same
+      -- newItm' is all (old) items that must be renamed
+      ~(newItm', newRev') = IntMap.partitionWithKey (\k _ -> IntSet.member k oldKeySet) rev
+      newItm :: IntSet.IntSet
+      newItm = IntSet.unions (im : IntMap.elems newItm') -- all
+      newRev = IntMap.insert newKey newItm newRev'
+      newElems = IntMap.union (IntMap.fromSet (const newKey) newItm) allElems -- overwrites some of the allElems items with the new key
+
+findExact :: (Ord a, SetLike x) => Op1EqualitySystem a -> FreeLattice a -> x a -- returns the empty set on a failure, returns all sets equivalent to "FreeLattice a" according to the equalitysystem
+findExact = findWith lookupInRevMap (\x -> fromList [x])
+findSubsets :: (Ord a, SetLike x) => Op1EqualitySystem a -> FreeLattice a -> [x a] -- returns a list of largest subsets
+findSubsets = findWith findSubsetInRevMap (\x -> [fromList [x]])
+
+findWith :: Ord a
+  => ([Int] -> RevMap a -> b) -- Function that finds the normalized form
+  -> (a -> b)                   -- Shorthand in case the FreeLattice does not need to go through the translation process
+  -> Op1EqualitySystem a        -- system in which the FreeLattice elements can be found
+  -> FreeLattice a              -- the FreeLattice that needs translation
+  -> b
+findWith f f2 es@(ES1 _ back _) trmUnsimplified
+  = case trm of
+     Atom x -> f2 x
+     _ -> f (IntSet.toList (case trm' of
+                       Just t -> intersections (map it t)
+                       Nothing -> IntSet.empty
+                     )
+            ) back
+  where it = simplifySet es
+        intersections [] = IntSet.empty
+        intersections x = foldr1 IntSet.intersection x
+        trm' = latticeToTranslatable es trm
+        trm = simpl trmUnsimplified
+        simpl (Meet a b)
+          = case (simpl a, simpl b) of
+             (Atom a', Atom b') | a'==b' -> Atom a'
+             (a',b') -> Meet a' b'
+        simpl (Join a b)
+          = case (simpl a, simpl b) of
+             (Atom a', Atom b') | a'==b' -> Atom a'
+             (a',b') -> Join a' b'
+        simpl (Atom x) = Atom x
+
+simplifySet :: Op1EqualitySystem t -> IntSet.IntSet -> IntSet.IntSet
+simplifySet (ES1 _ _ imap) x = imapTranslate imap x IntSet.empty
+
+latticeToTranslatable :: Ord a => Op1EqualitySystem a -> FreeLattice a -> Maybe [IntSet.IntSet]
+latticeToTranslatable (ES1 m _ _) lt = t lt
+ where
+   t (Atom a)   = do{r<-Map.lookup a m;return [r]}
+   t (Meet a b) = do{a'<-t a;b'<- t b;return [IntSet.union ta tb | ta <- a', tb <- b']}
+   t (Join a b) = do{a'<-t a;b'<- t b;return (a'++b')}
+
+-- how to lookup something in a RevMap (Precondition: list is sorted!)
+lookupInRevMap :: (Ord a, SetLike x) => [Int] -> RevMap a -> x a
+lookupInRevMap [] (RevMap st _) = fromSet st
+lookupInRevMap (a:as) (RevMap _ mp)
+ = case IntMap.lookup a mp of
+    Nothing -> slEmpty
+    Just rm -> lookupInRevMap as rm
+
+-- a bit slower: suppose we could not find our element in the RevMap, we find all subsets of it (as a RevMap)
+findSubsetAsRevMap :: (Ord a) => [Int] -> RevMap a -> RevMap a
+findSubsetAsRevMap [] (RevMap st _) = RevMap st IntMap.empty
+findSubsetAsRevMap lst (RevMap st mp)
+ = RevMap st (IntMap.fromList [ (l, rm)
+                              | (l, rst) <- listAndRest lst
+                              , (Just mp') <- [IntMap.lookup l mp]
+                              , let rm@(RevMap st2 mp2) = findSubsetAsRevMap rst mp'
+                              , not (Set.null st2 && IntMap.null mp2)
+                              ] )
+
+-- fins the largest subsets! (endpoints only)
+findSubsetInRevMap :: (Ord a, SetLike x) => [Int] -> RevMap a -> [x a]
+findSubsetInRevMap lst rm = largestSubset (findSubsetAsRevMap lst rm)
+
+largestSubset :: (Ord a, SetLike x) => RevMap a -> [x a]
+largestSubset i
+ = elimSubsets (endPoints i)
+ where elimSubsets ((a,v):as) = v : elimSubsets (filter (\x -> not (IntSet.isSubsetOf (fst x) a)) as)
+       elimSubsets [] = []
+
+endPoints :: (Ord a, SetLike x) => RevMap a -> [(IntSet.IntSet,x a)]
+endPoints (RevMap st im)
+ = if (IntMap.null im) then (if slNull st then [] else [(IntSet.empty,fromSet st)]) else concatMap endPoints' (IntMap.toList im)
+ where endPoints' (i,rm) = map addi (endPoints rm)
+        where addi (lst,elm) = (IntSet.insert i lst,elm)
+
+listAndRest :: [t] -> [(t, [t])]
+listAndRest [] = []
+listAndRest (a:rst) = (a,rst):listAndRest rst
+
+data RevMap a
+ = RevMap (Set.Set a) -- all elements equivalent to this point in the map
+          (IntMap.IntMap (RevMap a)) -- recursive
+          deriving Show
+
+data Op1EqualitySystem a
+ = ES1 (Map.Map a (IntSet.IntSet))
+       (RevMap a)
+       (IntMap.IntMap  -- map for: whenever you encounter this element i in your set y
+         [( IntSet.IntSet -- when you find this set (that is: if it is a subset of y)
+          , IntSet.IntSet -- add this set
+          )]
+       )
+
+-- TODO: this function can be optimised a lot
+reverseMap :: (Ord a) => [(a,[Int])] -> RevMap a
+reverseMap lst
+ = RevMap (Set.fromList (map fst empties)) (buildMap rest)
+ where
+   (empties,rest) = partition (null . snd) lst
+   buildMap [] = IntMap.empty
+   buildMap o@((_,~(f:_)):_)
+     = IntMap.insert f (reverseMap (map tail2 h)) (buildMap tl)
+     where tail2 (a,b) = (a, tail b)
+           (h,tl) = partition ((== f) . head . snd) o
+
+optimize1 :: Ord a => EqualitySystem a -> Op1EqualitySystem a
+optimize1 (ES oldmap oldimap)
+ = ES1 newmap
+       (reverseMap (Map.toList (Map.map IntSet.toList newmap)))
+       (IntMap.mapMaybe maybeMapper     oldimap)
+ where notEmpty [] = Nothing
+       notEmpty a = Just a
+       maybeMapper :: [(IntSet.IntSet,IntSet.IntSet)] -> Maybe [(IntSet.IntSet,IntSet.IntSet)]
+       maybeMapper x = notEmpty [ (s1,imapTranslate oldimap s2 (IntSet.empty))
+                                | (s1,s2) <- x
+                                , not (IntSet.null s1)
+                                , not (IntSet.null s2)
+                                ]
+       newmap = Map.map (\x -> imapTranslate oldimap (IntSet.singleton x) (IntSet.empty)) oldmap
+
+addEquality :: (Ord a, SetLike x) => (x a, x a) -> EqualitySystem a -> EqualitySystem a
+addEquality (set1, set2) eqSys0
+ = addEquality' eqSys2 ns1 ns2
+ where
+   (eqSys1, ns1) = translateWith eqSys0 set1
+   (eqSys2, ns2) = translateWith eqSys1 set2
+
+addEquality' :: Ord a => EqualitySystem a -> IntSet.IntSet -> IntSet.IntSet -> EqualitySystem a
+addEquality' ~(ES nms imap) set1 set2
+ = ES nms (addRule (addRule imap set1 set1 uni) set2 (IntSet.difference set2 set1) uni)
+ where
+   uni = IntSet.union set1 set2
+   addRule :: IntMap.IntMap [(IntSet.IntSet, IntSet.IntSet)] -> IntSet.IntSet -> IntSet.IntSet -> IntSet.IntSet -> IntMap.IntMap [(IntSet.IntSet, IntSet.IntSet)]
+   addRule oldimap origSet triggers newSet
+    = foldl updateMapForTrigger oldimap (IntSet.toList triggers)
+    where dif = IntSet.difference newSet origSet
+          updateMapForTrigger :: IntMap.IntMap [(IntSet.IntSet, IntSet.IntSet)] -> Int -> IntMap.IntMap [(IntSet.IntSet, IntSet.IntSet)]
+          updateMapForTrigger mp trigger
+           = IntMap.insertWith (++) trigger [(IntSet.delete trigger origSet, dif)] mp
+
+translateWith :: (Ord a, SetLike x) => EqualitySystem a -> x a -> (EqualitySystem a, IntSet.IntSet)
+translateWith ~(ES nomenclature imap) inSet
+ = ( ES newNomenclature imap
+   , IntSet.fromList$ map (newNomenclature Map.!) (getList inSet)
+   )
+ where
+  newNomenclature
+   = foldr (\x y -> if Map.member x y then y else Map.insert x (Map.size y) y) nomenclature (getList inSet)
+
+imapTranslate :: IntMap.IntMap [(IntSet.IntSet, IntSet.IntSet)] -> IntSet.IntSet -> IntSet.IntSet -> IntSet.IntSet
+imapTranslate imap tds doneSet
+ = case IntSet.minView tds of
+    Nothing -> doneSet
+    Just (todo,set) -> imapTranslate imap (newSet todo set) (IntSet.insert todo doneSet)
+ where
+  newSet todo set
+   = case IntMap.lookup todo imap of
+       Nothing -> set
+       Just lst -> IntSet.unions (set:[IntSet.difference tl doneSet | (fl,tl) <- lst, IntSet.isSubsetOf fl doneSet])
+
+data FreeLattice a
+ = Join (FreeLattice a) (FreeLattice a)
+ | Meet (FreeLattice a) (FreeLattice a)
+ | Atom a
+
+instance SetLike [] where
+  fromList = id
+  fromSet = Set.toList
+  toSet = Set.fromList
+  getList = id
+  slUnion a b = mrgUnion a b
+  slIsect a b = mrgIsect a b
+  slFold = foldl
+  slNull = null
+  slSize = length
+
+instance SetLike Set.Set where
+  slIsect = Set.intersection
+  slUnion = Set.union
+  slEmpty = Set.empty
+  slUnions = Set.unions
+  slMap = Set.map
+  getList = Set.toList
+  fromList = Set.fromList
+  fromSet = id
+  isElemOf = Set.member
+  slFold f = Set.fold (flip f)
+  slNull = Set.null
+  slSize = Set.size
+  slInsert = Set.insert
+  toSet = id
+
+class SetLike x where -- I dislike having to put Ord everywhere, is there another way? (Without including a in the class)
+  slIsect :: Ord a => x a -> x a -> x a
+  slUnion :: Ord a => x a -> x a -> x a
+  getList :: Ord a => x a -> [a]
+  fromList :: Ord a => [a] -> x a
+  fromSet :: Ord a => Set.Set a -> x a
+  slMap :: (Ord a,Ord b) => (a -> b) -> x a -> x b
+  slMap f = fromList . nub' . sort . (map f) . getList
+  slEmpty :: Ord a => x a
+  slEmpty = fromList []
+  slUnions :: Ord a => [x a] -> x a
+  slUnions = foldr slUnion slEmpty
+  isElemOf :: Ord a => a -> x a -> Bool
+  isElemOf e mp = (e `elem` getList mp)
+  slFold :: Ord b => (a -> b -> a) -> a -> x b -> a
+  slFold f u xs = foldl f u (getList xs)
+  slSize :: Ord a => x a -> Int
+  slSize = length . getList
+  slNull :: Ord a => x a -> Bool
+  slNull = null . getList
+  slInsert :: Ord a => a -> x a -> x a
+  slInsert x = slUnion (fromList [x])
+  toSet :: Ord a => x a -> Set.Set a
+
+nub' :: Eq a => [a] -> [a]
+nub' (a:b:bs) | a == b = nub' (b:bs)
+              | otherwise = a:nub' (b:bs)
+nub' rst = rst
+
+mrgUnion :: (Ord a) => [a] -> [a] -> [a]
+mrgUnion (a:as) (b:bs) | a<b       = a:mrgUnion as (b:bs)
+                       | a==b      = a:mrgUnion as bs
+                       | otherwise = b:mrgUnion (a:as) bs
+mrgUnion a b = a ++ b -- since either a or b is the empty list
+{-# SPECIALIZE mrgUnion :: [Int] -> [Int] -> [Int] #-}
+
+mrgIsect :: (Ord a) => [a] -> [a] -> [a]
+mrgIsect (a:as) (b:bs) | a<b       = mrgIsect as (b:bs)
+                       | a==b      = b: mrgIsect as bs
+                       | otherwise = mrgIsect (a:as) bs
+mrgIsect _ _ = [] -- since either a or b is the empty list
+{-# SPECIALIZE mrgIsect :: [Int] -> [Int] -> [Int] #-}
+

+ src/Database/Design/Ampersand/ADL1/P2A_Converters.hs view
@@ -0,0 +1,784 @@+{-# OPTIONS_GHC -Wall #-}
+{-# LANGUAGE LambdaCase #-}
+module Database.Design.Ampersand.ADL1.P2A_Converters (pCtx2aCtx,pCpt2aCpt)
+where
+import Database.Design.Ampersand.ADL1.Disambiguate
+import Database.Design.Ampersand.Core.ParseTree -- (P_Context(..), A_Context(..))
+import Database.Design.Ampersand.Input.ADL1.CtxError
+import Database.Design.Ampersand.ADL1.Lattices -- used for type-checking
+import Database.Design.Ampersand.Core.AbstractSyntaxTree hiding (sortWith, maxima, greatest)
+import Database.Design.Ampersand.Classes.ViewPoint hiding (gens)
+import Database.Design.Ampersand.Classes.ConceptStructure
+import Database.Design.Ampersand.Basics
+import Database.Design.Ampersand.Misc
+import Prelude hiding (sequence, mapM)
+import Control.Applicative
+import Data.Traversable
+import qualified Data.Set as Set
+import qualified Data.Map as Map
+import Data.Function
+import Data.Maybe
+import Data.List(nub)
+
+fatal :: Int -> String -> a
+fatal = fatalMsg "ADL1.P2A_Converters"
+
+newtype SignOrd = SignOrd Sign
+instance Ord SignOrd where
+  compare (SignOrd (Sign a b)) (SignOrd (Sign c d)) = compare (name a,name b) (name c,name d)
+instance Eq SignOrd where
+  (==) (SignOrd (Sign a b)) (SignOrd (Sign c d)) = (name a,name b) == (name c,name d)
+
+-- pCtx2aCtx has three tasks:
+-- 1) Disambiguate the structures.
+--    Disambiguation means replacing every "TermPrim" (the parsed expression) with the correct Expression (available through DisambPrim)
+--    This is done by using the function "disambiguate" on the outer-most structure.
+--    In order to do this, its data type must be polymorphic, as in "P_ViewSegmt a".
+--    After parsing, the type has TermPrim for the type variable. In our example: "P_ViewSegmt TermPrim". Note that "type P_ViewSegment = P_ViewSegmt TermPrim".
+--    After disambiguation, the type variable is (TermPrim, DisambPrim), as in "P_ViewSegmt (TermPrim, DisambPrim)"
+-- 2) Typecheck the structures.
+--    This changes the data-structure entirely, changing the P_ into the A_
+--    A "Guarded" will be added on the outside, in order to catch both type errors and disambiguation errors.
+--    Using the Applicative operations <$> and <*> causes these errors to be in parallel
+-- 3) Check everything else on the A_-structure: interface references should not be cyclic, rules e.a. must have unique names, etc.
+-- Part 3 is done below, the other two are done in pCtx2aCtx'
+pCtx2aCtx :: Options -> P_Context -> Guarded A_Context
+pCtx2aCtx opts = checkOtherAtomsInSessionConcept
+               . checkPurposes             -- Check whether all purposes refer to existing objects
+               . checkDanglingRulesInRuleRoles -- Check whether all rules in MAINTAIN statements are declared
+               . checkInterfaceCycles      -- Check that interface references are not cyclic
+               . checkMultipleDefaultViews -- Check whether each concept has at most one default view
+               . checkUnique udefrules     -- Check uniquene names of: rules,
+               . checkUnique patterns      --                          patterns,
+               . checkUnique ctxvs         --                          view defs,
+               . checkUnique ctxifcs       --                          and interfaces.
+               . pCtx2aCtx' opts
+  where
+    checkUnique f gCtx =
+     case gCtx of
+       Checked ctx -> case uniqueNames (f ctx) of
+                         Checked () -> gCtx
+                         Errors err -> Errors err
+       Errors err -> Errors err
+
+-- NOTE: Static checks like checkPurposes should ideally occur on the P-structure before type-checking, as it makes little
+-- sense to do type checking when there are static errors. However, in Ampersand all collect functions (e.g. in ViewPoint)
+-- only exist on the A-Structure, so we do it afterwards. Static purpose errors won't affect types, so in this case it is no problem. 
+
+-- Check whether all purposes refer to existing objects.
+checkPurposes :: Guarded A_Context -> Guarded A_Context
+checkPurposes gCtx =
+  case gCtx of
+    Errors err  -> Errors err
+    Checked ctx -> let topLevelPurposes = ctxps ctx
+                       purposesInPatterns = concatMap ptxps (ctxpats ctx)
+                       allPurposes = topLevelPurposes ++ purposesInPatterns
+                       danglingPurposes = filter (isDanglingPurpose ctx) allPurposes
+                   in  if null danglingPurposes then gCtx else Errors $ map mkDanglingPurposeError danglingPurposes
+
+-- Return True if the ExplObj in this Purpose does not exist.
+isDanglingPurpose :: A_Context -> Purpose -> Bool
+isDanglingPurpose ctx purp = 
+  case explObj purp of
+    ExplConceptDef concDef -> let nm = name concDef in nm `notElem` map name (ctxcds ctx )
+    ExplDeclaration decl -> let nm = name decl in nm `notElem` map name (relsDefdIn ctx) -- is already covered by type checker
+    ExplRule nm -> nm `notElem` map name (udefrules ctx) 
+    ExplIdentityDef nm -> nm `notElem` map name (identities ctx)
+    ExplViewDef nm ->  nm `notElem` map name (viewDefs ctx)
+    ExplPattern nm -> nm `notElem` map name (ctxpats ctx)
+    ExplInterface nm -> nm `notElem` map name (ctxifcs ctx)
+    ExplContext nm -> ctxnm ctx /= nm 
+                         && False -- HJO: This line is a workaround for the issue mentioned in https://github.com/AmpersandTarski/ampersand/issues/46
+                                  -- TODO: fix this when we pick up working on multiple contexts.
+-- Check that interface references are not cyclic
+checkInterfaceCycles :: Guarded A_Context -> Guarded A_Context
+checkInterfaceCycles gCtx =
+  case gCtx of
+    Errors err  -> Errors err
+    Checked ctx -> if null interfaceCycles then gCtx else Errors $  map mkInterfaceRefCycleError interfaceCycles
+      where interfaceCycles = [ map lookupInterface iCycle | iCycle <- getCycles refsPerInterface ]
+            refsPerInterface = [(name ifc, getDeepIfcRefs $ ifcObj ifc) | ifc <- ctxifcs ctx ]
+            getDeepIfcRefs obj = case objmsub obj of
+                                   Nothing                -> []
+                                   Just (InterfaceRef nm) -> [nm]
+                                   Just (Box _ _ objs)    -> concatMap getDeepIfcRefs objs
+            lookupInterface nm = case [ ifc | ifc <- ctxifcs ctx, name ifc == nm ] of
+                                   [ifc] -> ifc
+                                   _     -> fatal 124 "Interface lookup returned zero or more than one result"
+
+-- Check whether each concept has at most one default view
+checkMultipleDefaultViews :: Guarded A_Context -> Guarded A_Context
+checkMultipleDefaultViews gCtx =
+  case gCtx of
+    Errors err  -> Errors err
+    Checked ctx -> let conceptsWithMultipleViews = [ (c,vds)| vds@(Vd{vdcpt=c}:_:_) <- eqClass ((==) `on` vdcpt) $ filter vdIsDefault (ctxvs ctx) ]
+                   in  if null conceptsWithMultipleViews then gCtx else Errors $ map mkMultipleDefaultError conceptsWithMultipleViews
+
+checkDanglingRulesInRuleRoles :: Guarded A_Context -> Guarded A_Context
+checkDanglingRulesInRuleRoles gCtx =
+  case gCtx of
+    Errors _  -> gCtx
+    Checked ctx -> case [mkDanglingRefError "Rule" nm (arPos rr)  
+                        | rr <- ctxrrules ctx
+                        , nm <- arRules rr
+                        , nm `notElem` map name (allRules ctx)
+                        ] of
+                     [] -> gCtx
+                     errs -> Errors errs
+checkOtherAtomsInSessionConcept :: Guarded A_Context -> Guarded A_Context
+checkOtherAtomsInSessionConcept gCtx =
+   case gCtx of
+     Errors _  -> gCtx
+     Checked ctx -> case [mkOtherAtomInSessionError atom
+                         | pop@PCptPopu{popcpt =cpt} <- ctxpopus ctx
+                         , name cpt == "SESSION"
+                         , atom <- filter (/= "_SESSION") (popas pop)
+                         ] of
+                      [] -> gCtx
+                      errs -> Errors errs
+
+pCtx2aCtx' :: Options -> P_Context -> Guarded A_Context
+pCtx2aCtx' _
+ PCtx { ctx_nm     = n1
+      , ctx_pos    = n2
+      , ctx_lang   = lang
+      , ctx_markup = pandocf
+      , ctx_thms   = p_themes 
+      , ctx_pats   = p_patterns
+      , ctx_PPrcs  = p_processes
+      , ctx_rs     = p_rules    
+      , ctx_ds     = p_declarations
+      , ctx_cs     = p_conceptdefs
+      , ctx_ks     = p_identdefs
+      , ctx_rrules = p_roleRules
+      , ctx_rrels  = p_roleRelations
+      , ctx_vs     = p_viewdefs
+      , ctx_gs     = p_gens
+      , ctx_ifcs   = p_interfaces
+      , ctx_ps     = p_purposes
+      , ctx_pops   = p_pops
+      , ctx_sql    = p_sqldefs
+      , ctx_php    = p_phpdefs
+      , ctx_metas  = p_metas
+      }
+ = (\pats rules identdefs viewdefs interfaces purposes udpops sqldefs phpdefs allRoleRelations
+     -> ACtx{ ctxnm = n1
+            , ctxpos = n2
+            , ctxlang = deflangCtxt
+            , ctxmarkup = deffrmtCtxt
+            , ctxthms = p_themes
+            , ctxpats = pats
+            , ctxrs = rules
+            , ctxds = ctxDecls
+            , ctxpopus = nub (udpops++dclPops++mp1Pops rules++mp1Pops pats++mp1Pops identdefs++mp1Pops viewdefs++mp1Pops interfaces)
+            , ctxcds = allConceptDefs
+            , ctxks = identdefs
+            , ctxrrules = allRoleRules
+            , ctxRRels = allRoleRelations
+            , ctxvs = viewdefs
+            , ctxgs = map pGen2aGen p_gens
+            , ctxgenconcs = map (map castConcept) (concGroups ++ map (:[]) soloConcs)
+            , ctxifcs = interfaces
+            , ctxps = purposes
+            , ctxsql = sqldefs
+            , ctxphp = phpdefs
+            , ctxmetas = p_metas
+            }
+    ) <$> traverse pPat2aPat (p_patterns ++ p_processes)            --  The patterns defined in this context
+      <*> traverse (pRul2aRul n1) p_rules       --  All user defined rules in this context, but outside patterns and outside processes
+      <*> traverse pIdentity2aIdentity p_identdefs --  The identity definitions defined in this context, outside the scope of patterns
+      <*> traverse pViewDef2aViewDef p_viewdefs    --  The view definitions defined in this context, outside the scope of patterns
+      <*> traverse pIfc2aIfc p_interfaceAndDisambObjs   --  TODO: explain   ... The interfaces defined in this context, outside the scope of patterns
+      <*> traverse pPurp2aPurp p_purposes          --  The purposes of objects defined in this context, outside the scope of patterns
+      <*> traverse pPop2aPop p_pops                --  [Population]
+      <*> traverse pObjDef2aObjDef p_sqldefs       --  user defined sqlplugs, taken from the Ampersand script
+      <*> traverse pObjDef2aObjDef p_phpdefs       --  user defined phpplugs, taken from the Ampersand script
+      <*> traverse pRoleRelation2aRoleRelation (p_roleRelations ++ concatMap pt_RRels (p_patterns ++ p_processes))
+      
+  where
+    p_interfaceAndDisambObjs :: [(P_Interface, P_ObjDef (TermPrim, DisambPrim))]
+    p_interfaceAndDisambObjs = [ (ifc, disambiguate termPrimDisAmb $ ifc_Obj ifc) | ifc <- p_interfaces ]
+    -- story about genRules and genLattice
+    -- the genRules is a list of equalities between concept sets, in which every set is interpreted as a conjunction of concepts
+    -- the genLattice is the resulting optimized structure
+    genRules = [ ( Set.singleton (name (gen_spc x)), Set.fromList (map name (gen_concs x)))
+               | x <- p_gens ++ concatMap pt_gns (p_patterns ++ p_processes)
+               ]
+    genLattice :: Op1EqualitySystem String
+    genLattice = optimize1 (foldr addEquality emptySystem genRules)
+
+    concGroups :: [[String]]
+    concGroups = getGroups genLattice
+    allConcs :: Set.Set String
+    allConcs = Set.fromList (map (name . source) decls ++ map (name . target) decls)
+    soloConcs :: [String]
+    soloConcs = filter (not . isInSystem genLattice) (Set.toList allConcs)
+
+    deflangCtxt = lang -- take the default language from the top-level context
+
+    deffrmtCtxt = fromMaybe ReST pandocf
+
+    (decls,dclPops)= unzip dps
+    (ctxDecls,_ ) = unzip ctxDecls'
+    dps = ctxDecls'++patDecls
+    ctxDecls' = [ pDecl2aDecl n1         deflangCtxt deffrmtCtxt pDecl | pDecl<-p_declarations ] --  The relations declared in this context, outside the scope of patterns
+    patDecls  = [ pDecl2aDecl (name pat) deflangCtxt deffrmtCtxt pDecl | pat<-p_patterns ++p_processes , pDecl<-pt_dcs pat ] --  The relations declared in all patterns within this context.
+
+-- In order to find declarations efficiently, a Map is constructed to search declarations by name.
+    declMap = Map.map groupOnTp (Map.fromListWith (++) [(name d,[d]) | d <- decls])
+      where groupOnTp lst = Map.fromListWith accumDecl [(SignOrd$ sign d,d) | d <- lst]
+    findDecls x = Map.findWithDefault Map.empty x declMap  -- get all declarations with the same name as x
+    findDecl o x = (getOneExactly o . Map.elems . findDecls) x
+    findDeclsTyped x tp = Map.findWithDefault [] (SignOrd tp) (Map.map (:[]) (findDecls x))
+    findDeclTyped o x tp = getOneExactly o (findDeclsTyped x tp)
+    -- accumDecl is the function that combines two relations into one
+    -- meanings, for instance, two should get combined into a list of meanings, et cetera
+    -- positions are combined
+    -- TODO
+    accumDecl :: Declaration -> Declaration -> Declaration
+    accumDecl a _ = a
+
+    pDecl2aDecl ::
+         String         -- The name of the pattern
+      -> Lang           -- The default language
+      -> PandocFormat   -- The default pandocFormat
+      -> P_Declaration -> (Declaration, Population)
+    pDecl2aDecl patNm defLanguage defFormat pd
+     = let dcl = Sgn { decnm   = dec_nm pd
+                     , decsgn  = pSign2aSign (dec_sign pd)
+                     , decprps = dec_prps pd
+                     , decprps_calc = Nothing  --decprps_calc in an A_Context are still the user-defined only. prps are calculated in adl2fspec.
+                     , decprL  = dec_prL pd
+                     , decprM  = dec_prM pd
+                     , decprR  = dec_prR pd
+                     , decMean = pMean2aMean defLanguage defFormat (dec_Mean pd)
+                     , decfpos = dec_fpos pd
+                     , deciss  = True
+                     , decusr  = True
+                     , decpat  = patNm
+                     , decplug = dec_plug pd
+                     }
+       in (dcl, PRelPopu { popdcl = dcl, popps = dec_popu pd})
+
+    pSign2aSign :: P_Sign -> Sign
+    pSign2aSign (P_Sign src tgt) = Sign (pCpt2aCpt src) (pCpt2aCpt tgt)
+
+    pGen2aGen :: P_Gen -> A_Gen
+    pGen2aGen pg@PGen{}
+       = Isa{gengen = pCpt2aCpt (gen_gen pg)
+            ,genspc = pCpt2aCpt (gen_spc pg)
+            }
+    pGen2aGen pg@P_Cy{}
+       = IsE { genrhs = map pCpt2aCpt (gen_rhs pg)
+             , genspc = pCpt2aCpt (gen_spc pg)
+             }
+
+    castSign :: String -> String -> Sign
+    castSign a b = Sign (castConcept a) (castConcept b)
+
+    leastConcept :: A_Concept -> String -> A_Concept
+    leastConcept c str
+     = case (name c `elem` leastConcepts, str `elem` leastConcepts) of
+         (True, _) -> c
+         (_, True) -> castConcept str
+         (_, _)    -> fatal 178 ("Either "++name c++" or "++str++" should be a subset of the other." )
+       where
+         leastConcepts = findExact genLattice (Atom (name c) `Meet` (Atom str))
+
+    castConcept :: String -> A_Concept
+    castConcept "ONE" = ONE
+    castConcept x     = PlainConcept { cptnm = x }
+
+    pPop2aPop :: P_Population -> Guarded Population
+    pPop2aPop P_CptPopu { p_cnme = cnm, p_popas = ps }
+     = pure PCptPopu{ popcpt = castConcept cnm, popas = ps }
+    pPop2aPop orig@(P_RelPopu { p_rnme = rnm, p_popps = ps })
+     = fmap (\dcl -> PRelPopu { popdcl = dcl, popps = ps})
+            (findDecl orig rnm)
+    pPop2aPop orig@(P_TRelPop { p_rnme = rnm, p_type = tp, p_popps = ps })
+     = fmap (\dcl -> PRelPopu { popdcl = dcl, popps = ps})
+            (findDeclTyped orig rnm (pSign2aSign tp))
+
+    pObjDef2aObjDef :: P_ObjectDef -> Guarded ObjectDef
+    pObjDef2aObjDef x = pObjDefDisamb2aObjDef $ disambiguate termPrimDisAmb x
+
+    pObjDefDisamb2aObjDef :: P_ObjDef (TermPrim, DisambPrim) -> Guarded ObjectDef
+    pObjDefDisamb2aObjDef x = fmap fst (typecheckObjDef x)
+
+    pViewDef2aViewDef :: P_ViewDef -> Guarded ViewDef
+    pViewDef2aViewDef x = typecheckViewDef tpda
+     where tpda = disambiguate termPrimDisAmb x
+
+    typecheckViewDef :: P_ViewD (TermPrim, DisambPrim) -> Guarded ViewDef
+    typecheckViewDef
+       o@(P_Vd { vd_pos = orig
+            , vd_lbl  = lbl   -- String
+            , vd_cpt  = cpt   -- Concept
+            , vd_isDefault = isDefault
+            , vd_html = mHtml -- Html template
+            , vd_ats  = pvs   -- view segment
+            })
+     = (\vdts
+        -> Vd { vdpos  = orig
+              , vdlbl  = lbl
+              , vdcpt  = pCpt2aCpt cpt
+              , vdIsDefault = isDefault
+              , vdhtml = mHtml
+              , vdats  = vdts
+              })
+       <$> traverse (typeCheckViewSegment o) pvs
+
+    typeCheckViewSegment :: (P_ViewD a) -> (P_ViewSegmt (TermPrim, DisambPrim)) -> Guarded ViewSegment
+    typeCheckViewSegment o P_ViewExp{ vs_obj = ojd }
+     = unguard $
+         (\(obj,b) -> case findExact genLattice (mIsc c (name (source (objctx obj)))) of
+                        [] -> mustBeOrdered o o (Src,(source (objctx obj)),obj)
+                        r  -> if b || c `elem` r then pure (ViewExp obj{objctx = addEpsilonLeft' (head r) (objctx obj)})
+                              else mustBeBound (origin obj) [(Tgt,objctx obj)])
+         <$> typecheckObjDef ojd
+     where c = name (vd_cpt o)
+    typeCheckViewSegment _ P_ViewText { vs_txt = txt } = pure$ ViewText txt
+    typeCheckViewSegment _ P_ViewHtml { vs_htm = htm } = pure$ ViewHtml htm
+    
+    isa :: String -> String -> Bool
+    isa c1 c2 = c1 `elem` findExact genLattice (Atom c1 `Meet` Atom c2) -- shouldn't this Atom be called a Concept? SJC: Answer: we're using the constructor "Atom" in the lattice sense, not in the relation-algebra sense. c1 and c2 are indeed Concepts here
+    
+    typecheckObjDef :: (P_ObjDef (TermPrim, DisambPrim)) -> Guarded (ObjectDef, Bool)
+    typecheckObjDef o@(P_Obj { obj_nm = nm
+                             , obj_pos = orig
+                             , obj_ctx = ctx
+                             , obj_mView = mView
+                             , obj_msub = subs
+                             , obj_strs = ostrs
+                             })
+     = unguard $
+        (\ (objExpr,(srcBounded,tgtBounded)) ->
+            (\case
+               Just (newExpr,subStructures) -> obj (newExpr,srcBounded) (Just subStructures)
+               Nothing -> obj (objExpr,srcBounded) Nothing
+            )
+            <$> maybeOverGuarded (pSubi2aSubi objExpr tgtBounded o) subs <* typeCheckViewAnnotation objExpr mView
+        ) <$> typecheckTerm ctx
+     where      
+      
+      lookupView :: String -> Maybe P_ViewDef
+      lookupView viewId = case [ vd | vd <- p_viewdefs, vd_lbl vd == viewId ] of
+                            []   -> Nothing
+                            vd:_ -> Just vd -- return the first one, if there are more, this is caught later on by uniqueness static check
+                        
+      typeCheckViewAnnotation :: Expression -> Maybe String -> Guarded ()
+      typeCheckViewAnnotation _       Nothing       = pure ()
+      typeCheckViewAnnotation objExpr (Just viewId) =
+        case lookupView viewId of 
+          Just vd -> let viewAnnCptStr = name $ target objExpr
+                         viewDefCptStr = name $ vd_cpt vd
+                         viewIsCompatible = viewAnnCptStr `isa` viewDefCptStr
+                     in  if viewIsCompatible then pure () else Errors [mkIncompatibleViewError o viewId viewAnnCptStr viewDefCptStr]
+          Nothing -> Errors [mkUndeclaredError "view" o viewId] 
+     
+      
+      obj (e,sr) s
+       = ( Obj { objnm = nm
+               , objpos = orig
+               , objctx = e
+               , objmView = mView
+               , objmsub = s
+               , objstrs = ostrs
+               }, sr)
+    addEpsilonLeft',addEpsilonRight' :: String -> Expression -> Expression -- TODO: why use primes here?
+    addEpsilonLeft' a e
+     = if a==name (source e) then e else EEps (leastConcept (source e) a) (castSign a (name (source e))) .:. e
+    addEpsilonRight' a e
+     = if a==name (target e) then e else e .:. EEps (leastConcept (target e) a) (castSign (name (target e)) a)
+    addEpsilon :: String -> String -> Expression -> Expression
+    addEpsilon s t e
+     = addEpsilonLeft' s (addEpsilonRight' t e)
+
+    pSubi2aSubi :: Expression -- Expression of the surrounding
+                -> Bool -- Whether the surrounding is bounded
+                -> P_ObjDef a -- name of where the error occured!
+                -> P_SubIfc (TermPrim, DisambPrim) -- Subinterface to check
+                -> Guarded ( Expression -- In the case of a "Ref", we do not change the type of the subinterface with epsilons, this is to change the type of our surrounding instead. In the case of "Box", this is simply the original expression (in such a case, epsilons are added to the branches instead)
+                           , SubInterface -- the subinterface
+                           )
+    pSubi2aSubi objExpr b o x
+      = case x of
+         P_InterfaceRef{si_str = ifcId} 
+           ->  unguard $
+             (\(refIfcExpr,_) -> (\objExprEps -> (objExprEps,InterfaceRef ifcId)) <$> typeCheckInterfaceRef o ifcId objExpr refIfcExpr)
+             <$> case lookupDisambIfcObj ifcId of
+                   Just disambObj -> typecheckTerm $ obj_ctx disambObj -- term is type checked twice, but otherwise we need a more complicated type check method to access already-checked interfaces. TODO: hide possible duplicate errors in a nice way (that is: via CtxError)
+                   Nothing        -> Errors [mkUndeclaredError "interface" o ifcId]
+         P_Box{}
+           -> case si_box x of
+                []  -> const undefined <$> hasNone ([]::[P_SubIfc a]) x -- error
+                l   -> (\lst -> (objExpr,Box (target objExpr) (si_class x) lst)) <$> traverse (unguard . fmap (matchWith (target objExpr)) . typecheckObjDef) l <* uniqueNames l
+     where matchWith _ (ojd,exprBound)
+            = if b || exprBound then
+              ( case findExact genLattice (mIsc (name$ target objExpr) (name . source . objctx $ ojd)) of
+                    [] -> mustBeOrderedLst x [(source (objctx ojd),Src, ojd)]
+                    (r:_) -> pure (ojd{objctx=addEpsilonLeft' r (objctx ojd)})
+              )
+              else mustBeBound (origin ojd) [(Src,objctx ojd),(Tgt,objExpr)]
+    typeCheckInterfaceRef :: P_ObjDef a -> String -> Expression -> Expression -> Guarded Expression
+    typeCheckInterfaceRef objDef ifcRef objExpr ifcExpr = 
+      let expTarget = target objExpr
+          expTargetStr = name expTarget
+          ifcSource = source ifcExpr
+          ifcSourceStr = name ifcSource
+          refIsCompatible = expTargetStr `isa` ifcSourceStr || ifcSourceStr `isa` expTargetStr
+      in  if refIsCompatible 
+          then pure $ addEpsilonRight' ifcSourceStr objExpr 
+          else Errors [mkIncompatibleInterfaceError objDef expTarget ifcSource ifcRef ]
+    lookupDisambIfcObj :: String -> Maybe (P_ObjDef (TermPrim, DisambPrim))
+    lookupDisambIfcObj ifcId =
+      case [ disambObj | (vd,disambObj) <- p_interfaceAndDisambObjs, ifc_Name vd == ifcId ] of
+        []          -> Nothing
+        disambObj:_ -> Just disambObj -- return the first one, if there are more, this is caught later on by uniqueness static check
+    
+    typecheckTerm :: Term (TermPrim, DisambPrim) -> Guarded (Expression, (Bool, Bool))
+    typecheckTerm tct
+     = case tct of
+         Prim (t,v) -> (\x -> (x, case t of
+                                   PVee _ -> (False,False)
+                                   _      -> (True,True)
+                                   )) <$> pDisAmb2Expr (t,v)
+         PEqu _ a b -> unguard $ binary  (.==.) (MBE (Src,fst) (Src,snd), MBE (Tgt,fst) (Tgt,snd)) <$> tt a <*> tt b
+         PImp _ a b -> unguard $ binary  (.|-.) (MBG (Src,snd) (Src,fst), MBG (Tgt,snd) (Tgt,fst)) <$> tt a <*> tt b
+         PIsc _ a b -> unguard $ binary  (./\.) (ISC (Src,fst) (Src,snd), ISC (Tgt,fst) (Tgt,snd)) <$> tt a <*> tt b
+         PUni _ a b -> unguard $ binary  (.\/.) (UNI (Src,fst) (Src,snd), UNI (Tgt,fst) (Tgt,snd)) <$> tt a <*> tt b
+         PDif _ a b -> unguard $ binary  (.-.)  (MBG (Src,fst) (Src,snd), MBG (Tgt,fst) (Tgt,snd)) <$> tt a <*> tt b
+         PLrs _ a b -> unguard $ binary' (./.)  (MBG (Tgt,snd) (Tgt,fst)) ((Src,fst),(Src,snd)) Tgt Tgt <$> tt a <*> tt b
+         PRrs _ a b -> unguard $ binary' (.\.)  (MBG (Src,fst) (Src,snd)) ((Tgt,fst),(Tgt,snd)) Src Src <$> tt a <*> tt b
+         PDia _ a b -> unguard $ binary' (.<>.) (ISC (Tgt,fst) (Src,snd)) ((Src,fst),(Tgt,snd)) Tgt Src <$> tt a <*> tt b -- MBE would have been correct, but too restrictive
+         PCps _ a b -> unguard $ binary' (.:.)  (ISC (Tgt,fst) (Src,snd)) ((Src,fst),(Tgt,snd)) Tgt Src <$> tt a <*> tt b
+         PRad _ a b -> unguard $ binary' (.!.)  (MBE (Tgt,fst) (Src,snd)) ((Src,fst),(Tgt,snd)) Tgt Src <$> tt a <*> tt b -- Using MBE instead of ISC allows the programmer to use De Morgan
+         PPrd _ a b -> (\(x,(s,_)) (y,(_,t)) -> (x .*. y, (s,t))) <$> tt a <*> tt b
+         PKl0 _ a   -> unguard $ unary   EKl0   (UNI (Src, id) (Tgt, id), UNI (Src, id) (Tgt, id)) <$> tt a
+         PKl1 _ a   -> unguard $ unary   EKl1   (UNI (Src, id) (Tgt, id), UNI (Src, id) (Tgt, id)) <$> tt a
+         PFlp _ a   -> (\(x,(s,t)) -> ((EFlp x), (t,s))) <$> tt a
+         PCpl _ a   -> (\(x,_) -> (ECpl x,(False,False))) <$> tt a
+         PBrk _ e   -> (\(x,t) -> (EBrk x,t)) <$> tt e 
+     where
+      o = origin (fmap fst tct)
+      tt = typecheckTerm
+      -- SJC: Here is what binary, binary' and unary do:
+      -- (1) Create an expression, the combinator for this is given by its first argument
+      -- (2) Fill in the corresponding type-checked terms to that expression
+      -- (3) For binary' only: fill in the intermediate concept too
+      -- (4) Fill in the type of the new expression
+      -- For steps (3) and (4), you can use the `TT' data type to specify the new type, and what checks should occur:
+      -- If you don't know what to use, try MBE: it is the strictest form.
+      -- In the steps (3) and (4), different type errors may arise:
+      -- If the type does not exist, this yields a type error.
+      -- Some types may be generalized, while others may not.
+      -- When a type may be generalized, that means that the value of the expression does not change if the type becomes larger
+      -- When a type may not be generalized:
+      --   the type so far is actually just an estimate
+      --   it must be bound by the context to something smaller, or something as big
+      --   a way to do this, is by using (V[type] /\ thingToBeBound)
+      -- More details about generalizable types can be found by looking at "deriv1".
+      binary :: (Expression -> Expression->Expression) -- combinator
+             -> ( TT ( SrcOrTgt
+                     , ( (Expression, (Bool, Bool))
+                       , (Expression, (Bool, Bool))
+                       ) -> (Expression, (Bool, Bool))
+                     )
+                , TT ( SrcOrTgt
+                     , ( (Expression, (Bool, Bool))
+                       , (Expression, (Bool, Bool))
+                       ) -> (Expression, (Bool, Bool))
+                     )
+                ) -- simple instruction on how to derive the type
+             -> (Expression,(Bool,Bool))
+             -> (Expression,(Bool,Bool)) -- expressions to feed into the combinator after translation
+             -> Guarded (Expression,(Bool,Bool))
+      binary  cbn     tp  e1 e2 = wrap (fst e1,fst e2) <$> deriv tp (e1,e2)
+        where
+         wrap (expr1,expr2) ((src,b1), (tgt,b2)) = (cbn (addEpsilon src tgt expr1) (addEpsilon src tgt expr2), (b1, b2))
+      unary   cbn     tp e1      = wrap (fst e1) <$> deriv tp e1
+        where
+         wrap expr  ((src,b1), (tgt,b2))  = (cbn (addEpsilon src tgt expr), (b1, b2))
+      binary' cbn preConcept tp side1 side2 e1 e2 = wrap (fst e1,fst e2) <$> deriv1 o (fmap (resolve (e1,e2)) preConcept) <*> deriv' tp (e1,e2)
+        where
+         wrap (expr1,expr2) (cpt,_) ((_,b1), (_,b2))
+          = (cbn (lrDecide side1 expr1) (lrDecide side2 expr2), (b1, b2))
+            where lrDecide side e = case side of Src -> addEpsilonLeft' cpt e; Tgt -> addEpsilonRight' cpt e
+      deriv (t1,t2) es = (,) <$> deriv1 o (fmap (resolve es) t1) <*> deriv1 o (fmap (resolve es) t2)
+ 
+    deriv1 o x'
+     = case x' of
+        (MBE a@(p1,(e1,b1)) b@(p2,(e2,b2))) ->
+             if (b1 && b2) || (getConcept p1 e1 == getConcept p2 e2) then (\x -> (x,b1||b2)) <$> getExactType mjoin (p1, e1) (p2, e2)
+             else mustBeBound o [(p,e) | (p,(e,False))<-[a,b]]
+        (MBG (p1,(e1,b1)) (p2,(e2,b2))) ->
+             (\x -> (x,b1)) <$> getAndCheckType mjoin (p1, True, e1) (p2, b2, e2)
+        (UNI (p1,(e1,b1)) (p2,(e2,b2))) ->
+             (\x -> (x,b1 && b2)) <$> getAndCheckType mjoin (p1, b1, e1) (p2, b2, e2)
+        (ISC (p1,(e1,b1)) (p2,(e2,b2))) ->
+             (\x -> (x,b1 || b2)) <$> getAndCheckType mIsc  (p1, b1, e1) (p2, b2, e2)
+     where
+      getExactType flf (p1,e1) (p2,e2)
+       = case findExact genLattice (flf (getConcept p1 e1) (getConcept p2 e2)) of
+          [] -> mustBeOrdered o (p1,e1) (p2,e2)
+          r  -> pure$ head r
+      getAndCheckType flf (p1,b1,e1) (p2,b2,e2)
+       = case findSubsets genLattice (flf (getConcept p1 e1) (getConcept p2 e2)) of -- note: we could have used GetOneGuarded, but this is more specific
+          []  -> mustBeOrdered o (p1,e1) (p2,e2)
+          [r] -> case (b1 || Set.member (getConcept p1 e1) r,b2 || Set.member (getConcept p2 e2) r ) of
+                   (True,True) -> pure (head (Set.toList r))
+                   (a,b) -> mustBeBound o [(p,e) | (False,p,e)<-[(a,p1,e1),(b,p2,e2)]]
+          lst -> mustBeOrderedConcLst o (p1,e1) (p2,e2) (map (map castConcept . Set.toList) lst)
+    termPrimDisAmb :: TermPrim -> (TermPrim, DisambPrim)
+    termPrimDisAmb x
+     = (x, case x of
+           PI _        -> Ident
+           Pid _ conspt-> Known (EDcI (pCpt2aCpt conspt))
+           Patm _ s Nothing -> Mp1 s
+           Patm _ s (Just conspt) -> Known (EMp1 s (pCpt2aCpt conspt))
+           PVee _      -> Vee
+           Pfull _ a b -> Known (EDcV (Sign (pCpt2aCpt a) (pCpt2aCpt b)))
+           PNamedR nr -> Rel $ disambNamedRel nr
+        )
+    disambNamedRel (PNamedRel _ r Nothing)  = [EDcD dc | dc <- (Map.elems $ findDecls r)]
+    disambNamedRel (PNamedRel _ r (Just s)) = [EDcD dc | dc <- (findDeclsTyped r (pSign2aSign s))]
+
+    namedRel2Decl :: P_NamedRel -> Guarded Declaration
+    namedRel2Decl o@(PNamedRel _ r Nothing)  = getOneExactly o [ dc | dc <- (Map.elems $ findDecls r)]
+    namedRel2Decl o@(PNamedRel _ r (Just s)) = getOneExactly o [ dc | dc <- (findDeclsTyped r (pSign2aSign s))]
+
+    pIfc2aIfc :: (P_Interface, P_ObjDef (TermPrim, DisambPrim)) -> Guarded Interface
+    pIfc2aIfc (P_Ifc { ifc_Params = tps
+                    , ifc_Class = iclass
+                    , ifc_Args = args
+                    , ifc_Roles = rols
+                    , ifc_Obj = _
+                    , ifc_Pos = orig
+                    -- , ifc_Name = nm
+                    , ifc_Prp = prp
+                    }, objDisamb)
+        = (\ tps' obj'
+             -> Ifc { ifcParams = tps'
+                    , ifcClass = iclass
+                    , ifcArgs = args
+                    , ifcRoles = rols
+                    , ifcObj = obj'
+                    , ifcEcas = []      -- to be enriched in Adl2fSpec with ECA-rules
+                    , ifcControls = []  -- to be enriched in Adl2fSpec with rules to be checked
+                    , ifcPos = orig
+                    , ifcPrp = prp
+                    }) <$> traverse namedRel2Decl tps
+                       <*> pObjDefDisamb2aObjDef objDisamb
+
+    pRoleRelation2aRoleRelation :: P_RoleRelation -> Guarded A_RoleRelation
+    pRoleRelation2aRoleRelation prr
+     = (\ ds' 
+        -> RR { rrRoles = rr_Roles prr
+              , rrRels  = ds'
+              , rrPos   = rr_Pos prr
+              }) <$> traverse namedRel2Decl (rr_Rels prr)
+    pRoleRule2aRoleRule :: P_RoleRule -> A_RoleRule
+    pRoleRule2aRoleRule prr
+     = A_RoleRule { arRoles = mRoles prr
+                  , arRules = mRules prr
+                  , arPos   = mPos prr
+                  }
+    
+    pPat2aPat :: P_Pattern -> Guarded Pattern
+    pPat2aPat ppat
+     = f <$> traverse (pRul2aRul (name ppat)) (pt_rls ppat)
+         <*> traverse pIdentity2aIdentity (pt_ids ppat) 
+         <*> traverse pPop2aPop (pt_pop ppat)
+         <*> traverse pViewDef2aViewDef (pt_vds ppat) 
+         <*> traverse pPurp2aPurp (pt_xps ppat)
+       where
+        f rules' keys' pops' views' xpls
+           = let (decls',dPops) = unzip [ pDecl2aDecl (name ppat) deflangCtxt deffrmtCtxt pDecl | pDecl<-pt_dcs ppat ]
+             in A_Pat { ptnm  = name ppat
+                      , ptpos = pt_pos ppat
+                      , ptend = pt_end ppat
+                      , ptrls = rules'
+                      , ptgns = map pGen2aGen (pt_gns ppat)
+                      , ptdcs = decls'
+                      , ptups = pops' ++ [ dp | dp@PRelPopu{}<-dPops, (not.null.popps) dp ] ++ [ cp | cp@PCptPopu{}<-dPops, (not.null.popas) cp ]
+                      , ptids = keys'
+                      , ptvds = views'
+                      , ptxps = xpls
+                      }
+    pRul2aRul :: String -- environment name (pattern / proc name)
+              -> (P_Rule TermPrim) -> Guarded Rule
+    pRul2aRul env = typeCheckRul env . disambiguate termPrimDisAmb
+    typeCheckRul :: 
+                 String -- environment name (pattern / proc name)
+              -> (P_Rule (TermPrim, DisambPrim)) -> Guarded Rule
+    typeCheckRul env P_Ru { rr_nm = nm
+                          , rr_exp = expr
+                          , rr_fps = orig
+                          , rr_mean = meanings
+                          , rr_msg = msgs
+                          , rr_viol = viols
+                          }
+     = unguard $ 
+         (\ (exp',_) -> 
+           (\ vls ->
+             Ru { rrnm = nm
+                , rrexp = exp'
+                , rrfps = orig
+                , rrmean = pMean2aMean deflangCtxt deffrmtCtxt meanings
+                , rrmsg = map (pMess2aMess deflangCtxt deffrmtCtxt) msgs
+                , rrviol = vls
+                , rrtyp = sign exp'
+                , rrdcl = Nothing
+                , r_env = env
+                , r_usr = UserDefined
+                , isSignal = not . null . concatMap arRoles . filter (\x -> nm `elem` arRules x) $ allRoleRules 
+                })
+           <$> maybeOverGuarded (typeCheckPairView orig exp') viols)
+         <$> typecheckTerm expr
+    pIdentity2aIdentity :: P_IdentDef -> Guarded IdentityDef
+    pIdentity2aIdentity pidt
+     = case disambiguate termPrimDisAmb pidt of
+           P_Id { ix_lbl = lbl
+                , ix_ats = isegs
+                } -> (\isegs' -> Id { idPos = orig
+                                    , idLbl = lbl
+                                    , idCpt = conc
+                                    , identityAts = isegs'
+                                    }) <$> traverse pIdentSegment2IdentSegment isegs
+     where conc = pCpt2aCpt (ix_cpt pidt)
+           orig = ix_pos pidt
+           pIdentSegment2IdentSegment :: P_IdentSegmnt (TermPrim, DisambPrim) -> Guarded IdentitySegment
+           pIdentSegment2IdentSegment (P_IdentExp ojd) =
+              unguard $
+                (\o -> case findExact genLattice $ name (source $ objctx o) `mjoin` name conc of
+                         [] -> mustBeOrdered orig (Src, origin ojd, objctx o) pidt
+                         _  -> pure $ IdentityExp o{objctx = addEpsilonLeft' (name conc) (objctx o)}
+                ) <$> pObjDefDisamb2aObjDef ojd
+
+    typeCheckPairView :: Origin -> Expression -> PairView (Term (TermPrim, DisambPrim)) -> Guarded (PairView Expression)
+    typeCheckPairView o x (PairView lst)
+     = PairView <$> traverse (typeCheckPairViewSeg o x) lst
+    typeCheckPairViewSeg :: Origin -> Expression -> (PairViewSegment (Term (TermPrim, DisambPrim))) -> Guarded (PairViewSegment Expression)
+    typeCheckPairViewSeg _ _ (PairViewText orig x) = pure (PairViewText orig x)
+    typeCheckPairViewSeg o t (PairViewExp orig s x)
+     = unguard $
+         (\(e,(b,_)) -> case (findSubsets genLattice (mjoin (name (source e)) (getConcept s t))) of
+                          [] -> mustBeOrdered o (Src, (origin (fmap fst x)), e) (s,t)
+                          lst -> if b || and (map (name (source e) `elem`) lst)
+                                 then pure (PairViewExp orig s e)
+                                 else mustBeBound (origin (fmap fst x)) [(Src, e)])
+         <$> typecheckTerm x
+
+    pPurp2aPurp :: PPurpose -> Guarded Purpose
+    pPurp2aPurp PRef2 { pexPos    = orig     -- :: Origin
+                      , pexObj    = objref   -- :: PRefObj
+                      , pexMarkup = pmarkup  -- :: P_Markup
+                      , pexRefIDs  = refIds  -- :: [String]
+                      }
+     = (\ obj -> Expl { explPos      = orig
+                      , explObj      = obj
+                      , explMarkup   = pMarkup2aMarkup deflangCtxt deffrmtCtxt pmarkup
+                      , explUserdefd = True
+                      , explRefIds   = refIds
+                      })
+       <$> pRefObj2aRefObj objref
+    pRefObj2aRefObj :: PRef2Obj -> Guarded ExplObj
+    pRefObj2aRefObj (PRef2ConceptDef  s ) = pure$ ExplConceptDef (lookupConceptDef s)
+    pRefObj2aRefObj (PRef2Declaration tm) = ExplDeclaration <$> (namedRel2Decl tm)
+    pRefObj2aRefObj (PRef2Rule        s ) = pure$ ExplRule s
+    pRefObj2aRefObj (PRef2IdentityDef s ) = pure$ ExplIdentityDef s
+    pRefObj2aRefObj (PRef2ViewDef     s ) = pure$ ExplViewDef s
+    pRefObj2aRefObj (PRef2Pattern     s ) = pure$ ExplPattern s
+    pRefObj2aRefObj (PRef2Interface   s ) = pure$ ExplInterface s
+    pRefObj2aRefObj (PRef2Context     s ) = pure$ ExplContext s
+    pRefObj2aRefObj (PRef2Fspc        s ) = pure$ ExplContext s
+    lookupConceptDef :: String -> ConceptDef
+    lookupConceptDef s
+     = case filter (\cd -> name cd == s) allConceptDefs of
+        []    -> Cd{cdpos=OriginUnknown, cdcpt=s, cdplug=True, cddef="", cdtyp="", cdref="", cdfrom=n1} 
+        (x:_) -> x
+    allConceptDefs :: [ConceptDef]
+    allConceptDefs = p_conceptdefs++concatMap pt_cds (p_patterns++p_processes)
+    allRoleRules :: [A_RoleRule]
+    allRoleRules = map pRoleRule2aRoleRule 
+                      (p_roleRules ++ concatMap pt_RRuls (p_patterns++p_processes))
+pDisAmb2Expr :: (TermPrim, DisambPrim) -> Guarded Expression
+pDisAmb2Expr (_,Known x) = pure x
+pDisAmb2Expr (_,Rel [x]) = pure x
+pDisAmb2Expr (o,Rel rs)  = cannotDisambRel o rs
+pDisAmb2Expr (o,_)       = cannotDisamb o
+
+pMean2aMean :: Lang           -- The default language
+            -> PandocFormat   -- The default pandocFormat
+            -> [PMeaning] -> AMeaning
+pMean2aMean defLanguage defFormat pmeanings
+ = AMeaning [ pMarkup2aMarkup defLanguage defFormat pmarkup | PMeaning pmarkup <-pmeanings ]
+pMess2aMess :: Lang           -- The default language
+            -> PandocFormat   -- The default pandocFormat
+            -> PMessage -> A_Markup
+pMess2aMess defLanguage defFormat (PMessage x) = pMarkup2aMarkup defLanguage defFormat x
+pMarkup2aMarkup :: Lang           -- The default language
+                -> PandocFormat   -- The default pandocFormat
+                -> P_Markup -> A_Markup
+pMarkup2aMarkup defLanguage defFormat
+   P_Markup  { mLang   = ml
+             , mFormat = mpdf
+             , mString = str
+             }
+ = A_Markup { amLang = fromMaybe defLanguage ml -- The language is always defined; if not by the user, then by default.
+            , amFormat = fmt
+            , amPandoc = string2Blocks fmt str
+            }
+     where
+       fmt = fromMaybe defFormat mpdf           -- The pandoc format is always defined; if not by the user, then by default.
+
+-- helpers for generating a lattice, not having to write `Atom' all the time
+-- TODO: Names are inconsistent: maybe call these either mUnion & mIsc or mJoin & mMeet? Or even lJoin and lMeet to denote the lattice.
+mjoin,mIsc :: a -> a -> FreeLattice a
+mjoin a b = Join (Atom a) (Atom b)
+mIsc  a b = Meet (Atom a) (Atom b)
+-- intended for finding the right expression on terms like (Src,fst)
+resolve :: t -> (SrcOrTgt, t -> (t1, (t2, t2))) -> (SrcOrTgt, (t1, t2))
+resolve es (p,f)
+ = case (p,f es) of
+  (Src,(e,(b,_))) -> (Src,(e,b))
+  (Tgt,(e,(_,b))) -> (Tgt,(e,b))
+
+maybeOverGuarded :: Applicative f => (t -> f a) -> Maybe t -> f (Maybe a)
+maybeOverGuarded _ Nothing = pure Nothing
+maybeOverGuarded f (Just x) = Just <$> f x
+
+data TT a  -- (In order of increasing strictness. If you are unsure which to pick: just use MBE, it'll usually work fine)
+ = UNI a a -- find the union of these types, return it.
+ | ISC a a -- find the intersection of these types, return it.
+ | MBE a a -- must be equal: must be (made) of equal type. If these types are comparable, it returns the greatest.
+ | MBG a a -- The first of these types must be the greatest, if so, return it (error otherwise)
+ -- SJC: difference between UNI and MBE
+ -- in general, UNI is less strict than MBE:
+ --   suppose A ≤ C, B ≤ C, and C is the least such concept (e.g. if A≤D and B≤D then C≤D)
+ --   in this case UNI A B will yield C (if both A and B are generalizable), while MBE A B will give an error
+ --   note that in case of A ≤ C, B ≤ C, A ≤ D, B ≤ D (and there is no order between C and D), both will give an error
+ --   the error message, however, should be different:
+ --     for MBE it says that A and B must be of the same type, and suggests adding an order between A and B
+ --     for UNI it says that it cannot decide whether A \/ B is of type C or D, and suggests adding an order between C and D
+ --   In addition, MBE requires that both sides are not generalizable. UNI does not, and simply propagates this property.
+ -- MBG is like MBE, but will only try to generalize the right hand side (when allowed)
+
+deriv' :: (Applicative f)
+       => ((SrcOrTgt, t -> (Expression, (Bool, Bool))), (SrcOrTgt, t -> (Expression, (Bool, Bool))))
+       -> t
+       -> f ((String, Bool), (String, Bool))
+deriv' (a,b) es = let (sourceOrTarget1, (e1, t1)) = resolve es a
+                      (sourceOrTarget2, (e2, t2)) = resolve es b
+                  in pure ((getConcept sourceOrTarget1 e1, t1), (getConcept sourceOrTarget2 e2, t2))
+instance Functor TT where
+  fmap f (UNI a b) = UNI (f a) (f b)
+  fmap f (ISC a b) = ISC (f a) (f b)
+  fmap f (MBE a b) = MBE (f a) (f b)
+  fmap f (MBG a b) = MBG (f a) (f b)
+  
+-- TODO: would probably be better to return an A_Concept
+getConcept :: SrcOrTgt -> Expression -> String
+getConcept Src = name . source
+getConcept Tgt = name . target
+

+ src/Database/Design/Ampersand/ADL1/Pair.hs view
@@ -0,0 +1,26 @@+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+module Database.Design.Ampersand.ADL1.Pair
+                    ( Paire(..),Pairs
+                    , mkPair
+                    )
+where
+import Data.Typeable
+import Database.Design.Ampersand.Basics
+
+type Pairs = [Paire]
+--srcPaire :: Paire -> String
+--trgPaire :: Paire -> String
+--type Paire = (String,String)
+--mkPair :: String -> String -> Paire
+--mkPair a b = (a,b)
+--srcPaire = fst
+--trgPaire = snd
+data Paire = Paire {srcPaire ::String  --TODO introduction of AtomValue, and replace these messy Strings
+                   ,trgPaire ::String
+                   } deriving (Show ,Eq,Ord, Typeable)
+mkPair :: String -> String -> Paire
+mkPair = Paire
+instance Unique Paire where
+  showUnique p = "("++srcPaire p++","++trgPaire p++")"

+ src/Database/Design/Ampersand/ADL1/Rule.hs view
@@ -0,0 +1,115 @@+module Database.Design.Ampersand.ADL1.Rule 
+  (consequent, antecedent, rulefromProp, ruleviolations, conjunctViolations, hasantecedent) where
+
+import Database.Design.Ampersand.Core.AbstractSyntaxTree
+import Database.Design.Ampersand.Basics
+import Database.Design.Ampersand.Classes.Populated ( fullContents)
+import Database.Design.Ampersand.Misc
+import qualified Data.Set as Set
+
+fatal :: Int -> String -> a
+fatal = fatalMsg "ADL1.Rule"
+
+hasantecedent :: Rule -> Bool
+hasantecedent r
+ = case rrexp r of
+     EEqu{} -> True
+     EImp{} -> True
+     _      -> False
+antecedent :: Rule -> Expression
+antecedent r
+ = case rrexp r of
+     EEqu (le,_) -> le
+     EImp (le,_) -> le
+     _           -> fatal 134 $ "erroneous reference to antecedent of rule "++show r
+
+consequent :: Rule -> Expression
+consequent r
+ = case rrexp r of
+     EEqu (_,re) -> re
+     EImp (_,re) -> re
+     x           -> x
+
+conjunctViolations :: [A_Gen] -> [Population] -> Conjunct -> Pairs
+conjunctViolations gens pop conj =
+  let vConts    = Set.fromList $ fullContents gens pop (EDcV (sign (rc_conjunct conj)))
+      conjConts = Set.fromList $ fullContents gens pop (rc_conjunct conj)
+  in  Set.toList $ vConts `Set.difference` conjConts 
+     
+ruleviolations :: [A_Gen] -> [Population] -> Rule -> Pairs
+ruleviolations gens pop r = case rrexp r of
+     EEqu{} -> (cra >- crc) ++ (crc >- cra)
+     EImp{} -> cra >- crc
+     _      -> fullContents gens pop (EDcV (sign (consequent r))) >- crc  --everything not in con
+     where cra = fullContents gens pop (antecedent r)
+           crc = fullContents gens pop (consequent r)
+
+-- rulefromProp specifies a rule that defines property prp of declaration d.
+-- The table of all relations is provided, in order to generate shorter names if possible.
+rulefromProp :: Prop -> Declaration -> Maybe Rule
+rulefromProp Aut _ = Nothing
+rulefromProp prp d@Sgn{} =
+  Just $ 
+     Ru { rrnm  = show prp++" "++name d++"::"++s++"*"++t
+        , rrexp = rExpr
+        , rrfps = origin d
+        , rrmean = AMeaning $ explain True prp
+        , rrmsg = explain False prp
+        , rrviol = Nothing
+        , rrtyp = sign rExpr
+        , rrdcl = Just (prp,d)         -- For traceability: The original property and declaration.
+        , r_env = decpat d             -- For traceability: The name of the pattern. Unknown at this position but it may be changed by the environment.
+        , r_usr = Multiplicity
+        , isSignal = fatal 63 "It is determined later (when all MAINTAIN statements are available), what this value is." 
+        }
+       where
+        s = name (source d)
+        t = name (target d)
+        r:: Expression
+        r = EDcD d
+        rExpr = if not (isEndo r) && prp `elem` [Sym, Asy, Trn, Rfx, Irf]
+                then fatal 70 ("Illegal property of an endo relation "++show (name d)) else
+                case prp of
+                     Uni-> flp r .:. r .|-. EDcI (target r)
+                     Tot-> EDcI (source r)  .|-. r .:. flp r
+                     Inj-> r .:. flp r .|-. EDcI (source r)
+                     Sur-> EDcI (target r)  .|-. flp r .:. r
+                     Sym-> r .==. flp r
+                     Asy-> flp r ./\. r .|-. EDcI (source r)
+                     Trn-> r .:. r .|-. r
+                     Rfx-> EDcI (source r) .|-. r
+                     Irf-> r .|-. ECpl (EDcI (source r))
+                     Aut -> fatal 78 "Aut should have been handled by pattern match on top-level declaration rulefromProp"
+        explain isPositive prop = [ A_Markup English ReST (string2Blocks ReST (
+                              case prop of
+                                Sym-> state isPositive English (name d++"["++s++"]") "symmetric"
+                                Asy-> state isPositive English (name d++"["++s++"]") "antisymmetric"
+                                Trn-> state isPositive English (name d++"["++s++"]") "transitive"
+                                Rfx-> state isPositive English (name d++"["++s++"]") "reflexive"
+                                Irf-> state isPositive English (name d++"["++s++"]") "irreflexive"
+                                Uni-> state isPositive English (name d++"["++s++"*"++t++"]") "univalent"
+                                Sur-> state isPositive English (name d++"["++s++"*"++t++"]") "surjective"
+                                Inj-> state isPositive English (name d++"["++s++"*"++t++"]") "injective"
+                                Tot-> state isPositive English (name d++"["++s++"*"++t++"]") "total"
+                                Aut -> fatal 90 "Aut should have been handled by pattern match on top-level declaration rulefromProp"
+                                ))
+                       ,   A_Markup Dutch ReST (string2Blocks ReST (
+                              case prop of
+                                Sym-> state isPositive Dutch (name d++"["++s++"]") "symmetrisch."
+                                Asy-> state isPositive Dutch (name d++"["++s++"]") "antisymmetrisch."
+                                Trn-> state isPositive Dutch (name d++"["++s++"]") "transitief."
+                                Rfx-> state isPositive Dutch (name d++"["++s++"]") "reflexief."
+                                Irf-> state isPositive Dutch (name d++"["++s++"]") "irreflexief."
+                                Uni-> state isPositive Dutch (name d++"["++s++"*"++t++"]") "univalent"
+                                Sur-> state isPositive Dutch (name d++"["++s++"*"++t++"]") "surjectief"
+                                Inj-> state isPositive Dutch (name d++"["++s++"*"++t++"]") "injectief"
+                                Tot-> state isPositive Dutch (name d++"["++s++"*"++t++"]") "totaal"
+                                Aut -> fatal 103 "Aut should have been handled by pattern match on top-level declaration rulefromProp"
+                                ))
+                      ]
+
+        state True  _       left right = left ++ " is " ++ right
+        state False English left right = left ++ " is not " ++ right
+        state False Dutch   left right = left ++ " is niet " ++ right
+
+rulefromProp _ _ = fatal 252 "Properties can only be set on user-defined relations."

+ src/Database/Design/Ampersand/Basics.hs view
@@ -0,0 +1,15 @@+module Database.Design.Ampersand.Basics
+  ( module Database.Design.Ampersand.Basics.Auxiliaries
+  , module Database.Design.Ampersand.Basics.Collection
+  , module Database.Design.Ampersand.Basics.String
+  , module Database.Design.Ampersand.Basics.Unique
+  , module Database.Design.Ampersand.Basics.UTF8
+  , module Database.Design.Ampersand.Basics.Version
+  ) where
+import Database.Design.Ampersand.Basics.Auxiliaries
+import Database.Design.Ampersand.Basics.Collection
+import Database.Design.Ampersand.Basics.String
+import Database.Design.Ampersand.Basics.Unique
+import Database.Design.Ampersand.Basics.UTF8
+import Database.Design.Ampersand.Basics.Version
+

+ src/Database/Design/Ampersand/Basics/Auxiliaries.hs view
@@ -0,0 +1,124 @@+{-# LANGUAGE ScopedTypeVariables #-}
+module Database.Design.Ampersand.Basics.Auxiliaries 
+         ( module Database.Design.Ampersand.Basics.Auxiliaries
+         , module Debug.Trace) where
+
+import Data.List
+import Data.Graph (stronglyConnComp, SCC(CyclicSCC))
+import Data.Maybe (fromMaybe)
+import Data.Map (Map) 
+import qualified Data.Map as Map 
+import Data.Set (Set)
+import qualified Data.Set as Set 
+import Debug.Trace
+
+-- | The 'eqClass' function takes an equality test function and a list and returns a list of lists such
+-- that each sublist in the result contains only equal elements, and all equal elements are in
+-- the same sublist.  For example,
+--
+-- Example> eqClass "Mississippi" = ["M","iiii","ssss","pp"]
+--
+eqClass :: (a -> a -> Bool) -> [a] -> [[a]]
+eqClass _ [] = []
+eqClass f (x:xs) = (x:[e |e<-xs, f x e]) : eqClass f [e |e<-xs, not (f x e)]
+
+-- | eqCl is used for gathering things that are equal wrt some criterion f.
+--   For instance, if you want to have persons with the same name:
+--    'eqCl name persons' produces a list,in which each element is a list of persons with the same name.
+-- Example> eqCl (=='s') "Mississippi" = "ssss"
+
+eqCl :: Eq b => (a -> b) -> [a] -> [[a]]
+eqCl _ [] = []
+eqCl f (x:xs) = (x:[e |e<-xs, f x==f e]) : eqCl f [e |e<-xs, f x/=f e]
+
+-- | getCycles returns a list of cycles in the edges list (each edge is a pair of a from-vertex
+--   and a list of to-vertices)
+getCycles :: Eq a => [(a, [a])] -> [[a]]
+getCycles edges =
+  let allVertices = nub . concat $ [ from : to | (from, to) <- edges ]
+      keyFor v = fromMaybe (error "FATAL") $ elemIndex v allVertices
+      graphEdges = [ (v, keyFor v , map keyFor vs)  | (v, vs) <- edges ]
+  in  [ vs | CyclicSCC vs <- stronglyConnComp graphEdges ]
+
+
+-- |  Warshall's transitive closure algorithm
+transClosureMap :: (Eq a, Ord a) => Map a [a] -> Map a [a]
+transClosureMap xs
+  = foldl f xs (Map.keys xs `intersect` nub (concat (Map.elems xs)))
+    where
+     f :: (Eq a, Ord a) => Map a [a] -> a -> Map a [a]   -- The type is given for documentation purposes only
+     f q x = Map.unionWith union q (Map.fromListWith union [(a, q Map.! x) | (a, bs) <- Map.assocs q, x `elem` bs])
+
+-- The following function can be used to determine how much of a set of alternative expression is already determined
+-- | The 'combinations' function returns all possible combinations of lists of list.
+-- For example,
+--
+-- > combinations [[1,2,3],[10,20],[4]] == [[1,10,4],[1,20,4],[2,10,4],[2,20,4],[3,10,4],[3,20,4]]
+combinations :: [[a]] -> [[a]]
+combinations []       = [[]]
+combinations (es:ess) = [ x:xs | x<-es, xs<-combinations ess]
+
+-- Convert list of a's with associated b's to a list of b's with associated a's.
+-- Each b in the result is unique, and so is each a per b, eg.: 
+-- converse [(1,[2,2,3]),(1,[3,4]),(2,[4,5])]  == [(2,[1]),(3,[1]),(4,[1,2]),(5,[2])]
+converse :: forall a b . (Ord a, Ord b) => [(a, [b])] -> [(b, [a])]
+converse aBss = let asPerB ::(Ord a, Ord b) =>  Map b (Set a)
+                    asPerB = foldl (.) id [ Map.insertWith Set.union b (Set.singleton a)  | (a,bs) <- aBss, b <- bs ] $ Map.empty
+                in Map.toList $ fmap Set.toList asPerB -- first convert each Set to a list, and then the whole Map to a list of tuples
+
+commaEng :: String -> [String] -> String
+commaEng str [a,b,c] = a++", "++b++", "++str++" "++c
+commaEng str [a,b]   = a++" "++str++" "++b
+commaEng _   [a]     = a
+commaEng str (a:as)  = a++", "++commaEng str as
+commaEng _   []      = ""
+
+commaNL :: String -> [String] -> String
+commaNL str [a,b]  = a++" "++str++" "++b
+commaNL  _  [a]    = a
+commaNL str (a:as) = a++", "++commaNL str as
+commaNL  _  []     = ""
+
+fst3 :: (a,b,c)->a
+snd3 :: (a,b,c)->b
+thd3 :: (a,b,c)->c
+fst3 (a,_,_) = a
+snd3 (_,b,_) = b
+thd3 (_,_,c) = c
+
+class Flippable a where
+  flp :: a -> a
+
+
+-- Trace shorthands
+
+showTrace :: Show a => a -> a
+showTrace a = traceShowId a
+
+showTraceTag :: Show a => String -> a -> a
+showTraceTag tag x = trace (tag ++ ": " ++ show x) x
+
+
+-- Code formatting utils
+
+blockParenthesize :: String -> String -> String -> [[String]] -> [String]
+blockParenthesize open close sep liness =
+  case liness of
+    [] -> [open ++ close]
+    _  -> concat [ zipWith (++) (pre:repeat "  ") linez
+                 | (pre, linez) <- zip ((open++" "): repeat (sep++" ")) liness ] ++ [close]
+-- [["line"], ["line1", "line2", "line3"],["linea", "lineb"] ->
+-- ( line
+-- , line1
+--   line2
+--   line3
+-- , linea
+--   lineb
+-- )
+
+addToLastLine :: String -> [String] -> [String]
+addToLastLine str [] = [str]
+addToLastLine str liness = init liness ++ [last liness ++ str]
+
+indent :: Int -> [String] -> [String]
+indent n liness = [ replicate n ' ' ++ line | line <- liness ]

+ src/Database/Design/Ampersand/Basics/BuildInfo_Generated.hs view
@@ -0,0 +1,16 @@+module Database.Design.Ampersand.Basics.BuildInfo_Generated(cabalVersionStr, gitInfoStr, buildTimeStr) where
+
+-- This module is generated automatically by Setup.hs before building. Do not edit!
+
+{-# NOINLINE cabalVersionStr #-}
+cabalVersionStr :: String
+cabalVersionStr = "3.0.3"
+
+{-# NOINLINE gitInfoStr #-}
+gitInfoStr :: String
+gitInfoStr = "master:5d85663*"
+
+{-# NOINLINE buildTimeStr #-}
+buildTimeStr :: String
+buildTimeStr = "30-Apr-15 10:43:19 West-Europa (zomertijd)"
+

+ src/Database/Design/Ampersand/Basics/Collection.hs view
@@ -0,0 +1,27 @@+module Database.Design.Ampersand.Basics.Collection
+  (  Collection ( eleM
+                , uni
+                , isc
+                ,(>-)
+                ,empty
+                ,elems)
+  )where
+   ----------------------------------------------
+   ---- Collection of type a --------------------
+   ----------------------------------------------
+   infixl 5  >-
+
+   class Collection a where      -- TODO Vervangen door efficient algorithme: Data.Set
+    eleM :: Eq b => b -> a b -> Bool
+    uni, isc :: Eq b => a b -> a b -> a b
+    (>-) :: Eq b => a b -> a b -> a b
+    empty :: Eq b => a b
+    elems :: Eq b => a b -> [b]
+
+   instance Collection [] where
+    eleM         = elem
+    xs `uni` ys  = xs++(ys>-xs)
+    xs `isc` ys  = [y | y<-ys, y `elem` xs]
+    xs >- ys     = [x | x<-xs, x `notElem` ys]
+    empty        = []
+    elems        = id

+ src/Database/Design/Ampersand/Basics/String.hs view
@@ -0,0 +1,26 @@+  -- | This module contains some common String funcions
+module Database.Design.Ampersand.Basics.String (unCap,upCap,escapeNonAlphaNum) where
+
+import Data.Char
+
+-- | Converts the first character of a string to lowercase, with the exception that there is a second character, which is uppercase.
+-- uncap "AbcDe" == "abcDe"
+-- uncap "ABcDE" == "ABcDE"
+unCap :: String -> String
+unCap [] = []
+unCap [h] = [toLower h]
+unCap (h:h':t) | isUpper h' = h:h':t
+               | otherwise  = toLower h:h':t
+-- | Converts the first character of a string to uppercase
+upCap :: String -> String
+upCap [] = []
+upCap (h:t) = toUpper h:t
+
+-- | escape anything except regular characters and digits to _<character code>
+-- e.g. escapeNonAlphaNum "a_é" = "a_95_233"
+escapeNonAlphaNum :: String -> String
+escapeNonAlphaNum = concatMap escapeNonAlphaNumChar
+ where escapeNonAlphaNumChar c
+         | isAlphaNum c && isAscii c = [c]
+         | otherwise                 = '_' : show (ord c)
+   
+ src/Database/Design/Ampersand/Basics/UTF8.hs view
@@ -0,0 +1,127 @@+{-
+Copyright (C) 2010 John MacFarlane <jgm@berkeley.edu>
+
+This program is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or
+(at your option) any later version.
+
+This program is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with this program; if not, write to the Free Software
+Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
+-}
+
+{- |
+   Module      : Text.Pandoc.UTF8
+   Copyright   : Copyright (C) 2010 John MacFarlane
+   License     : GNU GPL, version 2 or above
+
+   Maintainer  : John MacFarlane <jgm@berkeley.edu>
+   Stability   : alpha
+   Portability : portable
+
+UTF-8 aware string IO functions that will work with GHC 6.10, 6.12, or 7.
+-}
+module Database.Design.Ampersand.Basics.UTF8
+           ( readUTF8File
+           , readFile
+           , writeFile
+           , getContents
+           , putStr
+           , putStrLn
+           , hGetContents
+           , hPutStr
+           , hPutStrLn
+           )
+
+where
+import Codec.Binary.UTF8.String (encodeString)
+import qualified Data.ByteString as B hiding (putStrLn)
+import qualified Data.ByteString.Char8 as C (putStrLn)
+import Data.ByteString.UTF8 (toString, fromString)
+import Prelude hiding (readFile, writeFile, getContents, putStr, putStrLn)
+import System.IO (Handle)
+import Control.Monad (liftM)
+import Data.Text (unpack)
+import Data.Text.Encoding (decodeUtf8)
+import Data.Word
+import Data.Bits
+import Control.Exception
+
+bom :: B.ByteString
+bom = B.pack [0xEF, 0xBB, 0xBF]
+
+stripBOM :: B.ByteString -> B.ByteString
+stripBOM s | bom `B.isPrefixOf` s = B.drop 3 s
+stripBOM s = s
+
+-- Try to read file pth as UTF-8 and return (Left err) in case of failure, or (Right contents) on success.
+readUTF8File :: FilePath -> IO (Either String String)
+readUTF8File pth =
+ do { contents <- fmap stripBOM $ B.readFile pth
+    -- Exceptions from decodeUtf8 only show the offending byte, which is not helpful, so we validate the file ourselves to get a good error message.
+    ; let res = case validateUTF8 $ contents of
+                 Just utf8PrefixRev -> let utf8Lines = lines . unpack . decodeUtf8 $ utf8PrefixRev
+                                       in  Left $ "Invalid UTF-8 character at line "++ show (length utf8Lines) ++
+                                           case reverse utf8Lines of 
+                                             []   -> "" -- won't happen
+                                             ln:_ -> " : " ++ show (length ln + 1) ++ " (column nr when viewed as UTF-8)\n" ++ 
+                                                     "Text preceding invalid character:\n" ++ "..." ++ (reverse . take 50 . reverse $ ln)++"<INVALID CHARACTER>" 
+                 Nothing -> let txt = decodeUtf8 $ contents
+                            in  Right $ unpack txt
+    ; seq (either length length res) $ return res -- force decodeUtf8 exceptions
+    } `catch` \exc ->
+ do { return $ Left $ show (exc :: SomeException) --  should not occur if validateUTF8 works correctly
+    }
+
+readFile :: FilePath -> IO String
+readFile = liftM (toString . stripBOM) . B.readFile . encodeString
+
+writeFile :: FilePath -> String -> IO ()
+writeFile f = B.writeFile (encodeString f) . fromString
+
+getContents :: IO String
+getContents = liftM (toString . stripBOM) B.getContents
+
+putStr :: String -> IO ()
+putStr = B.putStr . fromString
+
+putStrLn :: String -> IO ()
+putStrLn = C.putStrLn . fromString
+
+hGetContents :: Handle -> IO String
+hGetContents h = liftM (toString . stripBOM) (B.hGetContents h)
+
+hPutStr :: Handle -> String -> IO ()
+hPutStr h = B.hPutStr h . fromString
+
+hPutStrLn :: Handle -> String -> IO ()
+hPutStrLn h s = hPutStr h (s ++ "\n")
+
+-- Return Nothing if bs is valid UTF-8, or Just the maximum valid prefix if it contains an invalid character
+validateUTF8 :: B.ByteString -> Maybe B.ByteString
+validateUTF8 bs = fmap (B.pack . reverse) $ validate [] $ B.unpack bs
+  where validate :: [Word8] -> [Word8] -> Maybe [Word8]
+        validate _         []                                     = Nothing
+        validate validated (w:ws)            | bitMask0xxxxxxx w  = validate (w : validated) ws
+        validate validated (w1:w2:ws)        | bitMask110xxxxx w1 
+                                            && bitMask10xxxxxx w2 = validate (w2:w1 : validated) ws
+        validate validated (w1:w2:w3:ws)     | bitMask1110xxxx w1
+                                            && bitMask10xxxxxx w2
+                                            && bitMask10xxxxxx w3 = validate (w3:w2:w1 : validated) ws
+        validate validated (w1:w2:w3:w4:ws)  | bitMask11110xxx w1
+                                            && bitMask10xxxxxx w2
+                                            && bitMask10xxxxxx w3
+                                            && bitMask10xxxxxx w4 = validate (w4:w3:w2:w1 : validated) ws
+        validate validated _                                      = Just validated
+        
+        bitMask0xxxxxxx w = w .&. (bit 7)                                 == 0
+        bitMask10xxxxxx w = w .&. (bit 7 + bit 6)                         == bit 7
+        bitMask110xxxxx w = w .&. (bit 7 + bit 6 + bit 5)                 == bit 7 + bit 6
+        bitMask1110xxxx w = w .&. (bit 7 + bit 6 + bit 5 + bit 4)         == bit 7 + bit 6 + bit 5
+        bitMask11110xxx w = w .&. (bit 7 + bit 6 + bit 5 + bit 4 + bit 3) == bit 7 + bit 6 + bit 5 + bit 4

+ src/Database/Design/Ampersand/Basics/Unique.hs view
@@ -0,0 +1,50 @@+{-# LANGUAGE DeriveDataTypeable #-}
+module Database.Design.Ampersand.Basics.Unique 
+  (Unique(..),Named(..))
+where
+import Data.Typeable
+import Data.List
+import Data.Char
+import Database.Design.Ampersand.Basics.Version
+
+fatal :: Int -> String -> a
+fatal = fatalMsg "Unique"
+
+-- | anything could have some label, can't it?
+class Named a where
+  name :: a->String
+
+-- | In the context of the haskell code, things can be Unique. 
+class (Typeable e, Eq e) => Unique e where 
+  -- | a representation of a unique thing
+  self :: e -> UniqueObj e
+  self a = UniqueObj { theThing = a
+                     , theShow  = showUnique
+                     }
+  -- | representation of a Unique thing into a string.  
+  uniqueShow :: Bool ->  --  Should the type show too? 
+              e    ->  --  the thing to show
+              String
+  uniqueShow includeType x = typePrefix ++ (showUnique . theThing . self) x
+    where
+      typePrefix = if includeType then show $ typeOf x else ""
+  -- | A function to show a unique instance. It is the responsability
+  --   of the instance definition to make sure that for every a, b of 
+  --   an individual type:
+  --        a == b  <==> showUnique a == showUnique b
+  showUnique :: e -> String
+  {-# MINIMAL showUnique #-}
+  
+
+-- | this is the implementation of the abstract data type. It mustn't be exported
+data UniqueObj a = 
+       UniqueObj { theThing :: a
+                 , theShow  :: (a -> String)
+                 } deriving (Typeable)
+
+instance Unique a => Unique [a] where
+   showUnique [] = fatal 74 $ "empty list is not unique"
+   showUnique xs = "["++intercalate ", " (map showUnique xs)++"]"
+
+instance Unique Bool where
+ showUnique = map toLower . show 

+ src/Database/Design/Ampersand/Basics/Version.hs view
@@ -0,0 +1,29 @@+-- | This module contains Version of Ampersand
+module Database.Design.Ampersand.Basics.Version (ampersandVersionStr, ampersandVersionWithoutBuildTimeStr, fatalMsg) where
+
+import Database.Design.Ampersand.Basics.BuildInfo_Generated
+
+-- | a function to create error message in a structured way, containing the version of Ampersand.
+--   It throws an error, showing a (module)name and a number. This makes debugging pretty easy.
+fatalMsg :: String -> Int -> String -> a
+fatalMsg haskellModuleName lineNr msg
+ = error ("!fatal "++show lineNr++" (module "++haskellModuleName++") "++ampersandVersionWithoutBuildTimeStr++"\n  "++
+            let maxLen = 1500 -- This trick is to make sure the process is terminated after the error.
+                              -- If the string is too long, it seems that the sentinel `hangs`.
+                              -- But what is too long???
+            in case drop maxLen msg of
+                [] -> msg
+                _  -> take maxLen msg ++"\n<The rest of error message has been cut off.>"
+           )
+
+-- | String, containing the Ampersand version, including the build timestamp.
+ampersandVersionStr :: String
+ampersandVersionStr = ampersandVersionWithoutBuildTimeStr ++", build time: "++buildTimeStr
+
+-- | String, containing the Ampersand version
+ampersandVersionWithoutBuildTimeStr :: String
+ampersandVersionWithoutBuildTimeStr = "Ampersand v"++cabalVersionStr++"["++gitInfoStr++"]"
+{-
+   #1.#2.#3[$gitInfo] : #1 major version; #2 student release version; #3 production fix version (normally 0 );
+   $gitInfo: "branch:SHA", followed by a '*' if the working copy was dirty: e.g. "master:0eea5e3*" 
+-}

+ src/Database/Design/Ampersand/Classes.hs view
@@ -0,0 +1,14 @@+module Database.Design.Ampersand.Classes
+   ( module Database.Design.Ampersand.Classes.Populated
+   , module Database.Design.Ampersand.Classes.ConceptStructure
+   , module Database.Design.Ampersand.Classes.Relational
+   , module Database.Design.Ampersand.Classes.ViewPoint
+   ) where
+import Database.Design.Ampersand.Classes.Populated
+       (fullContents,atomsOf)
+import Database.Design.Ampersand.Classes.ConceptStructure
+       (ConceptStructure(..))
+import Database.Design.Ampersand.Classes.Relational
+       (Relational(..))
+import Database.Design.Ampersand.Classes.ViewPoint
+       (Language(..))
+ src/Database/Design/Ampersand/Classes/ConceptStructure.hs view
@@ -0,0 +1,206 @@+{-# LANGUAGE FlexibleInstances #-}
+module Database.Design.Ampersand.Classes.ConceptStructure (ConceptStructure(..)) where      
+
+import Database.Design.Ampersand.Core.AbstractSyntaxTree
+import Database.Design.Ampersand.Basics
+import Data.List
+import Data.Maybe
+import Database.Design.Ampersand.ADL1.Expression(primitives,isMp1,foldrMapExpression)
+import Database.Design.Ampersand.Classes.ViewPoint
+import Prelude hiding (Ordering(..))
+
+fatal :: Int -> String -> a
+fatal = fatalMsg "Classes.ConceptStructure"
+
+{- TODO: Interface parameters (of type Declaration) are returned as Expressions by expressionsIn, to preserve the meaning of relsMentionedIn
+   (implemented using primsMentionedIn, which calls expressionsIn). A more correct way to do this would be to not use expressionsIn, but
+   define relsMentionedIn directly.
+   
+   Another improvement would be to factorize the prim constructors from the Expression data type, so expressionsIn won't need to be partial
+   anymore.
+-}
+
+class ConceptStructure a where
+  concs ::    a -> [A_Concept]       -- ^ the set of all concepts used in data structure a
+  relsUsedIn :: a -> [Declaration]        -- ^ the set of all declaratons used within data structure a. `used within` means that there is a relation that refers to that declaration.
+  relsUsedIn a = [ d | d@Sgn{}<-relsMentionedIn a]++[Isn c | c<-concs a]
+  relsMentionedIn :: a -> [Declaration]        -- ^ the set of all declaratons used within data structure a. `used within` means that there is a relation that refers to that declaration.
+  relsMentionedIn = nub . map prim2rel . primsMentionedIn
+  primsMentionedIn :: a -> [Expression]
+  primsMentionedIn = nub . concatMap primitives . expressionsIn
+  expressionsIn :: a -> [Expression] -- ^The set of all expressions within data structure a
+  
+  -- | mp1Pops draws the population from singleton expressions.
+  mp1Pops :: a -> [Population]
+  mp1Pops struc
+   = [ PCptPopu{ popcpt = cpt (head cl)
+               , popas = map atm cl } 
+     | cl<-eqCl cpt ((filter isMp1.primsMentionedIn) struc)]
+     where cpt (EMp1 _ c) = c
+           cpt _          = fatal 31 "cpt error"
+           atm (EMp1 a _) = a
+           atm _          = fatal 31 "atm error"
+           
+prim2rel :: Expression -> Declaration
+prim2rel e
+ = case e of
+    EDcD d@Sgn{} -> d
+    EDcD{}       -> fatal 23 "invalid declaration in EDcD{}"
+    EDcI c       -> Isn c
+    EDcV sgn     -> Vs sgn
+    EMp1 _ c     -> Isn c
+    _            -> fatal 40 $ "only primitive expressions should be found here.\nHere we see: " ++ show e
+
+instance (ConceptStructure a,ConceptStructure b) => ConceptStructure (a, b)  where
+  concs    (a,b) = concs a `uni` concs b
+  expressionsIn (a,b) = expressionsIn a `uni` expressionsIn b
+
+instance ConceptStructure a => ConceptStructure (Maybe a) where
+  concs    ma = maybe [] concs ma
+  expressionsIn ma = maybe [] expressionsIn ma
+
+instance ConceptStructure a => ConceptStructure [a] where
+  concs     = nub . concatMap concs
+  expressionsIn = foldr ((uni) . expressionsIn) []
+
+instance ConceptStructure A_Context where
+  concs ctx = foldr uni []
+              [ (concs.ctxpats) ctx
+              , (concs.ctxrs) ctx
+              , (concs.ctxds) ctx
+              , (concs.ctxpopus) ctx
+              , (concs.ctxcds) ctx
+              , (concs.ctxks) ctx
+              , (concs.ctxvs) ctx
+              , (concs.ctxgs) ctx
+              , (concs.ctxifcs) ctx
+              , (concs.ctxps) ctx
+              , (concs.ctxsql) ctx
+              , (concs.ctxphp) ctx
+              ]
+  expressionsIn ctx = foldr uni []
+                      [ (expressionsIn.ctxpats) ctx
+                      , (expressionsIn.ctxifcs) ctx
+                      , (expressionsIn.ctxrs) ctx
+                      , (expressionsIn.ctxks) ctx
+                      , (expressionsIn.ctxvs) ctx
+                      , (expressionsIn.ctxsql) ctx
+                      , (expressionsIn.ctxphp) ctx
+                      , (expressionsIn.multrules) ctx
+                      , (expressionsIn.identityRules) ctx
+                      ]
+
+instance ConceptStructure IdentityDef where
+  concs       identity   = [idCpt identity] `uni` concs [objDef | IdentityExp objDef <- identityAts identity]
+  expressionsIn identity = expressionsIn             [objDef | IdentityExp objDef <- identityAts identity]
+
+instance ConceptStructure ViewDef where
+  concs       vd = [vdcpt vd] `uni` concs [objDef | ViewExp objDef <- vdats vd]
+  expressionsIn vd = expressionsIn        [objDef | ViewExp objDef <- vdats vd]
+
+instance ConceptStructure Expression where
+  concs (EDcI c    ) = [c]
+  concs (EEps i sgn) = nub (i:concs sgn)
+  concs (EDcV   sgn) = concs sgn
+  concs (EMp1 _ c  ) = [c]
+  concs e            = foldrMapExpression uni concs [] e
+  expressionsIn e = [e]
+
+instance ConceptStructure A_Concept where
+  concs         c = [c]
+  expressionsIn _ = []
+
+instance ConceptStructure ConceptDef where
+  concs        cd = [PlainConcept { cptnm = name cd
+                                  }
+                    ]
+  expressionsIn _ = []
+
+instance ConceptStructure Sign where
+  concs (Sign s t) = nub [s,t]
+  expressionsIn _  = []
+
+instance ConceptStructure ObjectDef where
+  concs     obj = [target (objctx obj)] `uni` concs (objmsub obj)
+  expressionsIn obj = foldr (uni) []
+                     [ (expressionsIn.objctx) obj
+                     , (expressionsIn.objmsub) obj
+                     ]
+
+-- Note that these functions are not recursive in the case of InterfaceRefs (which is of course obvious from their types)
+instance ConceptStructure SubInterface where
+  concs (Box _ _ objs)           = concs objs
+  concs (InterfaceRef _)         = []
+  expressionsIn (Box _ _ objs)   = expressionsIn objs
+  expressionsIn (InterfaceRef _) = []
+
+instance ConceptStructure Pattern where
+  concs pat = foldr uni []
+              [ (concs.ptrls) pat
+              , (concs.ptgns) pat
+              , (concs.ptdcs) pat
+              , (concs.ptups) pat
+              , (concs.ptids) pat
+              , (concs.ptxps) pat
+              ]
+  expressionsIn p = foldr (uni) []
+                     [ (expressionsIn.ptrls) p
+                     , (expressionsIn.ptids) p
+                     , (expressionsIn.ptvds) p
+                     ]
+
+instance ConceptStructure Interface where
+  concs         ifc = concs (ifcObj ifc)
+  expressionsIn ifc = foldr (uni) []
+                     [ (expressionsIn.ifcObj) ifc
+                     , map EDcD $ ifcParams ifc -- Return param declarations as expressions
+                     ]
+
+instance ConceptStructure Declaration where
+  concs         d = concs (sign d)
+  expressionsIn _ = fatal 148 "expressionsIn not allowed on Declaration"
+
+instance ConceptStructure Rule where
+  concs r   = concs (rrexp r) `uni` concs (rrviol r)
+  expressionsIn r = foldr (uni) []
+                   [ (expressionsIn.rrexp ) r
+                   , (expressionsIn.rrviol) r
+                   ]
+
+instance ConceptStructure (PairView Expression) where
+  concs         (PairView ps) = concs         ps
+  expressionsIn (PairView ps) = expressionsIn ps
+
+instance ConceptStructure Population where
+  concs pop@PRelPopu{} = concs (popdcl pop)
+  concs pop@PCptPopu{} = concs (popcpt pop)
+  expressionsIn _    = []
+
+instance ConceptStructure Purpose where
+  concs pop@Expl{} = concs (explObj pop)
+  expressionsIn _ = []
+
+instance ConceptStructure ExplObj where
+  concs (ExplConceptDef cd) = concs cd
+  concs (ExplDeclaration d) = concs d
+  concs (ExplRule _)        = [{-beware of loops...-}]
+  concs (ExplIdentityDef _) = [{-beware of loops...-}]
+  concs (ExplViewDef _)     = [{-beware of loops...-}]
+  concs (ExplPattern _)     = [{-beware of loops...-}]
+  concs (ExplInterface _)   = [{-beware of loops...-}]
+  concs (ExplContext _)     = [{-beware of loops...-}]
+  
+  expressionsIn _ = []
+
+instance ConceptStructure (PairViewSegment Expression) where
+  concs pvs = case pvs of
+      PairViewText{} -> []
+      PairViewExp{}  -> concs (pvsExp pvs)
+  expressionsIn pvs = case pvs of
+      PairViewText{} -> []
+      PairViewExp{}  -> expressionsIn (pvsExp pvs)
+
+instance ConceptStructure A_Gen where
+  concs g@Isa{}  = nub [gengen g,genspc g]
+  concs g@IsE{}  = nub (genspc g: genrhs g)
+  expressionsIn _ = fatal 160 "expressionsIn not allowed on A_Gen"

+ src/Database/Design/Ampersand/Classes/Populated.hs view
@@ -0,0 +1,99 @@+module Database.Design.Ampersand.Classes.Populated (fullContents,atomsOf) where
+{- This file contains all functions to compute populations.
+   The implementation is done through Haskell's Map mechanism, as defined in Data.Map, for reasons of efficiency.
+-}
+
+import Prelude hiding (lookup)
+import Database.Design.Ampersand.ADL1.Pair
+import Database.Design.Ampersand.ADL1.Expression                 (notCpl)
+import Database.Design.Ampersand.Core.AbstractSyntaxTree
+import Database.Design.Ampersand.Basics hiding (empty)
+import Data.Map hiding (null, unions)
+   -- WHY: don't we use strict Maps? Since the sets of atoms and pairs are finite, we might want the efficiency of strictness.
+import Data.Maybe (maybeToList)
+import Data.List (nub)
+fatal :: Int -> String -> a
+fatal = fatalMsg "Classes.Populated"
+
+-- | This function returns the atoms of a concept (like fullContents does for relation-like things.)
+atomsOf :: [A_Gen]      -- the generalisation relations from the context
+        -> [Population] -- the user defined populations in the context
+        -> A_Concept    -- the concept from which the population is requested
+        -> [String]     -- the elements in the concept's set of atoms
+atomsOf gens pt c
+ = case c of
+     ONE -> ["1"] -- fatal 22 "Asking for the value of the universal singleton"
+     PlainConcept{}
+         -> let smallerconcs = c:smallerConcepts gens c in
+            nub$ [srcPaire p | pop@PRelPopu{} <- pt, source (popdcl pop) `elem` smallerconcs, p <- popps pop]
+               ++[trgPaire p | pop@PRelPopu{} <- pt, target (popdcl pop) `elem` smallerconcs, p <- popps pop]
+               ++[a          | pop@PCptPopu{} <- pt, popcpt pop `elem` smallerconcs, a <- popas pop]
+
+pairsOf :: [A_Gen] -> [Population] -> Declaration -> Map String [String]
+pairsOf gens pt dcl
+ = case dcl of
+     Isn c  -> fromList [ (a,[a])   | a  <-atomsOf gens pt c]
+     Vs sgn -> fromList [ (sa, atomsOf gens pt (target sgn)) | sa <-atomsOf gens pt (source sgn)]
+     Sgn{}  -> unionsWith uni
+                      [ fromListWith uni [ (srcPaire p,[trgPaire p]) | p<-popps pop]
+                      | pop@PRelPopu{} <- pt
+                      , name dcl==name (popdcl pop)
+                      , let s=source (popdcl pop) in s `elem` source dcl:smallerConcepts gens (source dcl)
+                      , let t=target (popdcl pop) in t `elem` target dcl:smallerConcepts gens (target dcl)
+                      ]
+
+fullContents :: [A_Gen] -> [Population] -> Expression -> Pairs
+fullContents gens pt e = [ mkPair a b | let pairMap=contents e, a<-keys pairMap, b<-pairMap ! a ]
+  where
+   unions t1 t2 = unionWith uni t1 t2
+   inters t1 t2 = mergeWithKey (\_ l r ->case l `isc` r of [] -> Nothing; atoms -> Just atoms) c c t1 t2
+                  where c=const empty
+   differ t1 t2 = differenceWith (\l r->case l >- r of [] -> Nothing; atoms -> Just atoms) t1 t2
+   contents :: Expression -> Map String [String]
+   contents expr
+    = let lkp x contMap = (concat.maybeToList.lookup x) contMap in  -- (!) may not be used, because we don't know whether x `elem` keys fmap
+      case expr of
+         EEqu (l,r) -> contents ((l .|-. r) ./\. (r .|-. l))
+         EImp (l,r) -> contents (notCpl l .\/. r)
+         EUni (l,r) -> unions (contents l) (contents r)
+         EIsc (l,r) -> inters (contents l) (contents r)
+         EDif (l,r) -> differ (contents l) (contents r)
+         -- The left residual l/r is defined by: for all x,y:  x(l/r)y  <=>  for all z in X, y r z implies x l z.
+         ELrs (l,r) -> fromListWith (++)
+                       [(x,[y]) | x<-atomsOf gens pt (source l), y<-atomsOf gens pt (source r)
+                                , null (lkp y (contents r) >- lkp x (contents l))
+                                ]
+         -- The right residual l\r defined by: for all x,y:   x(l\r)y  <=>  for all z in X, z l x implies z r y.
+         ERrs (l,r) -> fromListWith uni
+                       [(x,[y]) | x<-atomsOf gens pt (target l), y<-atomsOf gens pt (target r)
+                                , null (lkp x (contents (EFlp l)) >- lkp y (contents (EFlp r)))
+                                ]
+         EDia (l,r) -> fromListWith (++)
+                       [(x,[y]) | x<-atomsOf gens pt (source l), y<-atomsOf gens pt (source r)
+                                , null (lkp y (contents r) >- lkp x (contents l))
+                                , null (lkp y (contents l) >- lkp x (contents r))
+                                ]
+         ERad (l,r) -> fromListWith uni
+                       [(x,[y]) | x<-atomsOf gens pt (source l), y<-atomsOf gens pt (target r)
+                                , null (atomsOf gens pt (target l) >- (lkp x (contents l) `uni` lkp y (contents (EFlp r))))
+                                ]
+         EPrd (l,r) -> fromList $
+                       [ (a,cod) | a <- atomsOf gens pt (source l), let cod=atomsOf gens pt (target r), not (null cod) ]
+         ECps (l,r) -> fromListWith uni
+                       [(x,[y]) | x<-keys (contents l), y<-keys flipr
+                                , (not.null) ((contents l ! x ) `isc` (flipr ! y))
+                                ] where flipr = contents (EFlp r)
+         EKl0 x     -> if source x == target x --see #166
+                       then transClosureMap (unionWith uni (contents x) (contents (EDcI (source x))))
+                       else fatal 87 ("source and target of "++show x++show (sign x)++ " are not equal.")
+         EKl1 x     -> if source x == target x --see #166
+                       then transClosureMap (contents x)
+                       else fatal 90 ("source and target of "++show x++show (sign x)++ " are not equal.")
+         EFlp x     -> fromListWith uni [(b,[a]) | (a,bs)<-assocs (contents x), b<-bs]
+         ECpl x     -> contents (EDcV (sign x) .-. x)
+         EBrk x     -> contents x
+         EDcD dcl   -> pairsOf gens pt dcl
+         EDcI c     -> fromList [(a,[a]) | a <- atomsOf gens pt c]
+         EEps i _   -> fromList [(a,[a]) | a <- atomsOf gens pt i]
+         EDcV sgn   -> fromList [(s, cod) | s <- atomsOf gens pt (source sgn), let cod=atomsOf gens pt (target sgn), not (null cod) ]
+         EMp1 a c   -> fromList [(a,[a]) | name c/="SESSION"] -- prevent populating SESSION

+ src/Database/Design/Ampersand/Classes/Relational.hs view
@@ -0,0 +1,209 @@+module Database.Design.Ampersand.Classes.Relational
+   (Relational(..)
+   ) where
+
+import Data.Maybe
+import Database.Design.Ampersand.Core.AbstractSyntaxTree
+import Database.Design.Ampersand.ADL1.Expression
+import Database.Design.Ampersand.Basics
+
+--fatal :: Int -> String -> a
+--fatal = fatalMsg "Classes.Relational"
+
+class Association r => Relational r where
+    multiplicities :: r -> [Prop]
+    isProp :: r -> Bool  -- > tells whether the argument is a property
+    isImin :: r -> Bool  -- > tells whether the argument is equivalent to I-
+    isTrue :: r -> Bool  -- > tells whether the argument is equivalent to V
+    isFalse :: r -> Bool  -- > tells whether the argument is equivalent to V-
+    isFunction :: r -> Bool
+    isFunction r   = null ([Uni,Tot]>-multiplicities r)
+    isTot :: r -> Bool  --
+    isTot r = Tot `elem` multiplicities r
+    isUni :: r -> Bool  --
+    isUni r = Uni `elem` multiplicities r
+    isSur :: r -> Bool  --
+    isSur r = Sur `elem` multiplicities r
+    isInj :: r -> Bool  --
+    isInj r = Inj `elem` multiplicities r
+    isRfx :: r -> Bool  --
+    isRfx r = Rfx `elem` multiplicities r
+    isIrf :: r -> Bool  --
+    isIrf r = Irf `elem` multiplicities r
+    isTrn :: r -> Bool  --
+    isTrn r = Trn `elem` multiplicities r
+    isSym :: r -> Bool  --
+    isSym r = Sym `elem` multiplicities r
+    isAsy :: r -> Bool  --
+    isAsy r = Asy `elem` multiplicities r
+    isIdent :: r -> Bool  -- > tells whether the argument is equivalent to I
+    isEpsilon :: r -> Bool  -- > tells whether the argument is equivalent to I
+
+--instance Relational Relation where
+--    multiplicities rel
+--      = case rel of
+--           Rel{}               -> multiplicities (reldcl rel)
+--           V {}                -> [Tot]
+--                                ++[Sur]
+--                                ++[Inj | isSingleton (source rel)]
+--                                ++[Uni | isSingleton (target rel)]
+--                                ++[Asy | isEndo rel, isSingleton (source rel)]
+--                                ++[Sym | isEndo rel]
+--                                ++[Rfx | isEndo rel]
+--                                ++[Trn | isEndo rel]
+--           I{}                 -> [Uni,Tot,Inj,Sur,Sym,Asy,Trn,Rfx]
+--    isProp rel = case rel of
+--           Rel{}               -> null ([Asy,Sym]>-multiplicities (reldcl rel))
+--           V{}                 -> isEndo rel && isSingleton (source rel)
+--           I{}                 -> True
+--    isImin rel  = isImin (makeDeclaration rel)   -- > tells whether the argument is equivalent to I-
+--    isTrue rel = case rel of
+--           Rel{}               -> False
+--           V{}                 -> True
+--           I{}                 -> False
+--    isFalse _   = False
+--    isIdent rel = case rel of       -- > tells whether the argument is equivalent to I
+--                   Rel{} -> False
+--                   V{}   -> isEndo rel && isSingleton (source rel)
+--                   I{}   -> True
+
+instance Relational Declaration where
+    multiplicities d = case d of
+           Sgn {}       -> case decprps_calc d of
+                             Nothing -> decprps d
+                             Just ps -> ps
+           Isn{}        -> [Uni,Tot,Inj,Sur,Sym,Asy,Trn,Rfx]
+           Vs{}         -> [Tot,Sur]
+    isProp d = case d of         -- > tells whether the argument is a property.
+           Sgn {}       -> null ([Asy,Sym]>-multiplicities d)
+           Isn{}        -> True
+           Vs{}         -> isEndo (sign d) && isSingleton (source d)
+    isImin _ = False  -- LET OP: Dit kan natuurlijk niet goed zijn, maar is gedetecteerd bij revision 913, toen straffeloos de Iscompl{} kon worden verwijderd.
+    isTrue d = case d of
+           Vs{}         -> True
+           _            -> False
+    isFalse _ = False
+    isIdent d = case d of
+                 Isn{} -> True   -- > tells whether the argument is equivalent to I
+                 _     -> False
+    isEpsilon _ = False
+
+isSingleton :: A_Concept -> Bool
+isSingleton ONE = True
+isSingleton _   = False
+
+-- The function "multiplicities" does not only provide the multiplicities provided by the Ampersand user,
+-- but tries to derive the most obvious multiplicity constraints as well. The more multiplicity constraints are known,
+-- the better the data structure that is derived.
+-- Not every constraint that can be proven is obtained by this function. This does not hurt Ampersand.
+instance Relational Expression where        -- TODO: see if we can find more multiplicity constraints...
+ multiplicities expr = case expr of
+     EDcD dcl   -> multiplicities dcl
+     EDcI{}     -> [Uni,Tot,Inj,Sur,Sym,Asy,Trn,Rfx]
+     EEps a sgn -> [Tot | a == source sgn]++[Sur | a == target sgn] ++ [Uni,Inj]
+     EDcV sgn   -> [Tot]
+                 ++[Sur]
+                 ++[Inj | isSingleton (source sgn)]
+                 ++[Uni | isSingleton (target sgn)]
+                 ++[Asy | isEndo sgn, isSingleton (source sgn)]
+                 ++[Sym | isEndo sgn]
+                 ++[Rfx | isEndo sgn]
+                 ++[Trn | isEndo sgn]
+     EBrk f     -> multiplicities f
+     ECps (l,r) -> [m | m<-multiplicities l `isc` multiplicities r, m `elem` [Uni,Tot,Inj,Sur]] -- endo properties can be used and deduced by and from rules: many rules are multiplicities (TODO)
+     EPrd (l,r) -> [Tot | isTot l]++[Sur | isSur r]++[Rfx | isRfx l&&isRfx r]++[Trn]
+     EKl0 e'    -> [Rfx,Trn] `uni` (multiplicities e'>-[Uni,Inj])
+     EKl1 e'    -> [    Trn] `uni` (multiplicities e'>-[Uni,Inj])
+     ECpl e'    -> [p |p<-multiplicities e', p==Sym]
+     EFlp e'    -> [fromMaybe m $ lookup m [(Uni,Inj),(Inj,Uni),(Sur,Tot),(Tot,Sur)] | m <- multiplicities e'] -- switch Uni<->Inj and Sur<->Tot, keeping the others the same
+     EMp1{}     -> [Uni,Inj,Sym,Asy,Trn]
+     _          -> []
+
+ -- |  isTrue e == True   means that e is true, i.e. the population of e is (source e * target e).
+ --    isTrue e == False  does not mean anything.
+ --    the function isTrue is meant to produce a quick answer, without any form of theorem proving.
+ isTrue expr
+  = case expr of
+     EEqu (l,r) -> l == r
+     EImp (l,_) -> isTrue l
+     EIsc (l,r) -> isTrue l && isTrue r
+     EUni (l,r) -> isTrue l || isTrue r
+     EDif (l,r) -> isTrue l && isFalse r
+     ECps (l,r) | null ([Uni,Tot]>-multiplicities l) -> isTrue r
+                | null ([Sur,Inj]>-multiplicities r) -> isTrue l
+                | otherwise                          -> isTrue l && isTrue r
+     EPrd (l,r) -> isTrue l && isTrue r || isTot l && isSur r || isRfx l && isRfx r
+     EKl0 e     -> isTrue e
+     EKl1 e     -> isTrue e
+     EFlp e     -> isTrue e
+     ECpl e     -> isFalse e
+     EDcD{}     -> False
+     EDcI c     -> isSingleton c
+     EEps i _   -> isSingleton i
+     EDcV{}     -> True
+     EBrk e     -> isTrue e
+     _          -> False  -- TODO: find richer answers for ERrs, ELrs, EDia, ERad, and EMp1
+
+ -- |  isFalse e == True   means that e is false, i.e. the population of e is empty.
+ --    isFalse e == False  does not mean anything.
+ --    the function isFalse is meant to produce a quick answer, without any form of theorem proving.
+ isFalse expr
+  = case expr of
+     EEqu (l,r) -> l == notCpl r
+     EImp (_,r) -> isFalse r
+     EIsc (l,r) -> isFalse r || isFalse l
+     EUni (l,r) -> isFalse r && isFalse l
+     EDif (l,r) -> isFalse l || isTrue r
+     ECps (l,r) -> isFalse r || isFalse l
+     EPrd (l,r) -> isFalse r || isFalse l
+     EKl0 e     -> isFalse e
+     EKl1 e     -> isFalse e
+     EFlp e     -> isFalse e
+     ECpl e     -> isTrue e
+     EDcD{}     -> False
+     EDcI{}     -> False
+     EEps{}     -> False
+     EDcV{}     -> False
+     EBrk e     -> isFalse e
+     _          -> False  -- TODO: find richer answers for ERrs, ELrs, EDia, and ERad
+
+ isProp expr = null ([Asy,Sym]>-multiplicities expr)
+
+ -- |  The function isIdent tries to establish whether an expression is an identity relation.
+ --    It does a little bit more than just test on ERel I _.
+ --    If it returns False, this must be interpreted as: the expression is definitely not I, an may not be equal to I as far as the computer can tell on face value.
+ isIdent expr = case expr of
+     EEqu (l,r) -> isIdent (EIsc (EImp (l,r), EImp (r,l)))    -- TODO: maybe derive something better?
+     EImp (l,r) -> isIdent (EUni (ECpl l, r))                     -- TODO: maybe derive something better?
+     EIsc (l,r) -> isIdent l && isIdent r
+     EUni (l,r) -> isIdent l && isIdent r
+     EDif (l,r) -> isIdent l && isFalse r
+     ECps (l,r) -> isIdent l && isIdent r
+     EKl0 e     -> isIdent e || isFalse e
+     EKl1 e     -> isIdent e
+     ECpl e     -> isImin e
+     EDcD{}     -> False
+     EDcI{}     -> True
+     EEps{}     -> False
+     EDcV sgn   -> isEndo sgn && isSingleton (source sgn)
+     EBrk f     -> isIdent f
+     EFlp f     -> isIdent f
+     _          -> False  -- TODO: find richer answers for ELrs, ERrs, EDia, EPrd, and ERad
+ isEpsilon e = case e of
+                EEps{} -> True
+                _      -> False
+
+ isImin expr' = case expr' of       -- > tells whether the argument is equivalent to I-
+     EEqu (l,r) -> isImin (EIsc (EImp (l,r), EImp (r,l)))       -- TODO: maybe derive something better?
+     EImp (l,r) -> isImin (EUni (ECpl l, r))                  -- TODO: maybe derive something better?
+     EIsc (l,r) -> isImin l && isImin r
+     EUni (l,r) -> isImin l && isImin r
+     EDif (l,r) -> isImin l && isFalse r
+     ECpl e     -> isIdent e
+     EDcD dcl   -> isImin dcl
+     EDcI{}     -> False
+     EEps{}     -> False
+     EDcV{}     -> False
+     EBrk f     -> isImin f
+     EFlp f     -> isImin f
+     _          -> False  -- TODO: find richer answers for ELrs, ERrs, and EDia

+ src/Database/Design/Ampersand/Classes/ViewPoint.hs view
@@ -0,0 +1,98 @@+module Database.Design.Ampersand.Classes.ViewPoint (Language(..)) where
+import Database.Design.Ampersand.Core.ParseTree
+import Database.Design.Ampersand.Core.AbstractSyntaxTree
+import Prelude hiding (Ord(..))
+import Database.Design.Ampersand.ADL1.Rule
+import Database.Design.Ampersand.Classes.Relational  (Relational(multiplicities))
+import Database.Design.Ampersand.Basics
+import Database.Design.Ampersand.Misc.Explain
+import Data.Maybe
+
+fatal :: Int -> String -> a
+fatal = fatalMsg "Classes.ViewPoint"
+
+-- Language exists because there are many data structures that behave like an ontology, such as Pattern, P_Context, and Rule.
+-- These data structures are accessed by means of a common set of functions (e.g. rules, relations, etc.)
+
+class Language a where
+  relsDefdIn :: a -> [Declaration]   -- ^ all relations that are declared in the scope of this viewpoint.
+                                     --   These are user defined relations and all generated relarations,
+                                     --   i.e. one relation for each GEN and one for each signal rule.
+                                     --   Don't confuse relsDefdIn with relsUsedIn, which gives the relations that are
+                                     --   used in a.)
+  udefrules :: a -> [Rule]           -- ^ all user defined rules that are maintained within this viewpoint,
+                                     --   which are not multiplicity- and not identity rules.
+  multrules :: a -> [Rule]           -- ^ all multiplicityrules that are maintained within this viewpoint.
+  multrules x   = catMaybes [rulefromProp p d |d<-relsDefdIn x, p<-multiplicities d]
+  identityRules :: a -> [Rule]       -- all identity rules that are maintained within this viewpoint.
+  identityRules x    = concatMap rulesFromIdentity (identities x)
+  allRules :: a -> [Rule]
+  allRules x = udefrules x ++ multrules x ++ identityRules x
+  identities :: a -> [IdentityDef]   -- ^ all keys that are defined in a
+  viewDefs :: a -> [ViewDef]         -- ^ all views that are defined in a
+  gens :: a -> [A_Gen]               -- ^ all generalizations that are valid within this viewpoint
+  patterns :: a -> [Pattern]         -- ^ all patterns that are used in this viewpoint
+
+ 
+rulesFromIdentity :: IdentityDef -> [Rule]
+rulesFromIdentity identity
+ = [ if null (identityAts identity) then fatal 81 ("Moving into foldr1 with empty list (identityAts identity).") else
+     mkKeyRule
+      ( foldr1 (./\.) [  expr .:. flp expr | IdentityExp att <- identityAts identity, let expr=objctx att ]
+        .|-. EDcI (idCpt identity)) ]
+ {-    diamond e1 e2 = (flp e1 .\. e2) ./\. (e1 ./. flp e2)  -}
+ where ruleName = "identity_" ++ name identity
+       meaningEN = "Identity rule" ++ ", following from identity "++name identity
+       meaningNL = "Identiteitsregel" ++ ", volgend uit identiteit "++name identity
+       mkKeyRule expression =
+         Ru { rrnm   = ruleName
+            , rrexp  = expression
+            , rrfps  = origin identity     -- position in source file
+            , rrmean = AMeaning
+                         [ A_Markup English ReST (string2Blocks ReST meaningEN)
+                         , A_Markup Dutch ReST (string2Blocks ReST meaningNL)
+                         ]
+            , rrmsg  = []
+            , rrviol = Nothing
+            , rrtyp  = sign expression
+            , rrdcl  = Nothing        -- This rule was not generated from a property of some declaration.
+            , r_env  = ""             -- For traceability: The name of the pattern. Unknown at this position but it may be changed by the environment.
+            , r_usr  = Identity            -- This rule was not specified as a rule in the Ampersand script, but has been generated by a computer
+            , isSignal  = False          -- This is not a signal rule
+            }
+
+instance Language a => Language [a] where
+  relsDefdIn  = concatMap relsDefdIn
+  udefrules   = concatMap udefrules
+  identities  = concatMap identities
+  viewDefs    = concatMap viewDefs
+  gens        = concatMap gens
+  patterns    = concatMap patterns
+
+instance Language A_Context where
+  relsDefdIn context = uniteRels (concatMap relsDefdIn (patterns context)
+                                ++ ctxds context)
+     where
+      -- relations with the same name, but different properties (decprps,pragma,decpopu,etc.) may exist and need to be united
+      -- decpopu, decprps and decprps_calc are united, all others are taken from the head.
+      uniteRels :: [Declaration] -> [Declaration]
+      uniteRels [] = []
+      uniteRels ds = [ d | cl<-eqClass (==) ds
+                         , let d=(head cl){ decprps      = (foldr1 uni.map decprps) cl
+                                          , decprps_calc = Nothing -- Calculation is only done in ADL2Fspc. -- was:(foldr1 uni.map decprps_calc) cl
+                                          }]
+  udefrules    context = concatMap udefrules  (ctxpats context) ++ ctxrs context
+  identities   context = concatMap identities (ctxpats context) ++ ctxks context
+  viewDefs     context = concatMap viewDefs   (ctxpats context) ++ ctxvs context
+  gens         context = concatMap gens       (ctxpats context) ++ ctxgs context
+  patterns             = ctxpats
+
+instance Language Pattern where
+  relsDefdIn pat = ptdcs pat
+  udefrules      = ptrls   -- all user defined rules in this pattern
+--  invariants pat = [r |r<-ptrls pat, not (isSignal r)]
+  identities     = ptids
+  viewDefs       = ptvds
+  gens           = ptgns
+  patterns   pat = [pat]
+

+ src/Database/Design/Ampersand/Components.hs view
@@ -0,0 +1,128 @@+-- | This module contains the building blocks that are available in the Ampersand Library. These building blocks will be described further at [ampersand.sourceforge.net |the wiki pages of our project].
+--
+module Database.Design.Ampersand.Components
+  ( -- * Type checking and calculus
+     makeFSpec
+    -- * Generators of output
+   , generateAmpersandOutput
+--   , doGenADL
+--   , doGenProofs
+--   , doGenHaskell
+--   , doGenXML
+--   , doGenUML
+--   , doGenDocument
+--   , doGenFPAExcel
+    -- * etc...
+  )
+where
+import Prelude hiding (putStr,readFile,writeFile)
+import Database.Design.Ampersand.Misc
+import Text.Pandoc
+import Text.Pandoc.Builder
+import Database.Design.Ampersand.Basics
+import Database.Design.Ampersand.FSpec
+import Database.Design.Ampersand.FSpec.GenerateUML
+import Database.Design.Ampersand.FSpec.ShowXMLtiny (showXML)
+import Database.Design.Ampersand.Output
+import Control.Monad
+import System.FilePath
+
+fatal :: Int -> String -> a
+fatal = fatalMsg "Components"
+
+--  | The FSpec is the datastructure that contains everything to generate the output. This monadic function
+--    takes the FSpec as its input, and spits out everything the user requested.
+generateAmpersandOutput :: FSpec -> IO ()
+generateAmpersandOutput fSpec =
+ do { when (genXML (getOpts fSpec))      $ doGenXML      fSpec
+    ; when (genUML (getOpts fSpec))      $ doGenUML      fSpec
+    ; when (haskell (getOpts fSpec))     $ doGenHaskell  fSpec
+    ; when (export2adl (getOpts fSpec))  $ doGenADL      fSpec
+    ; when (genFSpec (getOpts fSpec))    $ doGenDocument fSpec
+    ; when (genFPAExcel (getOpts fSpec)) $ doGenFPAExcel fSpec
+    ; when (proofs (getOpts fSpec))      $ doGenProofs   fSpec
+    --; Prelude.putStrLn $ "Declared rules:\n" ++ show (map showADL $ vrules fSpec)
+    --; Prelude.putStrLn $ "Generated rules:\n" ++ show (map showADL $ grules fSpec)
+    --; Prelude.putStrLn $ "Violations:\n" ++ show (violations fSpec)
+    ; verboseLn (getOpts fSpec) "Done."
+    }
+
+-- An expression e is type ambiguous means that   (showADL e) cannot be parsed (in the context of fSpec) without a type ambiguity error.
+-- Q: Should we disambiguate the exprs in the fSpec i.e. mapexprs disambiguate fSpec fSpec?
+--    Or do we assume a correct implementation with unambiguous expressions only?
+-- A: The fSpec may contain disambiguated expressions only. If one expression somewhere in fSpec is type-ambiguous, fSpec is wrong.
+--    So the answer is: we assume a correct implementation with unambiguous expressions only.
+doGenADL :: FSpec -> IO()
+doGenADL fSpec =
+ do { writeFile outputFile . showADL . originalContext $ fSpec
+    ; verboseLn (getOpts fSpec) $ ".adl-file written to " ++ outputFile ++ "."
+    }
+ where outputFile = combine (dirOutput (getOpts fSpec)) (outputfile (getOpts fSpec))
+
+doGenProofs :: FSpec -> IO()
+doGenProofs fSpec =
+ do { verboseLn (getOpts fSpec) $ "Generating Proof for " ++ name fSpec ++ " into " ++ outputFile ++ "."
+--  ; verboseLn (getOpts fSpec) $ writeTextile def thePandoc
+    ; writeFile outputFile $ writeHtmlString def thePandoc
+    ; verboseLn (getOpts fSpec) "Proof written."
+    }
+ where outputFile = combine (dirOutput (getOpts fSpec)) $ replaceExtension ("proofs_of_"++baseName (getOpts fSpec)) ".html"
+       thePandoc = setTitle title (doc theDoc)
+       title  = text $ "Proofs for "++name fSpec
+       theDoc = fDeriveProofs fSpec
+       --theDoc = plain (text "Aap")  -- use for testing...
+
+doGenHaskell :: FSpec -> IO()
+doGenHaskell fSpec =
+ do { verboseLn (getOpts fSpec) $ "Generating Haskell source code for "++name fSpec
+--  ; verboseLn (getOpts fSpec) $ fSpec2Haskell fSpec -- switch this on to display the contents of Installer.php on the command line. May be useful for debugging.
+    ; writeFile outputFile (fSpec2Haskell fSpec)
+    ; verboseLn (getOpts fSpec) $ "Haskell written into " ++ outputFile ++ "."
+    }
+ where outputFile = combine (dirOutput (getOpts fSpec)) $ replaceExtension (baseName (getOpts fSpec)) ".hs"
+
+doGenXML :: FSpec -> IO()
+doGenXML fSpec =
+ do { verboseLn (getOpts fSpec) "Generating XML..."
+    ; writeFile outputFile $ showXML fSpec (genTime (getOpts fSpec))
+    ; verboseLn (getOpts fSpec) $ "XML written into " ++ outputFile ++ "."
+    }
+   where outputFile = combine (dirOutput (getOpts fSpec)) $ replaceExtension (baseName (getOpts fSpec)) ".xml"
+
+doGenUML :: FSpec -> IO()
+doGenUML fSpec =
+ do { verboseLn (getOpts fSpec) "Generating UML..."
+    ; writeFile outputFile $ generateUML fSpec
+    ; Prelude.putStrLn $ "Generated file: " ++ outputFile ++ "."
+    }
+   where outputFile = combine (dirOutput (getOpts fSpec)) $ replaceExtension (baseName (getOpts fSpec)) ".xmi"
+
+-- This function will generate all Pictures for a given FSpec.
+-- the returned FSpec contains the details about the Pictures, so they
+-- can be referenced while rendering the FSpec.
+-- This function generates a pandoc document, possibly with pictures from an fSpec.
+doGenDocument :: FSpec -> IO()
+doGenDocument fSpec =
+ do { verboseLn (getOpts fSpec) ("Processing "++name fSpec)
+    ; makeOutput
+    ; verboseLn (getOpts fSpec) $ "Document has been written to " ++ outputFile ++ "."
+    ; when (genGraphics (getOpts fSpec) && not(null thePictures) && fspecFormat (getOpts fSpec)/=FPandoc) $
+        mapM_ (writePicture (getOpts fSpec)) thePictures
+     -- postProcessing of the generated output file depends on the format:
+    ; postProcessor
+    }
+  where (thePandoc,thePictures) =
+          case (theme (getOpts fSpec), fspecFormat (getOpts fSpec)) of
+ -- TODO Ticket #104: Could not find texOnly_proofdoc in any module? Where has in gone?
+ --                (ProofTheme, FLatex ) -> (texOnly_proofdoc fSpec,[])     --generate a proof document
+                 (ProofTheme, _      ) -> fatal 116 "Ampersand only supports proof documents output in LaTeX format. try `-fLatex` "
+                 (_         , _      ) -> fSpec2Pandoc fSpec
+        (outputFile,makeOutput,postProcessor) = writepandoc fSpec thePandoc
+
+-- | This function will generate an Excel workbook file, containing an extract from the FSpec
+doGenFPAExcel :: FSpec -> IO()
+doGenFPAExcel fSpec =
+ do { verboseLn (getOpts fSpec) "Generating Excel..."
+    ; writeFile outputFile (showSpreadsheet (fspec2Workbook fSpec))
+    }
+   where outputFile = combine (dirOutput (getOpts fSpec)) $ replaceExtension ("FPA_"++baseName (getOpts fSpec)) ".xml"  -- Do not use .xls here, because that generated document contains xml.

+ src/Database/Design/Ampersand/Core/AbstractSyntaxTree.hs view
@@ -0,0 +1,757 @@+{-# LANGUAGE FlexibleInstances, UndecidableInstances, OverlappingInstances #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE DeriveGeneric #-}
+module Database.Design.Ampersand.Core.AbstractSyntaxTree (
+   A_Context(..)
+ , Meta(..)
+ , Pattern(..)
+ , PairView(..)
+ , PairViewSegment(..)
+ , Rule(..)
+ , ruleIsInvariantUniOrInj
+ , RuleType(..)
+ , RuleOrigin(..)
+ , Declaration(..)
+ , IdentityDef(..)
+ , IdentitySegment(..)
+ , ViewDef(..)
+ , ViewSegment(..)
+ , A_Gen(..)
+ , Interface(..)
+ , getInterfaceByName
+ , SubInterface(..)
+ , ObjectDef(..)
+ , Object(..)
+ , objAts
+ , Purpose(..)
+ , ExplObj(..)
+ , Expression(..)
+ , getExpressionRelation
+ , A_Concept(..)
+ , A_Markup(..)
+ , AMeaning(..)
+ , A_RoleRule(..)
+ , A_RoleRelation(..)
+ , Sign(..)
+ , Population(..)
+ , GenR
+ , Association(..)
+ , PAclause(..), Event(..), ECArule(..), InsDel(..), Conjunct(..), DnfClause(..)
+  -- (Poset.<=) is not exported because it requires hiding/qualifying the Prelude.<= or Poset.<= too much
+  -- import directly from Database.Design.Ampersand.Core.Poset when needed
+ , (<==>),join,meet,greatest,least,maxima,minima,sortWith
+ , smallerConcepts, largerConcepts, rootConcepts, genericAndSpecifics
+ , showSign
+ , aMarkup2String
+ , module Database.Design.Ampersand.Core.ParseTree  -- export all used constructors of the parsetree, because they have actually become part of the Abstract Syntax Tree.
+ , (.==.), (.|-.), (./\.), (.\/.), (.-.), (./.), (.\.), (.<>.), (.:.), (.!.), (.*.)
+)where
+import qualified Prelude
+import Prelude hiding (Ord(..), Ordering(..))
+import Database.Design.Ampersand.Basics
+import Database.Design.Ampersand.Core.ParseTree ( MetaObj(..),Meta(..),Role(..),ConceptDef,Origin(..),Traced(..), ViewHtmlTemplate(..){-, ViewTextTemplate(..)-}
+                                                , PairView(..),PairViewSegment(..),Prop(..),Lang,Pairs, PandocFormat, P_Markup(..), PMeaning(..)
+                                                , SrcOrTgt(..), isSrc)
+import Database.Design.Ampersand.Core.Poset (Poset(..), Sortable(..),Ordering(..),greatest,least,maxima,minima,sortWith)
+import Database.Design.Ampersand.Misc
+import Text.Pandoc hiding (Meta)
+import Data.Function
+import Data.List (intercalate,nub,delete)
+import Data.Typeable
+import GHC.Generics (Generic)
+import Data.Hashable
+
+fatal :: Int -> String -> a
+fatal = fatalMsg "Core.AbstractSyntaxTree"
+
+data A_Context
+   = ACtx{ ctxnm :: String           -- ^ 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 (currently: LaTeX, ...)
+         , ctxthms :: [String]       -- ^ Names of patterns/processes to be printed in the functional specification. (For partial documents.)
+         , ctxpats :: [Pattern]      -- ^ The patterns defined in this context
+         , ctxrs :: [Rule]           -- ^ All user defined rules in this context, but outside patterns and outside processes
+         , ctxds :: [Declaration]    -- ^ 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
+         , ctxcds :: [ConceptDef]    -- ^ 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
+         , ctxrrules :: [A_RoleRule]
+         , ctxRRels :: [A_RoleRelation] -- ^ The assignment of roles to Relations (which role mayEdit what relations)
+         , ctxvs :: [ViewDef]        -- ^ The view definitions defined in this context, outside the scope of patterns
+         , ctxgs :: [A_Gen]          -- ^ 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
+         , ctxsql :: [ObjectDef]     -- ^ user defined sqlplugs, taken from the Ampersand script
+         , ctxphp :: [ObjectDef]     -- ^ user defined phpplugs, taken from the Ampersand script
+         , ctxmetas :: [Meta]        -- ^ used for Pandoc authors (and possibly other things)
+         } deriving (Typeable)              --deriving (Show) -- voor debugging
+instance Show A_Context where
+  showsPrec _ c = showString (ctxnm c)
+instance Eq A_Context where
+  c1 == c2  =  name c1 == name c2
+instance Unique A_Context where
+  showUnique = name
+instance Named A_Context where
+  name  = ctxnm
+
+data A_RoleRelation
+   = RR { rrRoles :: [Role]     -- ^ name of a role
+        , rrRels :: [Declaration]   -- ^ name of a Relation
+        , rrPos :: Origin       -- ^ position in the Ampersand script
+        } deriving Show
+instance Traced A_RoleRelation where
+   origin = rrPos
+
+data Pattern
+   = A_Pat { ptnm :: String         -- ^ Name of this pattern
+           , ptpos :: Origin        -- ^ the position in the file in which this pattern was declared.
+           , ptend :: Origin        -- ^ the end position in the file, elements with a position between pos and end are elements of this pattern.
+           , ptrls :: [Rule]        -- ^ The user defined rules in this pattern
+           , ptgns :: [A_Gen]       -- ^ The generalizations defined in this pattern
+           , ptdcs :: [Declaration] -- ^ The relations that are declared in this pattern
+           , ptups :: [Population]  -- ^ The user defined populations in this pattern
+           , ptids :: [IdentityDef] -- ^ 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)    -- Show for debugging purposes
+instance Eq Pattern where
+  p==p' = ptnm p==ptnm p'
+instance Unique Pattern where
+  showUnique = name
+
+instance Named Pattern where
+ name = ptnm
+instance Traced Pattern where
+ origin = ptpos
+
+
+data A_RoleRule = A_RoleRule { arRoles :: [Role]
+                             , arRules  :: [String] -- the names of the rules 
+                             , arPos   :: Origin 
+                             } deriving (Show)
+data A_Markup =
+    A_Markup { amLang :: Lang -- No Maybe here!  In the A-structure, it will be defined by the default if the P-structure does not define it. In the P-structure, the language is optional.
+             , amFormat :: PandocFormat -- Idem: no Maybe in the A-structure.
+             , amPandoc :: [Block]
+             } deriving (Show, Eq, Prelude.Ord)
+
+data RuleOrigin = UserDefined     -- This rule was specified explicitly as a rule in the Ampersand script
+                | Multiplicity    -- This rule follows implicitly from the Ampersand script (Because of a property) and generated by a computer
+                | Identity             -- This rule follows implicitly from the Ampersand script (Because of a identity) and generated by a computer
+                deriving (Show, Eq)
+data Rule =
+     Ru { rrnm :: String                  -- ^ Name of this rule
+        , rrexp :: Expression              -- ^ The rule expression
+        , rrfps :: Origin                  -- ^ Position in the Ampersand file
+        , rrmean :: AMeaning                -- ^ Ampersand generated meaning (for all known languages)
+        , rrmsg :: [A_Markup]              -- ^ User-specified violation messages, possibly more than one, for multiple languages.
+        , rrviol :: Maybe (PairView Expression) -- ^ Custom presentation for violations, currently only in a single language
+        , rrtyp :: Sign                    -- ^ Allocated type
+        , rrdcl :: Maybe (Prop,Declaration)  -- ^ The property, if this rule originates from a property on a Declaration
+        , r_env :: String                  -- ^ Name of pattern in which it was defined.
+        , r_usr :: RuleOrigin              -- ^ Where does this rule come from?
+        , isSignal :: Bool                    -- ^ True if this is a signal; False if it is an invariant
+        } deriving Typeable 
+instance Eq Rule where
+  r==r' = rrnm r==rrnm r'
+instance Unique Rule where
+  showUnique = rrnm 
+instance Prelude.Ord Rule where
+  compare = Prelude.compare `on` rrnm
+instance Show Rule where
+  showsPrec _ x
+   = showString $ "RULE "++ (if null (name x) then "" else name x++": ")++ show (rrexp x)
+instance Traced Rule where
+  origin = rrfps
+instance Named Rule where
+  name   = rrnm
+instance Association Rule where
+  sign   = rrtyp
+
+-- When an invariant rule is univalent or injective, the way it is stored in a table does not allow the univalence or injectivity
+-- to be broken. Hence, we need not check these rules in the prototype. (preventing breakage is the responsibility of the front-end)
+ruleIsInvariantUniOrInj :: Rule -> Bool
+ruleIsInvariantUniOrInj rule | not (isSignal rule), Just (p,_) <- rrdcl rule = p `elem` [Uni, Inj]
+                             | otherwise                                     = False
+                             -- NOTE: currently all rules coming from properties are invariants, so the not isSignal
+                             -- condition is unnecessary, but this will change in the future.    
+    
+data RuleType = Implication | Equivalence | Truth  deriving (Eq,Show)
+
+data Conjunct = Cjct { rc_id         :: String -- string that identifies this conjunct ('id' rather than 'name', because 
+                                               -- this is an internal id that has no counterpart at the ADL level)
+                     , rc_orgRules   :: [Rule] -- All rules this conjunct originates from
+                     , rc_conjunct   :: Expression
+                     , rc_dnfClauses :: [DnfClause]
+                     } deriving (Show,Typeable)
+
+data DnfClause = Dnf { antcs :: [Expression]
+                     , conss :: [Expression]
+                     }  deriving (Show, Eq) -- Show is for debugging purposes only.
+
+instance Eq Conjunct where
+  rc==rc' = rc_id rc==rc_id rc'
+instance Unique Conjunct where
+  showUnique = rc_id
+instance Prelude.Ord Conjunct where
+  compare = Prelude.compare `on` rc_id
+
+data Declaration =
+  Sgn { decnm :: String     -- ^ the name of the declaration
+      , decsgn :: Sign       -- ^ the source and target concepts of the declaration
+       --multiplicities returns decprps_calc, when it has been calculated. So if you only need the user defined properties do not use multiplicities but decprps
+      , decprps :: [Prop]     -- ^ the user defined multiplicity properties (Uni, Tot, Sur, Inj) and algebraic properties (Sym, Asy, Trn, Rfx)
+      , decprps_calc :: Maybe [Prop] -- ^ the calculated and user defined multiplicity properties (Uni, Tot, Sur, Inj) and algebraic properties (Sym, Asy, Trn, Rfx, Irf). Note that calculated properties are made by adl2fspec, so in the A-structure decprps and decprps_calc yield exactly the same answer.
+      , decprL :: String     -- ^ three strings, which form the pragma. E.g. if pragma consists of the three strings: "Person ", " is married to person ", and " in Vegas."
+      , decprM :: String     -- ^    then a tuple ("Peter","Jane") in the list of links means that Person Peter is married to person Jane in Vegas.
+      , decprR :: String
+      , decMean :: AMeaning   -- ^ the meaning of a declaration, for each language supported by Ampersand.
+      , decfpos :: Origin     -- ^ the position in the Ampersand source file where this declaration is declared. Not all decalartions come from the ampersand souce file.
+      , deciss  :: Bool       -- ^ if true, this is a signal relation; otherwise it is an ordinary relation.
+      , decusr  :: Bool       -- ^ if true, this relation is declared by an author in the Ampersand script; otherwise it was generated by Ampersand.
+      , decpat  :: String     -- ^ the pattern where this declaration has been declared.
+      , decplug :: Bool       -- ^ if true, this relation may not be stored in or retrieved from the standard database (it should be gotten from a Plug of some sort instead)
+      } |
+  Isn
+      { detyp :: A_Concept       -- ^ The type
+      } |
+  Vs
+      { decsgn :: Sign
+      } deriving (Prelude.Ord, Typeable)
+
+instance Eq Declaration where
+  d@Sgn{}     == d'@Sgn{}     = decnm d==decnm d' && decsgn d==decsgn d'
+  d@Isn{}     == d'@Isn{}     = detyp d==detyp d'
+  d@Vs{}      == d'@Vs{}      = decsgn d==decsgn d'
+  _           == _            = False
+instance Unique Declaration where
+  showUnique d = 
+    case d of
+      Sgn{} -> name d++uniqueShow False (decsgn d)
+      Isn{} -> "I["++uniqueShow False (detyp d)++"]"
+      Vs{}  -> "V"++uniqueShow False (decsgn d)
+instance Hashable Declaration where
+   hashWithSalt s dcl = 
+     s `hashWithSalt` constructorNr `hashWithSalt` (origin dcl)
+     where constructorNr :: Int
+           constructorNr 
+             = case dcl of 
+                 Sgn{} -> 0
+                 Isn{} -> 1
+                 Vs{}  -> 2 
+instance Show Declaration where  -- For debugging purposes only (and fatal messages)
+  showsPrec _ decl@Sgn{}
+   = showString (case decl of
+                  Sgn{} -> name decl++showSign (sign decl)
+                  Isn{} -> "I["++show (detyp decl)++"]" -- Isn{} is of type Declaration and it is implicitly defined
+                  Vs{}  -> "V"++show (decsgn decl) )
+-- was:
+--  = showString (unwords (["RELATION",decnm decl,show (decsgn decl),show (decprps_calc decl)
+--                         ,"PRAGMA",show (decprL decl),show (decprM decl),show (decprR decl)]
+--                          ++concatMap showMeaning (ameaMrk (decMean decl))
+--               )        )
+--         where
+--            showMeaning m = "MEANING"
+--                           : ["IN", show (amLang m)]
+--                          ++ [show (amFormat m)]
+--                          ++ ["{+",aMarkup2String m,"-}"]
+--                          -- then [] else ["MEANING",show (decMean decl)] ))
+
+  showsPrec _ d@Isn{}     = showString $ "Isn{detyp="++show(detyp d)++"}"
+  showsPrec _ d@Vs{}      = showString $ "V"++showSign(decsgn d)
+
+aMarkup2String :: A_Markup -> String
+aMarkup2String a = blocks2String (amFormat a) False (amPandoc a)
+
+data AMeaning = AMeaning { ameaMrk ::[A_Markup]} deriving (Show, Eq, Prelude.Ord)
+
+instance Named Declaration where
+  name d@Sgn{}   = decnm d
+  name Isn{}     = "I"
+  name Vs{}      = "V"
+instance Association Declaration where
+  sign d = case d of
+              Sgn {}    -> decsgn d
+              Isn {}    -> Sign (detyp d) (detyp d)
+              Vs {}     -> decsgn d
+instance Traced Declaration where
+  origin d = case d of
+              Sgn{}     -> decfpos d
+              _         -> OriginUnknown
+
+data IdentityDef = Id { idPos :: Origin        -- ^ position of this definition in the text of the Ampersand source file (filename, line number and column number).
+                      , idLbl :: String        -- ^ 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
+                      , identityAts :: [IdentitySegment]  -- ^ the constituent attributes (i.e. name/expression pairs) of this identity.
+                      } deriving (Eq,Show)
+instance Named IdentityDef where
+  name = idLbl
+instance Traced IdentityDef where
+  origin = idPos
+
+data IdentitySegment = IdentityExp ObjectDef deriving (Eq, Show)  -- TODO: refactor to a list of terms
+
+data ViewDef = Vd { vdpos :: Origin          -- ^ position of this definition in the text of the Ampersand source file (filename, line number and column number).
+                  , vdlbl :: String          -- ^ the name (or label) of this View. The label has no meaning in the Compliant Service Layer, but is used in the generated user interface. It is not an empty string.
+                  , vdcpt :: A_Concept       -- ^ the concept for which this view is applicable
+                  , vdIsDefault :: Bool      -- ^ whether or not this is the default view for the concept
+                  , vdhtml :: Maybe ViewHtmlTemplate -- ^ the html template for this view (not required since we may have other kinds of views as well in the future)
+--                  , vdtext :: Maybe ViewText -- Future extension
+                  , vdats :: [ViewSegment]   -- ^ the constituent attributes (i.e. name/expression pairs) of this view.
+                  } deriving (Eq,Show)
+instance Named ViewDef where
+  name = vdlbl
+instance Traced ViewDef where
+  origin = vdpos
+
+data ViewSegment = ViewExp ObjectDef | ViewText String | ViewHtml String deriving (Eq, Show)
+
+
+-- | data structure A_Gen contains the CLASSIFY statements from an Ampersand script
+--   CLASSIFY Employee ISA Person   translates to Isa (C "Person") (C "Employee")
+--   CLASSIFY Workingstudent IS Employee/\Student   translates to IsE orig (C "Workingstudent") [C "Employee",C "Student"]
+data A_Gen = Isa { genspc :: A_Concept      -- ^ specific concept
+                 , gengen :: A_Concept      -- ^ generic concept
+                 }
+           | IsE { genspc :: A_Concept      -- ^ specific concept
+                 , genrhs :: [A_Concept]    -- ^ concepts of which the conjunction is equivalent to the specific concept
+                 } deriving (Typeable, Eq)
+instance Unique A_Gen where
+  showUnique a =
+    case a of 
+      Isa{} -> uniqueShow False (genspc a)++" ISA "++uniqueShow False (gengen a)
+      IsE{} -> uniqueShow False (genspc a)++" IS "++intercalate " /\\ " (map (uniqueShow False) (genrhs a))
+instance Show A_Gen where
+  -- This show is used in error messages. It should therefore not display the term's type
+  showsPrec _ g =
+    case g of
+     Isa{} -> showString ("CLASSIFY "++show (genspc g)++" ISA "++show (gengen g))
+     IsE{} -> showString ("CLASSIFY "++show (genspc g)++" IS "++intercalate " /\\ " (map show (genrhs g)))
+
+genericAndSpecifics :: A_Gen -> [(A_Concept,A_Concept)]
+genericAndSpecifics gen = 
+    case gen of
+      Isa{} -> [(genspc gen, gengen gen)]
+      IsE{} -> [(genspc gen, g ) | g<-genrhs gen]
+
+-- | this function takes all generalisation relations from the context and a concept and delivers a list of all concepts that are more specific than the given concept.
+--   If there are no cycles in the generalization graph,  cpt  cannot be an element of  smallerConcepts gens cpt.
+smallerConcepts :: [A_Gen] -> A_Concept -> [A_Concept]
+smallerConcepts gens cpt
+  = nub$ oneSmaller ++ concatMap (smallerConcepts gens) oneSmaller
+  where oneSmaller = delete cpt. nub $ [ genspc g | g@Isa{}<-gens, gengen g==cpt ]++[ genspc g | g@IsE{}<-gens, cpt `elem` genrhs g ]
+-- | this function takes all generalisation relations from the context and a concept and delivers a list of all concepts that are more generic than the given concept.
+largerConcepts :: [A_Gen] -> A_Concept -> [A_Concept]
+largerConcepts gens cpt
+ = nub$ oneLarger ++ concatMap (largerConcepts gens) oneLarger
+  where oneLarger  = delete cpt. nub $[ gengen g | g@Isa{}<-gens, genspc g==cpt ]++[ c | g@IsE{}<-gens, genspc g==cpt, c<-genrhs g ]
+
+-- | this function returns the most generic concepts in the class of a given concept
+rootConcepts :: [A_Gen]  -> [A_Concept] -> [A_Concept]
+rootConcepts gens cpts = [ root | root<-nub $ [ c | cpt<-cpts, c<-largerConcepts gens cpt ] `uni` cpts
+                                , root `notElem` [ genspc g | g@Isa{}<-gens]++[c | g@IsE{}<-gens, c<-genrhs g ]
+                                ]
+
+data Interface = Ifc { ifcParams ::   [Declaration]
+                     , ifcClass ::    Maybe String
+                     , ifcArgs ::     [[String]]
+                     , ifcRoles ::    [Role]
+                     , ifcObj ::      ObjectDef -- NOTE: this top-level ObjectDef is contains the interface itself (ie. name and expression)
+                     , ifcEcas ::     [ECArule]
+                     , ifcControls :: [Conjunct]
+                     , ifcPos ::      Origin
+                     , ifcPrp ::      String
+                     } deriving Show
+
+instance Eq Interface where
+  s==s' = name s==name s'
+instance Named Interface where
+  name = name . ifcObj
+instance Traced Interface where
+  origin = ifcPos
+
+-- Utility function for looking up interface refs
+getInterfaceByName :: [Interface] -> String -> Interface
+getInterfaceByName interfaces' nm = case [ ifc | ifc <- interfaces', name ifc == nm ] of
+                                []    -> fatal 327 $ "getInterface by name: no interfaces named "++show nm
+                                [ifc] -> ifc
+                                _     -> fatal 330 $ "getInterface by name: multiple interfaces named "++show nm
+ 
+objAts :: ObjectDef -> [ObjectDef]
+objAts obj
+  = case objmsub obj of
+     Nothing       -> []
+     Just (InterfaceRef _) -> []
+     Just (Box _ _ objs)     -> objs
+
+class Object a where
+ concept :: a -> A_Concept        -- the type of the object
+ attributes :: a -> [ObjectDef]   -- the objects defined within the object
+ contextOf :: a -> Expression     -- the context expression
+
+instance Object ObjectDef where
+ concept obj = target (objctx obj)
+ attributes  = objAts
+ contextOf   = objctx
+
+data ObjectDef = Obj { objnm ::   String         -- ^ 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)
+                     , objctx ::  Expression     -- ^ this expression describes the instances of this object, related to their context.
+                     , objmView :: Maybe String  -- ^ The view that should be used for this object
+                     , objmsub :: Maybe SubInterface    -- ^ the attributes, which are object definitions themselves.
+                     , objstrs :: [[String]]     -- ^ directives that specify the interface.
+                     } deriving (Eq, Show)       -- just for debugging (zie ook instance Show ObjectDef)
+instance Named ObjectDef where
+  name   = objnm
+instance Traced ObjectDef where
+  origin = objpos
+
+data SubInterface = Box A_Concept (Maybe String)[ObjectDef] | InterfaceRef String deriving (Eq, Show)
+
+data InsDel   = Ins | Del
+                 deriving (Show,Eq)
+data ECArule= ECA { ecaTriggr :: Event       -- The event on which this rule is activated
+                  , ecaDelta ::  Declaration -- The delta to be inserted or deleted from this rule. It actually serves very much like a formal parameter.
+                  , ecaAction :: PAclause    -- The action to be taken when triggered.
+                  , ecaNum ::    Int         -- A unique number that identifies the ECArule within its scope.
+                  }
+                  
+instance Show ECArule where
+  showsPrec _ r = showString ("ON "++show (ecaTriggr r)++" "++show (ecaDelta r)++" do something.")
+
+instance Eq (ECArule) where
+   e==e' = ecaNum e==ecaNum e'
+
+data Event = On { eSrt :: InsDel
+                , eDcl :: Declaration
+                } deriving (Show,Eq)
+
+data PAclause
+              = CHC { paCls :: [PAclause]                 -- precisely one clause is executed.
+                    , paMotiv :: [(Expression,[Rule] )]   -- tells which conjunct from which rule is being maintained
+                    }
+              | GCH { paGCls :: [(InsDel,Expression,PAclause)]    -- guarded choice; The rule is maintained if one of the clauses of which the expression is populated is executed.
+                    , paMotiv :: [(Expression,[Rule] )]   -- tells which conjunct from which rule is being maintained
+                    }
+              | ALL { paCls :: [PAclause]                 -- all clauses are executed.
+                    , paMotiv :: [(Expression,[Rule] )]
+                    }
+              | Do  { paSrt :: InsDel                     -- do Insert or Delete
+                    , paTo :: Declaration                 -- into toExpr    or from toExpr
+                    , paDelta :: Expression               -- delta
+                    , paMotiv :: [(Expression,[Rule] )]
+                    }
+              | New { paCpt :: A_Concept                  -- make a new instance of type c
+                    , paCl :: String->PAclause            -- to be done after creating the concept
+                    , paMotiv :: [(Expression,[Rule] )]
+                    }
+              | Rmv { paCpt :: A_Concept                  -- Remove an instance of type c
+                    , paCl :: String->PAclause            -- to be done afteremoving the concept
+                    , paMotiv :: [(Expression,[Rule] )]
+                    }
+              | Nop { paMotiv :: [(Expression,[Rule] )]   -- tells which conjunct from whichule is being maintained
+                    }
+              | Blk { paMotiv :: [(Expression,[Rule] )]   -- tells which expression from whichule has caused the blockage
+                    }
+              | Let { paExpr :: PAclause                  -- the expression that represents a condition to be tested.
+                    , paBody :: PAclause -> PAclause
+                    , paMotiv :: [(Expression,[Rule] )]
+                    }
+              | Ref { paVar :: String
+                    }
+
+instance Eq PAclause where
+   CHC ds _ == CHC ds' _ = ds==ds'
+   GCH ds _ == GCH ds' _ = ds==ds'
+   ALL ds _ == ALL ds' _ = ds==ds'
+   p@Do{}   ==   p'@Do{} = paSrt p==paSrt p' && paTo p==paTo p' && paDelta p==paDelta p'
+   Nop _    ==     Nop _ = True
+   p@New{}  ==  p'@New{} = paCpt p==paCpt p'
+   p@Rmv{}  ==  p'@Rmv{} = paCpt p==paCpt p'
+   _ == _ = False
+
+-- | Explanation is the intended constructor. It explains the purpose of the object it references.
+--   The enrichment process of the parser must map the names (from PPurpose) to the actual objects
+data Purpose  = Expl { explPos :: Origin     -- ^ The position in the Ampersand script of this purpose definition
+                     , explObj :: ExplObj    -- ^ The object that is explained.
+                     , explMarkup :: A_Markup   -- ^ This field contains the text of the explanation including language and markup info.
+                     , explUserdefd :: Bool       -- ^ Is this purpose defined in the script?
+                     , explRefIds :: [String]     -- ^ The references of the explaination
+                     } deriving (Show, Typeable)
+instance Eq Purpose where
+  x0 == x1  =  explObj x0 == explObj x1 &&  -- TODO: check if this definition is right. 
+                                            -- I(Han) suspect that the Origin should be part of it. 
+               (amLang . explMarkup) x0 == (amLang . explMarkup) x1
+instance Unique Purpose where
+  showUnique p = uniqueShow True (explObj p)++" in "++(show.amLang.explMarkup) p
+                   ++ uniqueShow True (explPos p)
+instance Traced Purpose where
+  origin = explPos
+
+data Population -- The user defined populations
+  = PRelPopu { popdcl :: Declaration
+             , popps ::  Pairs     -- The user-defined pairs that populate the relation
+             }
+  | PCptPopu { popcpt :: A_Concept
+             , popas ::  [String]  -- The user-defined atoms that populate the concept
+             } deriving (Show, Eq)
+
+data ExplObj = ExplConceptDef ConceptDef
+             | ExplDeclaration Declaration
+             | ExplRule String
+             | ExplIdentityDef String
+             | ExplViewDef String
+             | ExplPattern String
+             | ExplInterface String
+             | ExplContext String
+          deriving (Show ,Eq, Typeable)
+instance Unique ExplObj where
+  showUnique e = "Explanation of "++
+    case e of 
+     (ExplConceptDef cd) -> uniqueShow True cd
+     (ExplDeclaration d) -> uniqueShow True d
+     (ExplRule s)        -> "a Rule named "++s
+     (ExplIdentityDef s) -> "an Ident named "++s
+     (ExplViewDef s)     -> "a View named "++s
+     (ExplPattern s)     -> "a Pattern named "++s
+     (ExplInterface s)   -> "an Interface named "++s
+     (ExplContext s)     -> "a Context named "++s
+     
+data Expression
+      = EEqu (Expression,Expression)   -- ^ equivalence             =
+      | EImp (Expression,Expression)   -- ^ implication             |-
+      | EIsc (Expression,Expression)   -- ^ intersection            /\
+      | EUni (Expression,Expression)   -- ^ union                   \/
+      | EDif (Expression,Expression)   -- ^ difference              -
+      | ELrs (Expression,Expression)   -- ^ left residual           /
+      | ERrs (Expression,Expression)   -- ^ right residual          \
+      | EDia (Expression,Expression)   -- ^ diamond                 <>
+      | ECps (Expression,Expression)   -- ^ composition             ;
+      | ERad (Expression,Expression)   -- ^ relative addition       !
+      | EPrd (Expression,Expression)   -- ^ cartesian product       *
+      | EKl0 Expression                -- ^ Rfx.Trn closure         *  (Kleene star)
+      | EKl1 Expression                -- ^ Transitive closure      +  (Kleene plus)
+      | EFlp Expression                -- ^ conversion (flip, wok)  ~
+      | ECpl Expression                -- ^ Complement
+      | EBrk Expression                -- ^ bracketed expression ( ... )
+      | EDcD Declaration               -- ^ simple declaration
+      | EDcI A_Concept                 -- ^ Identity relation
+      | EEps A_Concept Sign            -- ^ Epsilon relation (introduced by the system to ensure we compare concepts by equality only.
+      | EDcV Sign                      -- ^ Cartesian product relation
+      | EMp1 String A_Concept          -- ^ constant (string between single quotes)
+      deriving (Eq, Prelude.Ord, Show, Typeable, Generic)
+instance Unique Expression where
+  showUnique = show
+(.==.), (.|-.), (./\.), (.\/.), (.-.), (./.), (.\.), (.<>.), (.:.), (.!.), (.*.) :: Expression -> Expression -> Expression
+instance Hashable Expression
+instance Unique (PairView Expression) where
+  showUnique = show
+instance Unique (PairViewSegment Expression) where
+  showUnique = show
+infixl 1 .==.   -- equivalence
+infixl 1 .|-.   -- implication
+infixl 2 ./\.   -- intersection
+infixl 2 .\/.   -- union
+infixl 4 .-.    -- difference
+infixl 6 ./.    -- left residual
+infixl 6 .\.    -- right residual
+infixl 6 .<>.   -- diamond
+infixl 8 .:.    -- composition    -- .;. was unavailable, because Haskell's scanner does not recognize it as an operator.
+infixl 8 .!.    -- relative addition
+infixl 8 .*.    -- cartesian product
+
+-- SJ 20130118: The fatals are superfluous, but only if the type checker works correctly. For that reason, they are not being removed. Not even for performance reasons.
+l .==. r = if source l/=source r ||  target l/=target r then fatal 424 ("Cannot equate (with operator \"==\") expression l of type "++show (sign l)++"\n   "++show l++"\n   with expression r of type "++show (sign r)++"\n   "++show r++".") else
+           EEqu (l,r)
+l .|-. r = if source l/=source r ||  target l/=target r then fatal 426 ("Cannot include (with operator \"|-\") expression l of type "++show (sign l)++"\n   "++show l++"\n   with expression r of type "++show (sign r)++"\n   "++show r++".") else
+           EImp (l,r)
+l ./\. r = if source l/=source r ||  target l/=target r then fatal 428 ("Cannot intersect (with operator \"/\\\") expression l of type "++show (sign l)++"\n   "++show l++"\n   with expression r of type "++show (sign r)++"\n   "++show r++".") else
+           EIsc (l,r)
+l .\/. r = if source l/=source r ||  target l/=target r then fatal 430 ("Cannot unite (with operator \"\\/\") expression l of type "++show (sign l)++"\n   "++show l++"\n   with expression r of type "++show (sign r)++"\n   "++show r++".") else
+           EUni (l,r)
+l .-. r  = if source l/=source r ||  target l/=target r then fatal 432 ("Cannot subtract (with operator \"-\") expression l of type "++show (sign l)++"\n   "++show l++"\n   with expression r of type "++show (sign r)++"\n   "++show r++".") else
+           EDif (l,r)
+l ./. r  = if target l/=target r then fatal 434 ("Cannot residuate (with operator \"/\") expression l of type "++show (sign l)++"\n   "++show l++"\n   with expression r of type "++show (sign r)++"\n   "++show r++".") else
+           ELrs (l,r)
+l .\. r  = if source l/=source r then fatal 436 ("Cannot residuate (with operator \"\\\") expression l of type "++show (sign l)++"\n   "++show l++"\n   with expression r of type "++show (sign r)++"\n   "++show r++".") else
+           ERrs (l,r)
+l .<>. r = if source l/=target r then fatal 438 ("Cannot use diamond operator \"<>\") expression l of type "++show (sign l)++"\n   "++show l++"\n   with expression r of type "++show (sign r)++"\n   "++show r++".") else
+           EDia (l,r)
+l .:. r  = if source r/=target l then fatal 440 ("Cannot compose (with operator \";\") expression l of type "++show (sign l)++"\n   "++show l++"\n   with expression r of type "++show (sign r)++"\n   "++show r++".") else
+           ECps (l,r)
+l .!. r  = if source r/=target l then fatal 442 ("Cannot add (with operator \"!\") expression l of type "++show (sign l)++"\n   "++show l++"\n   with expression r of type "++show (sign r)++"\n   "++show r++".") else
+           ERad (l,r)
+l .*. r  = -- SJC: always fits! No fatal here..
+           EPrd (l,r)
+{- For the operators /, \, ;, ! and * we must not check whether the intermediate types exist.
+   Suppose the user says GEN Student ISA Person and GEN Employee ISA Person, then Student `join` Employee has a name (i.e. Person), but Student `meet` Employee
+   does not. In that case, -(r!s) (with target r=Student and source s=Employee) is defined, but -r;-s is not.
+   So in order to let -(r!s) be equal to -r;-s we must not check for the existence of these types, for the Rotterdam paper already shows that this is fine.
+-}
+
+instance Flippable Expression where
+  flp expr = case expr of
+               EEqu (l,r) -> EEqu (flp l, flp r)
+               EImp (l,r) -> EImp (flp l, flp r)
+               EIsc (l,r) -> EIsc (flp l, flp r)
+               EUni (l,r) -> EUni (flp l, flp r)
+               EDif (l,r) -> EDif (flp l, flp r)
+               ELrs (l,r) -> ERrs (flp r, flp l)
+               ERrs (l,r) -> ELrs (flp r, flp l)
+               EDia (l,r) -> EDia (flp r, flp l)
+               ECps (l,r) -> ECps (flp r, flp l)
+               ERad (l,r) -> ERad (flp r, flp l)
+               EPrd (l,r) -> EPrd (flp r, flp l)
+               EFlp e     -> e
+               ECpl e     -> ECpl (flp e)
+               EKl0 e     -> EKl0 (flp e)
+               EKl1 e     -> EKl1 (flp e)
+               EBrk f     -> EBrk (flp f)
+               EDcD{}     -> EFlp expr
+               EDcI{}     -> expr
+               EEps i sgn -> EEps i (flp sgn)
+               EDcV sgn   -> EDcV (flp sgn)
+               EMp1{}     -> expr
+
+instance Association Expression where
+ sign (EEqu (l,r)) = Sign (source l) (target r)
+ sign (EImp (l,r)) = Sign (source l) (target r)
+ sign (EIsc (l,r)) = Sign (source l) (target r)
+ sign (EUni (l,r)) = Sign (source l) (target r)
+ sign (EDif (l,r)) = Sign (source l) (target r)
+ sign (ELrs (l,r)) = Sign (source l) (source r)
+ sign (ERrs (l,r)) = Sign (target l) (target r)
+ sign (EDia (l,r)) = Sign (source l) (target r)
+ sign (ECps (l,r)) = Sign (source l) (target r)
+ sign (ERad (l,r)) = Sign (source l) (target r)
+ sign (EPrd (l,r)) = Sign (source l) (target r)
+ sign (EKl0 e)     = sign e
+ sign (EKl1 e)     = sign e
+ sign (EFlp e)     = flp (sign e)
+ sign (ECpl e)     = sign e
+ sign (EBrk e)     = sign e
+ sign (EDcD d)     = sign d
+ sign (EDcI c)     = Sign c c
+ sign (EEps _ sgn) = sgn
+ sign (EDcV sgn)   = sgn
+ sign (EMp1 _ c)   = Sign c c
+
+showSign :: Association a => a -> String
+showSign x = let Sign s t = sign x in "["++name s++"*"++name t++"]"
+
+-- We allow editing on basic relations (Declarations) that may have been flipped, or narrowed/widened by composing with I.
+-- Basically, we have a relation that may have several epsilons to its left and its right, and the source/target concepts
+-- we use are the concepts in the outermost epsilon, or the source/target concept of the relation, in absence of epsilons.
+-- This is used to determine the type of the atoms provided by the outside world through interfaces.
+getExpressionRelation :: Expression -> Maybe (A_Concept, Declaration, A_Concept, Bool)
+getExpressionRelation expr = case getRelation expr of
+   Just (s,Just d,t,isFlipped)  -> Just (s,d,t,isFlipped)
+   _                            -> Nothing
+ where
+    -- If the expression represents an editable relation, the relation is returned together with the narrowest possible source and target 
+    -- concepts, as well as a boolean that states whether the relation is flipped. 
+    getRelation :: Expression -> Maybe (A_Concept, Maybe Declaration, A_Concept, Bool)
+    getRelation (ECps (e, EDcI{})) = getRelation e
+    getRelation (ECps (EDcI{}, e)) = getRelation e
+    getRelation (ECps (e1, e2))
+      = case (getRelation e1, getRelation e2) of --note: target e1==source e2
+         (Just (_,Nothing,i1,_), Just (i2,Nothing,_,_)) -> if i1==target e1 && i2==source e2 then Just (i1, Nothing, i2, False) else -- i1==i2
+                                                           if i1==target e1 && i2/=source e2 then Just (i2, Nothing, i2, False) else
+                                                           if i1/=target e1 && i2==source e2 then Just (i1, Nothing, i1, False) else
+                                                           Nothing
+         (Just (_,Nothing,i,_), Just (s,d,t,isFlipped)) -> if i==target e1                 then Just (s,d,t,isFlipped) else                       
+                                                           if i/=target e1 && s==target e1 then Just (i,d,t,isFlipped) else                       
+                                                           Nothing                                                     
+         (Just (s,d,t,isFlipped), Just (i,Nothing,_,_)) -> if i==source e2                 then Just (s,d,t,isFlipped) else
+                                                           if i/=source e2 && t==source e2 then Just (s,d,i,isFlipped) else        
+                                                           Nothing                                                                 
+         _                                              -> Nothing
+    getRelation (EFlp e)
+     = case getRelation e of
+         Just (s,d,t,isFlipped) -> Just (t,d,s,not isFlipped)
+         Nothing                -> Nothing
+    getRelation (EDcD d)   = Just (source d, Just d, target d, False)
+    getRelation (EEps i _) = Just (i, Nothing, i, False)
+    getRelation _ = Nothing
+
+
+-- The following definition of concept is used in the type checker only.
+-- It is called Concept, meaning "type checking concept"
+
+data A_Concept
+   = PlainConcept { cptnm :: String  -- ^PlainConcept nm represents the set of instances cs by name nm.
+                  }
+   | ONE  -- ^The universal Singleton: 'I'['Anything'] = 'V'['Anything'*'Anything']
+    deriving (Prelude.Ord,Typeable)
+
+instance Eq A_Concept where
+   PlainConcept{cptnm=a} == PlainConcept{cptnm=b} = a==b
+   ONE == ONE = True
+   _ == _ = False
+instance Unique A_Concept where
+  showUnique = name
+instance Hashable A_Concept where
+  hashWithSalt s cpt =
+     s `hashWithSalt` (case cpt of
+                        PlainConcept{} -> (0::Int) `hashWithSalt` name cpt
+                        ONE            -> (1::Int)
+                      ) 
+instance Named A_Concept where
+  name PlainConcept{cptnm = nm} = nm
+  name ONE = "ONE"
+
+instance Show A_Concept where
+  showsPrec _ c = showString (name c)
+
+data Sign = Sign A_Concept A_Concept deriving (Eq, Prelude.Ord, Typeable, Generic)
+instance Hashable Sign
+instance Show Sign where
+  showsPrec _ (Sign s t) =
+     showString (   "[" ++ show s ++ "*" ++ show t ++ "]" )
+instance Unique Sign where
+  showUnique (Sign s t) = "[" ++ uniqueShow False s ++ "*" ++ uniqueShow False t ++ "]"
+instance Association Sign where
+  source (Sign s _) = s
+  target (Sign _ t) = t
+  sign sgn = sgn
+
+instance Flippable Sign where
+ flp (Sign s t) = Sign t s
+
+class Association rel where
+  source, target :: rel -> A_Concept      -- e.g. Declaration -> Concept
+  source x        = source (sign x)
+  target x        = target (sign x)
+  sign :: rel -> Sign
+  isEndo :: rel  -> Bool
+  isEndo s        = source s == target s
+
+{-
+  --  a <= b means that concept a is more specific than b and b is more generic than a. For instance 'Elephant' <= 'Animal'
+  --  The generalization relation <= between concepts is a partial order.
+  --  Partiality reflects the fact that not every pair of concepts of a specification need be related.
+  --  Although meets, joins and sorting of all concepts may be meaningless, within classes of comparable concepts it is meaningfull.
+  --  See Core.Poset to see how these functions are defined for the meaningfull cases only.
+  --  Core.Poset is based and partly copied from http://hackage.haskell.org/package/altfloat-0.3.1 intended to sort floats and more
+  --  A partial order is by definition reflexive, antisymmetric, and transitive
+  --  For every concept a and b in Ampersand, the following rule holds: a<b || b<a || a==b || a <==> b || a<\=> b
+  --  Every concept drags around the same partial order represented by
+  --   + a compare function (A_Concept->A_Concept->Ordering)
+  --   + and a list of comparable classes [[A_Concept]]
+-}
+type GenR = ( A_Concept -> A_Concept -> Ordering      --  gE: the ordering relation, which yields EQ, LT, GT, CP, or NC
+            , [[A_Concept]]                           --  join classes. Each class corresponds to a (scalar, binary or wide) entity later on in the database generator.
+            , [(A_Concept,A_Concept)]                 --  the smallest set of pairs that produces the ordering relation gE
+            , A_Concept -> A_Concept -> [A_Concept]   --  c `elem` (a `meets` b) means that c<=q and c<=b
+            , A_Concept -> A_Concept -> [A_Concept]   --  c `elem` (a `joins` b) means that c>=q and c>=b
+            )
+
+{- not used, but may be handy for debugging
+showOrder :: A_Concept -> String
+showOrder x = "\nComparability classes:"++ind++intercalate ind (map show classes)
+ where (_,classes,_,_,_) = cptgE x; ind = "\n   "
+-}
+
+  

+ src/Database/Design/Ampersand/Core/ParseTree.hs view
@@ -0,0 +1,687 @@+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE DeriveGeneric #-}
+module Database.Design.Ampersand.Core.ParseTree (
+     P_Context(..), mergeContexts
+   , Meta(..)
+   , MetaObj(..)
+   , P_RoleRelation(..)
+   , P_RoleRule(..)
+   , Role(..)
+   , P_Pattern(..)
+   , P_Declaration(..)
+   , Term(..), TermPrim(..), P_NamedRel(..)
+   , PairView(..), PairViewSegment(..), PairViewTerm(..), PairViewSegmentTerm(..)
+   , SrcOrTgt(..), isSrc
+   , P_Rule(..)
+   , ConceptDef(..)
+   , P_Population(..)
+
+   , P_ObjectDef, P_SubInterface, P_Interface(..), P_IClass(..), P_ObjDef(..), P_SubIfc(..)
+
+   , P_IdentDef, P_IdentDf(..) , P_IdentSegment, P_IdentSegmnt(..)
+   , P_ViewDef , P_ViewSegment, ViewHtmlTemplate(..) {-, ViewTextTemplate-}
+   , P_ViewD(..) , P_ViewSegmt(..)
+
+   , PPurpose(..),PRef2Obj(..),PMeaning(..),PMessage(..)
+
+   , P_Concept(..), P_Sign(..)
+
+   , P_Gen(..)
+
+   , Lang(..)
+   , P_Markup(..)
+
+   , PandocFormat(..)
+
+   , Label(..)
+
+   , Prop(..), Props
+   -- Inherited stuff:
+   , module Database.Design.Ampersand.Input.ADL1.FilePos
+   , module Database.Design.Ampersand.ADL1.Pair
+   , gen_concs
+  ) where
+import Database.Design.Ampersand.Input.ADL1.FilePos
+import Database.Design.Ampersand.Basics
+import Database.Design.Ampersand.ADL1.Pair (Pairs,Paire,mkPair ,srcPaire, trgPaire)
+import Data.Traversable
+import Data.Foldable (Foldable(foldMap))
+import Prelude hiding (foldr, sequence)
+import Control.Applicative
+import Data.Typeable
+import GHC.Generics (Generic)
+import Data.Hashable
+
+fatal :: Int -> String -> a
+fatal = fatalMsg "Core.ParseTree"
+
+data P_Context
+   = PCtx{ ctx_nm ::     String           -- ^ The name of this context
+         , ctx_pos ::    [Origin]         -- ^ The origin of the context. A context can be a merge of a file including other files c.q. a list of Origin.
+         , ctx_lang ::   Lang             -- ^ The default language specified on the top-level context
+         , ctx_markup :: Maybe PandocFormat  -- ^ The default markup format for free text in this context
+         , ctx_thms ::   [String]         -- ^ Names of patterns/processes to be printed in the functional specification. (For partial documents.)
+         , ctx_pats ::   [P_Pattern]      -- ^ The patterns defined in this context
+         , ctx_PPrcs ::  [P_Pattern]      -- ^ The processes as defined by the parser
+         , ctx_rs ::     [P_Rule TermPrim]         -- ^ All user defined rules in this context, but outside patterns and outside processes
+         , ctx_ds ::     [P_Declaration]  -- ^ The relations defined in this context, outside the scope of patterns
+         , ctx_cs ::     [ConceptDef]     -- ^ The concept definitions defined in this context, outside the scope of patterns
+         , ctx_ks ::     [P_IdentDef]     -- ^ The identity definitions defined in this context, outside the scope of patterns
+         , ctx_rrules :: [P_RoleRule]     -- ^ The MAINTAIN definitions defined in this context, outside the scope of patterns
+         , ctx_rrels ::  [P_RoleRelation] -- ^ The assignment of roles to Relations. (EDITS statements)
+         , ctx_vs ::     [P_ViewDef]      -- ^ The view definitions defined in this context, outside the scope of patterns
+         , ctx_gs ::     [P_Gen]          -- ^ The gen definitions defined in this context, outside the scope of patterns
+         , 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
+         , ctx_sql ::    [P_ObjectDef]    -- ^ user defined sqlplugs, taken from the Ampersand script
+         , ctx_php ::    [P_ObjectDef]    -- ^ user defined phpplugs, taken from the Ampersand script
+         , ctx_metas ::  [Meta]         -- ^ generic meta information (name/value pairs) that can be used for experimenting without having to modify the adl syntax
+         } deriving Show
+
+instance Eq P_Context where
+  c1 == c2  =  name c1 == name c2
+
+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 { mtPos :: Origin
+              , mtObj :: MetaObj
+              , mtName :: String
+              , mtVal :: String
+              } deriving (Show)
+data MetaObj = ContextMeta deriving Show -- for now, we just have meta data for the entire context
+
+-- | A RoleRelation rs means that any role in 'rrRoles rs' may edit any Relation  in  'rrInterfaces rs'
+data P_RoleRelation
+   = P_RR { rr_Roles :: [Role]      -- ^ list of roles
+          , rr_Rels :: [P_NamedRel] -- ^ list of named relations
+          , rr_Pos :: Origin      -- ^ position in the Ampersand script
+          } deriving (Show)       -- deriving Show is just for debugging
+instance Eq P_RoleRelation where rr==rr' = origin rr==origin rr'
+instance Traced P_RoleRelation where
+ origin = rr_Pos
+
+ -- | A RoleRule r means that a role called 'mRoles r' must maintain the process rule called 'mRules r'
+data P_RoleRule
+   = Maintain
+     { mRoles :: [Role]    -- ^ name of a role
+     , mRules :: [String]    -- ^ name of a Rule
+     , mPos :: Origin      -- ^ position in the Ampersand script
+     } deriving (Eq, Show)   -- deriving (Eq, Show) is just for debugging
+
+data Role = Role String deriving (Eq, Show, Typeable )   -- deriving (Eq, Show) is just for debugging
+instance Named Role where
+ name (Role nm) = nm
+instance Unique Role where
+ showUnique = name
+instance Traced P_RoleRule where
+ origin = mPos
+
+data P_Pattern
+   = P_Pat { pt_nm :: String            -- ^ Name of this pattern
+           , pt_pos :: Origin           -- ^ the starting position in the file in which this pattern was declared.
+           , pt_end :: Origin           -- ^ the end position in the file in which this pattern was declared.
+           , pt_rls :: [P_Rule TermPrim]         -- ^ The user defined rules in this pattern
+           , pt_gns :: [P_Gen]          -- ^ The generalizations defined in this pattern
+           , pt_dcs :: [P_Declaration]  -- ^ The relations that are declared in this pattern
+           , pt_RRuls :: [P_RoleRule]   -- ^ The assignment of roles to rules.
+           , pt_RRels :: [P_RoleRelation] -- ^ The assignment of roles to Relations.
+           , pt_cds :: [ConceptDef]     -- ^ The concept definitions defined in this pattern
+           , pt_ids :: [P_IdentDef]     -- ^ The identity definitions defined in this pattern
+           , pt_vds :: [P_ViewDef]      -- ^ The view definitions defined in this pattern
+           , pt_xps :: [PPurpose]       -- ^ The purposes of elements defined in this pattern
+           , pt_pop :: [P_Population]   -- ^ The populations that are local to this pattern
+           }   deriving (Show)       -- for debugging purposes
+
+instance Named P_Pattern where
+ name = pt_nm
+
+instance Traced P_Pattern where
+ origin = pt_pos
+
+data ConceptDef
+   = Cd  { cdpos :: Origin   -- ^ The position of this definition in the text of the Ampersand source (filename, line number and column number).
+         , cdcpt :: String   -- ^ The name of the concept for which this is the definition. If there is no such concept, the conceptdefinition is ignored.
+         , cdplug:: Bool     -- ^ Whether the user specifically told Ampersand not to store this concept in the database
+         , cddef :: String   -- ^ The textual definition of this concept.
+         , cdtyp :: String   -- ^ The (SQL) type of this concept.
+         , cdref :: String   -- ^ A label meant to identify the source of the definition. (useful as LaTeX' symbolic reference)
+         , cdfrom:: String   -- ^ The name of the pattern or context in which this concept definition was made
+         }   deriving (Show,Eq,Typeable)
+
+instance Unique ConceptDef where
+  showUnique cd = cdcpt cd++"At"++uniqueShow True (cdpos cd)
+instance Traced ConceptDef where
+ origin = cdpos
+instance Named ConceptDef where
+ name = cdcpt
+
+data P_Declaration =
+      P_Sgn { dec_nm :: String    -- ^ the name of the declaration
+            , dec_sign :: P_Sign    -- ^ the type. Parser must guarantee it is not empty.
+            , dec_prps :: Props     -- ^ the user defined multiplicity properties (Uni, Tot, Sur, Inj) and algebraic properties (Sym, Asy, Trn, Rfx)
+            , dec_prL :: String    -- ^ three strings, which form the pragma. E.g. if pragma consists of the three strings: "Person ", " is married to person ", and " in Vegas."
+            , dec_prM :: String    -- ^    then a tuple ("Peter","Jane") in the list of links means that Person Peter is married to person Jane in Vegas.
+            , dec_prR :: String
+            , dec_Mean :: [PMeaning]  -- ^ the optional meaning of a declaration, possibly more than one for different languages.
+            , dec_popu :: Pairs     -- ^ the list of tuples, of which the relation consists.
+            , dec_fpos :: Origin    -- ^ the position in the Ampersand source file where this declaration is declared. Not all decalartions come from the ampersand souce file.
+            , dec_plug :: Bool      -- ^ if true, this relation may not be stored in or retrieved from the standard database (it should be gotten from a Plug of some sort instead)
+            } deriving Show -- for debugging and testing only
+instance Eq P_Declaration where
+ decl==decl' = origin decl==origin decl'
+instance Prelude.Ord P_Declaration where
+ decl `compare` decl' = origin decl `compare` origin decl'
+instance Named P_Declaration where
+ name = dec_nm
+instance Traced P_Declaration where
+ origin = dec_fpos
+
+data TermPrim
+   = PI Origin                              -- ^ identity element without a type
+                                            --   At parse time, there may be zero or one element in the list of concepts.
+                                            --   Reason: when making eqClasses, the least element of that class is used as a witness of that class
+                                            --   to know whether an eqClass represents a concept, we only look at its witness
+                                            --   By making Pid the first in the data decleration, it becomes the least element for "deriving Ord".
+   | Pid Origin P_Concept                   -- ^ identity element restricted to a type
+   | Patm Origin String (Maybe P_Concept)   -- ^ an atom, possibly with a type
+   | PVee Origin                            -- ^ the complete relation, of which the type is yet to be derived by the type checker.
+   | Pfull Origin P_Concept P_Concept       -- ^ the complete relation, restricted to a type.
+                                            --   At parse time, there may be zero, one or two elements in the list of concepts.
+   | PNamedR P_NamedRel
+   deriving Show
+
+data P_NamedRel = PNamedRel Origin String (Maybe P_Sign)
+   deriving Show
+
+{- For whenever it may turn out to be useful
+instance Eq TermPrim where
+  PI _           == PI _            = True
+  Pid _ (Just c) == Pid _ (Just c') = p_cptnm c==p_cptnm c'
+  Pid _ Nothing  == Pid _ Nothing   = True
+  Patm _ x c     == Patm _ x' c'    = x==x' && p_cptnm c==p_cptnm c'
+  PVee _         == PVee _          = True
+  Pfull _ c d    == Pfull _ c' d'   = p_cptnm c==p_cptnm c' && d==d'
+  Prel _ x       == Prel _ x'       = x==x'
+  PTrel _ x s    == PTrel _ x' s'   = x==x' && pSrc s==pSrc s' && pTgt s==pTgt s'
+  _ == _ = False
+-}
+
+data Term a
+   = Prim a
+   | PEqu Origin (Term a) (Term a)  -- ^ equivalence             =
+   | PImp Origin (Term a) (Term a)  -- ^ implication             |-
+   | PIsc Origin (Term a) (Term a)  -- ^ intersection            /\
+   | PUni Origin (Term a) (Term a)  -- ^ union                   \/
+   | PDif Origin (Term a) (Term a)  -- ^ difference              -
+   | PLrs Origin (Term a) (Term a)  -- ^ left residual           /
+   | PRrs Origin (Term a) (Term a)  -- ^ right residual          \
+   | PDia Origin (Term a) (Term a)  -- ^ diamond                 <>
+   | PCps Origin (Term a) (Term a)  -- ^ composition             ;
+   | PRad Origin (Term a) (Term a)  -- ^ relative addition       !
+   | PPrd Origin (Term a) (Term a)  -- ^ cartesian product       *
+   | PKl0 Origin (Term a)           -- ^ Rfx.Trn closure         *  (Kleene star)
+   | PKl1 Origin (Term a)           -- ^ Transitive closure      +  (Kleene plus)
+   | PFlp Origin (Term a)           -- ^ conversion (flip, wok)  ~
+   | PCpl Origin (Term a)           -- ^ Complement
+   | PBrk Origin (Term a)           -- ^ bracketed expression ( ... )
+   deriving (Show) -- deriving Show for debugging purposes
+instance Functor Term where fmap = fmapDefault
+instance Foldable Term where foldMap = foldMapDefault
+instance Traversable Term where
+ traverse f' x
+  = case x of
+    Prim a -> Prim <$> f' a
+    PEqu o a b -> PEqu o <$> (f a) <*> (f b)
+    PImp o a b -> PImp o <$> (f a) <*> (f b)
+    PIsc o a b -> PIsc o <$> (f a) <*> (f b)
+    PUni o a b -> PUni o <$> (f a) <*> (f b)
+    PDif o a b -> PDif o <$> (f a) <*> (f b)
+    PLrs o a b -> PLrs o <$> (f a) <*> (f b)
+    PRrs o a b -> PRrs o <$> (f a) <*> (f b)
+    PDia o a b -> PDia o <$> (f a) <*> (f b)
+    PCps o a b -> PCps o <$> (f a) <*> (f b)
+    PRad o a b -> PRad o <$> (f a) <*> (f b)
+    PPrd o a b -> PPrd o <$> (f a) <*> (f b)
+    PKl0 o a   -> PKl0 o <$> (f a)
+    PKl1 o a   -> PKl1 o <$> (f a)
+    PFlp o a   -> PFlp o <$> (f a)
+    PCpl o a   -> PCpl o <$> (f a)
+    PBrk o a   -> PBrk o <$> (f a)
+  where f = traverse f'
+
+instance Functor P_SubIfc where fmap = fmapDefault
+instance Foldable P_SubIfc where foldMap = foldMapDefault
+instance Traversable P_SubIfc where
+  traverse _ (P_InterfaceRef a b) = pure (P_InterfaceRef a b)
+  traverse f (P_Box o c lst) = P_Box o c <$> (traverse (traverse f) lst)
+
+instance Traced (P_SubIfc a) where
+ origin = si_ori
+
+instance Functor P_ObjDef where fmap = fmapDefault
+instance Foldable P_ObjDef where foldMap = foldMapDefault
+instance Traversable P_ObjDef where
+ traverse f (P_Obj nm pos ctx mView msub strs)
+  = (\ctx' msub'->(P_Obj nm pos ctx' mView msub' strs)) <$>
+     traverse f ctx <*> traverse (traverse f) msub
+
+instance Traced TermPrim where
+ origin e = case e of
+   PI orig        -> orig
+   Pid orig _     -> orig
+   Patm orig _ _  -> orig
+   PVee orig      -> orig
+   Pfull orig _ _ -> orig
+   PNamedR r      -> origin r
+   
+instance Named TermPrim where
+ name e = case e of
+   PI _        -> "I"
+   Pid _ _     -> "I"
+   Patm _ s _  -> s
+   PVee _      -> "V"
+   Pfull _ _ _ -> "V"
+   PNamedR r   -> name r
+   
+instance Traced P_NamedRel where
+  origin (PNamedRel o _ _) = o
+
+instance Named P_NamedRel where
+  name (PNamedRel _ nm _) = nm
+
+instance Traced a => Traced (Term a) where
+ origin e = case e of
+   Prim a         -> origin a
+   PEqu orig _ _  -> orig
+   PImp orig _ _  -> orig
+   PIsc orig _ _  -> orig
+   PUni orig _ _  -> orig
+   PDif orig _ _  -> orig
+   PLrs orig _ _  -> orig
+   PRrs orig _ _  -> orig
+   PDia orig _ _  -> orig
+   PCps orig _ _  -> orig
+   PRad orig _ _  -> orig
+   PPrd orig _ _  -> orig
+   PKl0 orig _    -> orig
+   PKl1 orig _    -> orig
+   PFlp orig _    -> orig
+   PCpl orig _    -> orig
+   PBrk orig _    -> orig
+
+data SrcOrTgt = Src | Tgt deriving (Show, Eq, Ord, Generic)
+instance Hashable SrcOrTgt
+instance Flippable SrcOrTgt where
+  flp Src = Tgt
+  flp Tgt = Src
+
+isSrc :: SrcOrTgt -> Bool
+isSrc Src = True
+isSrc Tgt = False
+
+data PairView a = PairView { ppv_segs :: [PairViewSegment a] } deriving (Show, Typeable, Eq, Generic)
+instance Hashable a => Hashable (PairView a)
+instance Traced a => Traced (PairView a) where
+  origin pv = 
+    case ppv_segs pv of
+       [] -> fatal 342 "An empty PairView must not occur"
+       xs -> origin (head xs)   
+data PairViewSegment a = 
+    PairViewText{ pvsOrg :: Origin
+                , pvsStr :: String
+                }
+  | PairViewExp { pvsOrg :: Origin
+                , pvsSoT :: SrcOrTgt
+                , pvsExp :: a
+                } deriving (Show, Typeable, Eq, Generic)
+instance Hashable a => Hashable (PairViewSegment a)
+instance Traced (PairViewSegment a) where
+  origin = pvsOrg
+
+-- | the newtype to make it possible for a PairView to be disambiguatable: it must be of the form "d a" instead of "d (Term a)"
+newtype PairViewTerm a = PairViewTerm (PairView (Term a))
+newtype PairViewSegmentTerm a = PairViewSegmentTerm (PairViewSegment (Term a))
+
+instance Traversable PairViewSegmentTerm where
+  traverse f (PairViewSegmentTerm x) = PairViewSegmentTerm <$> traverse (traverse f) x
+instance Functor PairViewSegmentTerm where fmap = fmapDefault
+instance Foldable PairViewSegmentTerm where foldMap = foldMapDefault
+instance Traversable PairViewTerm where
+  traverse f (PairViewTerm x) = PairViewTerm <$> traverse (traverse f) x
+instance Functor PairViewTerm where fmap = fmapDefault
+instance Foldable PairViewTerm where foldMap = foldMapDefault
+instance Traversable PairViewSegment where
+  traverse _ (PairViewText ori s) = pure (PairViewText ori s)
+  traverse f (PairViewExp ori st x) = PairViewExp ori st <$> f x
+instance Functor PairViewSegment where fmap = fmapDefault
+instance Foldable PairViewSegment where foldMap = foldMapDefault
+instance Traversable PairView where
+  traverse f (PairView s) = PairView <$> traverse (traverse f) s
+instance Functor PairView where fmap = fmapDefault
+instance Foldable PairView where foldMap = foldMapDefault
+
+data P_Rule a  =
+   P_Ru { rr_nm ::   String            -- ^ Name of this rule
+        , rr_exp ::  (Term a)   -- ^ The rule expression
+        , rr_fps ::  Origin            -- ^ Position in the Ampersand file
+        , rr_mean :: [PMeaning]        -- ^ User-specified meanings, possibly more than one, for multiple languages.
+        , rr_msg ::  [PMessage]        -- ^ User-specified violation messages, possibly more than one, for multiple languages.
+        , rr_viol :: Maybe (PairView (Term a))  -- ^ Custom presentation for violations, currently only in a single language
+        } deriving Show
+
+instance Traced (P_Rule a) where
+ origin = rr_fps
+instance Functor P_Rule where fmap = fmapDefault
+instance Foldable P_Rule where foldMap = foldMapDefault
+instance Traversable P_Rule where
+ traverse f (P_Ru nm expr fps mean msg viol)
+  = (\e v -> P_Ru nm e fps mean msg v) <$> traverse f expr <*> traverse (traverse (traverse f)) viol
+
+instance Named (P_Rule a) where
+ name = rr_nm
+
+newtype PMeaning = PMeaning P_Markup
+         deriving Show
+newtype PMessage = PMessage P_Markup
+         deriving Show
+data P_Markup =
+    P_Markup  { mLang ::   Maybe Lang
+              , mFormat :: Maybe PandocFormat
+              , mString :: String
+              } deriving Show -- for debugging only
+
+data P_Population
+  = P_RelPopu { p_rnme ::  String  -- the name of a relation
+              , p_orig ::  Origin  -- the origin
+              , p_popps :: Pairs   -- the contents
+              }
+  | P_TRelPop { p_rnme ::  String  -- the name of a relation
+              , p_type ::  P_Sign  -- the signature of the relation
+              , p_orig ::  Origin  -- the origin
+              , p_popps :: Pairs   -- the contents
+              }
+  | P_CptPopu { p_cnme ::  String  -- the name of a concept
+              , p_orig ::  Origin  -- the origin
+              , p_popas :: [String]   -- atoms in the initial population of that concept
+              }
+    deriving Show
+
+instance Named P_Population where
+ name P_RelPopu{p_rnme = nm} = nm
+ name P_TRelPop{p_rnme = nm} = nm
+ name P_CptPopu{p_cnme = nm} = nm
+
+instance Traced P_Population where
+ origin = p_orig
+
+data P_Interface =
+     P_Ifc { ifc_Name :: String           -- ^ the name of the interface
+           , ifc_Class :: Maybe String    -- ^ the class of the interface
+           , ifc_Params :: [P_NamedRel]     -- ^ a list of named relations that are editable within this interface.
+           , ifc_Args :: [[String]]       -- ^ a list of arguments for code generation.
+           , ifc_Roles :: [Role]        -- ^ a list of roles that may use this interface
+           , ifc_Obj :: P_ObjectDef       -- ^ the context expression (mostly: I[c])
+           , ifc_Pos :: Origin
+           , ifc_Prp :: String
+           } deriving Show
+
+instance Named P_Interface where
+ name = ifc_Name
+
+instance Traced P_Interface where
+ origin = ifc_Pos
+
+data P_IClass = P_IClass { iclass_name :: String } deriving (Eq, Show)
+
+type P_SubInterface = P_SubIfc TermPrim
+data P_SubIfc a
+              = P_Box          { si_ori :: Origin
+                               , si_class :: Maybe String
+                               , si_box :: [P_ObjDef a] }
+              | P_InterfaceRef { si_ori :: Origin
+                               , si_str :: String }
+                deriving (Eq, Show)
+
+type P_ObjectDef = P_ObjDef TermPrim
+data P_ObjDef a =
+     P_Obj { obj_nm :: String          -- ^ 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.
+           , obj_pos :: Origin         -- ^ position of this definition in the text of the Ampersand source file (filename, line number and column number)
+           , obj_ctx :: Term a         -- ^ this expression describes the instances of this object, related to their context.
+           , obj_mView :: Maybe String -- ^ The view that should be used for this object
+           , obj_msub :: Maybe (P_SubIfc a)  -- ^ the attributes, which are object definitions themselves.
+           , obj_strs :: [[String]]    -- ^ directives that specify the interface.
+           }  deriving (Show)       -- just for debugging (zie ook instance Show ObjectDef)
+instance Eq (P_ObjDef a) where od==od' = origin od==origin od'
+instance Named (P_ObjDef a) where
+ name = obj_nm
+instance Traced (P_ObjDef a) where
+ origin = obj_pos
+
+type P_IdentDef = P_IdentDf TermPrim -- this is what is returned by the parser, but we need to change the "TermPrim" for disambiguation
+data P_IdentDf a = -- so this is the parametric data-structure
+         P_Id { ix_pos :: Origin         -- ^ position of this definition in the text of the Ampersand source file (filename, line number and column number).
+              , ix_lbl :: String         -- ^ 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.
+              , ix_cpt :: P_Concept      -- ^ this expression describes the instances of this object, related to their context
+              , ix_ats :: [P_IdentSegmnt a] -- ^ the constituent segments of this identity. TODO: refactor to a list of terms
+              } deriving (Show)
+instance Named (P_IdentDf a) where
+ name = ix_lbl
+instance Eq (P_IdentDf a) where identity==identity' = origin identity==origin identity'
+instance Traced (P_IdentDf a) where
+ origin = ix_pos
+instance Functor P_IdentDf where fmap = fmapDefault
+instance Foldable P_IdentDf where foldMap = foldMapDefault
+instance Traversable P_IdentDf where
+  traverse f (P_Id a b c lst) = P_Id a b c <$> traverse (traverse f) lst
+instance Functor P_IdentSegmnt where fmap = fmapDefault
+instance Foldable P_IdentSegmnt where foldMap = foldMapDefault
+instance Traversable P_IdentSegmnt where
+  traverse f (P_IdentExp x) = P_IdentExp <$> traverse f x
+
+type P_IdentSegment = P_IdentSegmnt TermPrim
+data P_IdentSegmnt a
+              = P_IdentExp  { ks_obj :: P_ObjDef a}
+                deriving (Eq, Show)
+                
+type P_ViewDef = P_ViewD TermPrim
+data P_ViewD a =
+         P_Vd { vd_pos :: Origin            -- ^ position of this definition in the text of the Ampersand source file (filename, line number and column number).
+              , vd_lbl :: String            -- ^ the name (or label) of this View. The label has no meaning in the Compliant Service Layer, but is used in the generated user interface. It is not an empty string.
+              , vd_cpt :: P_Concept         -- ^ the concept for which this view is applicable
+              , vd_isDefault :: Bool        -- ^ whether or not this is the default view for the concept 
+              , vd_html :: Maybe ViewHtmlTemplate -- ^ the html template for this view (not required since we may have other kinds of views as well in the future)
+--              , vd_text :: Maybe P_ViewText -- Future extension
+              , vd_ats :: [P_ViewSegmt a]   -- ^ the constituent segments of this view.
+              } deriving (Show)
+              
+instance Named (P_ViewD a) where
+ name = vd_lbl
+instance Functor P_ViewD where fmap = fmapDefault
+instance Foldable P_ViewD where foldMap = foldMapDefault
+instance Traversable P_ViewD where
+ traverse fn (P_Vd a b c d e f) = P_Vd a b c d e <$> traverse (traverse fn) f
+
+type P_ViewSegment = P_ViewSegmt TermPrim
+data P_ViewSegmt a  = P_ViewExp  { vs_obj :: P_ObjDef a }
+                    | P_ViewText { vs_txt :: String }
+                    | P_ViewHtml { vs_htm :: String }
+                      deriving (Eq, Show)
+
+data ViewHtmlTemplate = ViewHtmlTemplateFile String
+--              | ViewHtmlTemplateInline String -- Future extension 
+                  deriving (Eq, Show)
+
+{- Future extension:
+data ViewText = ViewTextTemplateFile String
+              | ViewTextTemplateInline String 
+                  deriving (Eq, Show)
+-}
+
+instance Functor P_ViewSegmt where fmap = fmapDefault
+instance Foldable P_ViewSegmt where foldMap = foldMapDefault
+instance Traversable P_ViewSegmt where
+ traverse f (P_ViewExp  a) = P_ViewExp <$> traverse f a
+ traverse _ (P_ViewText a) = pure (P_ViewText a)
+ traverse _ (P_ViewHtml a) = pure (P_ViewHtml a)
+
+instance Traced (P_ViewD a) where
+ origin = vd_pos
+
+
+-- PPurpose is a parse-time constructor. It contains the name of the object it explains.
+-- It is a pre-explanation in the sense that it contains a reference to something that is not yet built by the compiler.
+--                       Constructor      name          RefID  Explanation
+data PRef2Obj = PRef2ConceptDef String
+              | PRef2Declaration P_NamedRel
+              | PRef2Rule String
+              | PRef2IdentityDef String
+              | PRef2ViewDef String
+              | PRef2Pattern String
+              | PRef2Interface String
+              | PRef2Context String
+              | PRef2Fspc String
+              deriving Show -- only for fatal error messages
+
+instance Named PRef2Obj where
+  name pe = case pe of
+     PRef2ConceptDef str -> str
+     PRef2Declaration (PNamedRel _ nm mSgn) -> nm++maybe "" show mSgn
+     PRef2Rule str -> str
+     PRef2IdentityDef str -> str
+     PRef2ViewDef str -> str
+     PRef2Pattern str -> str
+     PRef2Interface str -> str
+     PRef2Context str -> str
+     PRef2Fspc str -> str
+
+data PPurpose = PRef2 { pexPos :: Origin      -- the position in the Ampersand script of this purpose definition
+                      , pexObj :: PRef2Obj    -- the reference to the object whose purpose is explained
+                      , pexMarkup:: P_Markup  -- the piece of text, including markup and language info
+                      , pexRefIDs :: [String] -- the references (for traceability)
+                      } deriving Show
+
+instance Named PPurpose where
+ name pe = name (pexObj pe)
+
+instance Traced PPurpose where
+ origin = pexPos
+
+data P_Concept
+   = PCpt{ p_cptnm :: String }  -- ^The name of this Concept
+   | P_Singleton
+--      deriving (Eq, Ord)
+-- (Sebastiaan 12 feb 2012) P_Concept has been defined Ord, only because we want to maintain sets of concepts in the type checker for quicker lookups.
+-- (Sebastiaan 11 okt 2013) Removed this again, I thought it would be more clean to use newtype for this instead
+
+instance Named P_Concept where
+ name (PCpt {p_cptnm = nm}) = nm
+ name P_Singleton = "ONE"
+
+instance Show P_Concept where
+ showsPrec _ c = showString (name c)
+
+data P_Sign = P_Sign {pSrc :: P_Concept, pTgt :: P_Concept }
+
+instance Show P_Sign where
+  showsPrec _ sgn =
+      showString (   "[" ++ show (pSrc sgn)++"*"++show (pTgt sgn) ++ "]" )
+
+data P_Gen =  P_Cy{ gen_spc :: P_Concept         -- ^ Left hand side concept expression
+                  , gen_rhs :: [P_Concept]       -- ^ Right hand side concept expression
+                  , gen_fp ::  Origin            -- ^ Position in the Ampersand file
+                  }
+            | PGen{ gen_spc :: P_Concept      -- ^ specific concept
+                  , gen_gen :: P_Concept      -- ^ generic concept
+                  , gen_fp  :: Origin         -- ^ the position of the GEN-rule
+                  }
+gen_concs :: P_Gen -> [P_Concept]
+gen_concs (P_Cy {gen_rhs=x}) = x
+gen_concs (PGen {gen_gen=x,gen_spc=y}) = [x,y]
+
+instance Show P_Gen where
+ -- This show is used in error messages.
+ showsPrec _ g = showString ("CLASSIFY "++show (gen_spc g)++" IS "++show (gen_concs g))
+
+instance Traced P_Gen where
+ origin = gen_fp
+
+data Lang = Dutch | English deriving (Show, Eq, Ord)
+
+data PandocFormat = HTML | ReST | LaTeX | Markdown deriving (Eq, Show, Ord)
+
+type Props = [Prop]
+
+data Prop      = Uni          -- ^ univalent
+               | Inj          -- ^ injective
+               | Sur          -- ^ surjective
+               | Tot          -- ^ total
+               | Sym          -- ^ symmetric
+               | Asy          -- ^ antisymmetric
+               | Trn          -- ^ transitive
+               | Rfx          -- ^ reflexive
+               | Irf          -- ^ irreflexive
+               | Aut          -- ^ automatically computed (NOTE: this is a hacky way to denote these until we have appropriate syntax)
+                 deriving (Eq,Ord)
+instance Show Prop where
+ showsPrec _ Uni = showString "UNI"
+ showsPrec _ Inj = showString "INJ"
+ showsPrec _ Sur = showString "SUR"
+ showsPrec _ Tot = showString "TOT"
+ showsPrec _ Sym = showString "SYM"
+ showsPrec _ Asy = showString "ASY"
+ showsPrec _ Trn = showString "TRN"
+ showsPrec _ Rfx = showString "RFX"
+ showsPrec _ Irf = showString "IRF"
+ showsPrec _ Aut = showString "AUT"
+
+instance Flippable Prop where
+ flp Uni = Inj
+ flp Tot = Sur
+ flp Sur = Tot
+ flp Inj = Uni
+ flp x = x
+
+data Label = Lbl { lblnm :: String
+                 , lblpos :: Origin
+                 , lblstrs :: [[String]]
+                 } deriving Show
+instance Eq Label where
+ l==l' = lblnm l==lblnm l'
+
+mergeContexts :: P_Context -> P_Context -> P_Context
+mergeContexts ctx1 ctx2 =
+  PCtx{ ctx_nm     = case (filter (not.null) . map ctx_nm) contexts of
+                        []    -> ""
+                        (x:_) -> x
+      , ctx_pos    = concatMap ctx_pos contexts
+      , ctx_lang   = ctx_lang ctx1 -- By taking the first, we end up with the language of the top-level context
+      , ctx_markup = foldl orElse Nothing $ map ctx_markup contexts
+      , ctx_thms   = concatMap ctx_thms contexts
+      , ctx_pats   = concatMap ctx_pats contexts
+      , ctx_PPrcs  = concatMap ctx_PPrcs contexts
+      , ctx_rs     = concatMap ctx_rs contexts
+      , ctx_ds     = concatMap ctx_ds contexts
+      , ctx_cs     = concatMap ctx_cs contexts
+      , ctx_ks     = concatMap ctx_ks contexts
+      , ctx_rrules = concatMap ctx_rrules contexts
+      , ctx_rrels  = concatMap ctx_rrels contexts
+      , ctx_vs     = concatMap ctx_vs contexts
+      , ctx_gs     = concatMap ctx_gs contexts
+      , ctx_ifcs   = concatMap ctx_ifcs contexts
+      , ctx_ps     = concatMap ctx_ps contexts
+      , ctx_pops   = concatMap ctx_pops contexts
+      , ctx_sql    = concatMap ctx_sql contexts
+      , ctx_php    = concatMap ctx_php contexts
+      , ctx_metas  = concatMap ctx_metas contexts
+      }
+    where contexts = [ctx1,ctx2]
+
+-- | Left-biased choice on maybes
+orElse :: Maybe a -> Maybe a -> Maybe a
+x `orElse` y = case x of
+                 Just _  -> x
+                 Nothing -> y
+

+ src/Database/Design/Ampersand/Core/Poset.hs view
@@ -0,0 +1,140 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}
+{- COPIED FROM http://hackage.haskell.org/package/altfloat-0.3.1 -}
+{-
+ - Copyright (C) 2009 Nick Bowler.
+ -
+ - License BSD2:  2-clause BSD license.  See LICENSE for full terms.
+ - This is free software: you are free to change and redistribute it.
+ - There is NO WARRANTY, to the extent permitted by law.
+ -}
+
+-- | Partially ordered data types.  The standard 'Prelude.Ord' class is for
+-- total orders and therefore not suitable for floating point.  However, we can
+-- still define meaningful 'max' and 'sortWith functions for these types.
+--
+-- We define our own 'Ord' class which is intended as a replacement for
+-- 'Prelude.Ord'.  Should the user wish to take advantage of existing libraries
+-- which use 'Prelude.Ord', just let Prelude.compare = (totalOrder .) . compare
+module Database.Design.Ampersand.Core.Poset (
+    Poset(..), Sortable(..), Ordering(..), Ord, comparableClass,greatest,least,maxima,minima,sortWith
+) where
+import qualified Prelude
+--import qualified GHC.Exts (sortWith)
+
+import Prelude hiding (Ord(..), Ordering(..))
+import Database.Design.Ampersand.Basics
+import Database.Design.Ampersand.Core.Poset.Instances() --required for instance Int of Poset only
+import Database.Design.Ampersand.Core.Poset.Internal hiding (fatal)
+
+--import Data.Function
+import Data.Monoid
+
+--import Database.Design.Ampersand.Basics (eqCl,isc,fatalMsg)
+import qualified Data.List as List
+
+fatal :: Int -> String -> a
+fatal = fatalMsg "Core.Poset"
+
+-- | makePartialOrder makes a partial order containing local partial orders, i.e. comparable classes.
+--   it makes sense to sort comparable classes.
+--   example: A and B are in a comparable class
+--            A and B are not LT, not GT, not EQ => CP
+--            if you sortBy comparableClass then A and B are considered EQ (comparableClass CP = Prelude.EQ)
+--   when the comparable classes have a top, then join can be defined on them
+--   when the comparable classes have a bottom, then meet can be defined on them
+--
+--   When A_Concept should be a collection of total orders change f a b guard (| or [ a `elem` cl && b `elem` cl | cl <- cls ] = NC)
+--
+--   examples on data X = A | B | C | D | E | F deriving (Eq,Show):
+--   [bottom]       (makePartialOrder [(A,B),(C,D),(B,D),(A,C),(D,E),(D,F)]) :: (A <= B /\ C <= B \/ C <= D <= E /\ F <= E \/ F)
+--   [ringish]      (makePartialOrder [(A,B),(C,D),(B,D),(A,C),(D,E),(D,F),(E,A),(F,A)]) _ _ = LT
+--   [ringish]      (makePartialOrder [(A,B),(C,D),(B,D),(A,C),(D,E),(D,F),(E,A)])       F A = GT
+--                  (makePartialOrder [(A,B),(C,D),(B,D),(A,C),(D,E),(D,F),(E,A)])       _ _ = LT
+--   [bottom,total] (makePartialOrder [(A,B),(C,D),(B,D),(A,C),(E,F)]) :: ( A <= B /\ C <= B \/ C <= D , E <= F )
+--   [2x total]     (makePartialOrder [(A,B),(B,C),(C,D),(E,F)]) :: ( A <= B <= C <= D , E <= F )
+--   [total]        (makePartialOrder [(A,B),(B,C),(C,D),(D,E),(E,F)]) :: ( A <= B <= C <= D <= E <= F )
+--   [3x total]     (makePartialOrder [(A,B),(B,C),(C,D)]) :: ( A <= B <= C <= D , E , F )
+--   [partial]      (makePartialOrder [(A,B),(C,D),(B,D),(D,E),(D,F)]) :: ( (A <= B <= D <= E /\ F <= E \/ F) + (C <= D <= E /\ F <= E \/ F) )
+--
+--   a sorted list will have the x left of y for all x and y. x <= y
+--   like x==y, the intraposition of x and y is without meaning for all x and y. x `compare` y = CP
+--   for example given a (makePartialOrder [(A,B),(C,D),(B,D),(D,E),(F,C)]):
+--    + sort  [F,E,D,C,B,A] = [F,C,A,B,D,E]
+--    + sort  [F,E,D,B,A,C] = [F,A,B,C,D,E]
+--    + sort  [B,F,E,C,D,A] = [A,B,F,C,D,E]
+
+instance Poset a => Poset (Maybe a) where
+    Just x  <= Just y = x <= y
+    Nothing <= _      = True
+    _       <= _      = False
+
+instance Poset a => Poset [a] where
+    compare = (mconcat .) . zipWith compare
+
+{-
+-- | Sort a list using the default comparison function.
+sort :: Sortable a => [a] -> [a]
+sort = sortBy compare
+
+-- | Apply a function to values before comparing.
+comparing :: Poset b => (a -> b) -> a -> a -> Ordering
+comparing = on compare
+-}
+
+-- example where b=A_Concept: sortWith (snd . order , concs fSpec) idCpt (vIndices fSpec)
+sortWith :: (Show b,Poset b) => (b -> [[b]], [b]) -> (a -> b) -> [a] -> [a]
+sortWith _   _  [] = []
+sortWith (tos,allb) f xs
+ = let xtos = [ [x | x<-xs, elem (f x) to] --group xs such that each elem of (map f xtos) is a total order
+              | to<-(tos . f . head) xs --non-trivial total orders
+                    ++ [[b] | b<-allb, not( elem b (concat((tos . f . head) xs))) ] --trivial total orders
+              ]
+       sortwith = List.sortBy (\x y -> comparableClass(compare (f x) (f y))) --sortwith of Poset, which should be a total order
+   in  concat(map sortwith xtos) --sortwith each total order and concat them
+
+-- | Elements can be arranged into classes of comparable elements, not necessarily a total order
+--   It makes sense to sort such a class.
+--   Take for example instance Sortable A_Concept.
+--   When A_Concept should be a collection of total orders: comparableClass CP = fatal 118 "Elements in totally ordered class, which are not LT, not GT and not EQ."
+comparableClass :: Ordering -> Prelude.Ordering
+comparableClass LT = Prelude.LT
+comparableClass EQ = Prelude.EQ
+comparableClass GT = Prelude.GT
+comparableClass NC = fatal 123 "Uncomparable elements in comparable class."
+comparableClass CP = Prelude.EQ --the position of two comparable concepts is equal
+
+{-
+-- | If elements are in a total order, then they can be sortedBy totalOrder using the Prelude.Ordering
+--   When A_Concept should be in a total order with an Anything and Nothing: sortBy f = Data.List.sortBy ((totalOrder .) . f)
+totalOrder :: Ordering -> Prelude.Ordering
+totalOrder LT = Prelude.LT
+totalOrder EQ = Prelude.EQ
+totalOrder GT = Prelude.GT
+totalOrder NC = fatal 132 "Uncomparable elements in total order."
+totalOrder CP = fatal 133 "Uncomparable elements in total order."
+-}
+
+-- | takes the greatest a of comparables
+greatest :: (Show a,Sortable a) => [a] -> a
+greatest xs =
+  case maxima (List.nub xs) of
+    []  -> fatal 138 "there is no greatest"
+    [x] -> x
+    xs'  -> fatal 140 ("there is more than one greatest: "++ show (List.nub xs'))
+-- | takes all a without anything larger
+maxima :: Sortable a => [a] -> [a]
+maxima [] = fatal 144 "the empty list has no maximum"
+maxima xs = [x | x<-List.nub xs,not (or [x < y | y<-List.nub xs])]
+
+-- | takes the least a of comparables if there is only one
+least :: Sortable a => [a] -> a
+least xs =
+  case minima (List.nub xs) of
+    []  -> fatal 150 "there is no least"
+    [x] -> x
+    _   -> fatal 150 "there is more than one least. "
+-- | takes all a without anything less
+minima :: Sortable a => [a] -> [a]
+minima [] = fatal 156 "the empty list has no minimum"
+minima xs = [x | x<-List.nub xs,not (or [y < x | y<-List.nub xs])]
+

+ src/Database/Design/Ampersand/Core/Poset/Instances.hs view
@@ -0,0 +1,57 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}
+{- COPIED FROM http://hackage.haskell.org/package/altfloat-0.3.1
+ - Disabled Sortable instances for instances of Prelude.Ord -}
+{-
+ - Copyright (C) 2009-2010 Nick Bowler.
+ -
+ - License BSD2:  2-clause BSD license.  See LICENSE for full terms.
+ - This is free software: you are free to change and redistribute it.
+ - There is NO WARRANTY, to the extent permitted by law.
+ -}
+
+-- | 'Poset' and 'Sortable' instances for instances of 'Prelude.Ord'
+{-# LANGUAGE CPP #-}
+module Database.Design.Ampersand.Core.Poset.Instances where
+
+import qualified Database.Design.Ampersand.Core.Poset.Internal as Poset
+import Database.Design.Ampersand.Core.Poset.Internal (Poset, partialOrder)
+
+import Data.Ratio
+import Data.Word
+import Data.Int
+
+#define POSET_ORD_INSTANCE(ctx, v) instance ctx Poset (v) where { \
+    compare = (partialOrder .) . compare; \
+    (<)     = (<); \
+    (<=)    = (<=); \
+    (>=)    = (>=); \
+    (>)     = (>); \
+    (<==>)  = const $ const True; \
+    (</=>)  = const $ const False }
+
+#define SORTABLE_ORD_INSTANCE(ctx, v) instance ctx Sortable (v) where { \
+    isOrdered = const True; \
+    sortBy f = sortBy $ (totalOrder .) . f; \
+    max    = max; \
+    min    = min; }
+
+#define ORD_INSTANCE(ctx, v) \
+    POSET_ORD_INSTANCE(ctx, v); \
+ {- SORTABLE_ORD_INSTANCE(ctx, v); -} \
+    instance ctx Poset.Ord (v)
+
+ORD_INSTANCE(, Bool)
+ORD_INSTANCE(, Char)
+ORD_INSTANCE(, Int)
+ORD_INSTANCE(, Int8)
+ORD_INSTANCE(, Int16)
+ORD_INSTANCE(, Int32)
+ORD_INSTANCE(, Int64)
+ORD_INSTANCE(, Word)
+ORD_INSTANCE(, Word8)
+ORD_INSTANCE(, Word16)
+ORD_INSTANCE(, Word32)
+ORD_INSTANCE(, Word64)
+ORD_INSTANCE(, Integer)
+
+ORD_INSTANCE(Integral a =>, Ratio a)

+ src/Database/Design/Ampersand/Core/Poset/Internal.hs view
@@ -0,0 +1,113 @@+{- Based on http://hackage.haskell.org/package/altfloat-0.3.1  -}
+{-
+ - Copyright (C) 2009-2010 Nick Bowler.
+ -
+ - License BSD2:  2-clause BSD license.  See LICENSE for full terms.
+ - This is free software: you are free to change and redistribute it.
+ - There is NO WARRANTY, to the extent permitted by law.
+ -}
+
+{-# LANGUAGE FlexibleInstances, OverlappingInstances, UndecidableInstances #-}
+module Database.Design.Ampersand.Core.Poset.Internal where
+
+import qualified Prelude
+import Prelude hiding (Ordering(..), Ord(..))
+import Data.Monoid
+import Database.Design.Ampersand.Basics (fatalMsg)
+fatal :: Int -> String -> a
+fatal = fatalMsg "Core.Poset.Internal"
+
+data Ordering = LT | EQ | GT | CP | NC
+    deriving (Eq, Show, Read, Bounded, Enum)
+
+-- Lexicographic ordering.
+instance Monoid Ordering where
+    mempty = EQ
+    mappend EQ x = x
+    mappend NC _ = NC
+    mappend LT _ = LT
+    mappend GT _ = GT
+    mappend CP _ = NC
+
+-- | Internal-use function to convert our Ordering to the ordinary one.
+totalOrder :: Ordering -> Prelude.Ordering
+totalOrder LT = Prelude.LT
+totalOrder EQ = Prelude.EQ
+totalOrder GT = Prelude.GT
+totalOrder NC = fatal 36 "Uncomparable elements in total order."
+totalOrder CP = fatal 37 "Uncomparable elements in total order."
+
+-- | Internal-use function to convert the ordinary Ordering to ours.
+partialOrder :: Prelude.Ordering -> Ordering
+partialOrder Prelude.LT = LT
+partialOrder Prelude.EQ = EQ
+partialOrder Prelude.GT = GT
+
+-- | Class for partially ordered data types.  Instances should satisfy the
+-- following laws for all values a, b and c:
+--
+-- * @a <= a@.
+--
+-- * @a <= b@ and @b <= a@ implies @a == b@.
+--
+-- * @a <= b@ and @b <= c@ implies @a <= c@.
+--
+-- But note that the floating point instances don't satisfy the first rule.
+--
+-- Minimal complete definition: 'compare' or '<='.
+class Eq a => Poset a where
+    compare :: a -> a -> Ordering
+    -- | Is comparable to.
+    (<==>) :: a -> a -> Bool
+    -- | Is not comparable to.
+    (</=>) :: a -> a -> Bool
+    (<) :: a -> a -> Bool
+    (<=) :: a -> a -> Bool
+    (>=) :: a -> a -> Bool
+    (>) :: a -> a -> Bool
+
+    a `compare` b
+        | a == b = EQ
+        | a <= b && b <= a = EQ
+        | a <= b = LT
+        | b <= a = GT
+        | otherwise = NC
+
+    a <    b = a `compare` b == LT
+    a >    b = a `compare` b == GT
+    a <==> b = a `compare` b /= NC
+    a </=> b = a `compare` b == NC
+    a <=   b = a < b || a `compare` b == EQ
+    a >=   b = a > b || a `compare` b == EQ
+
+-- | Class for partially ordered data types where sorting makes sense.
+-- This includes all totally ordered sets and floating point types.  Instances
+-- should satisfy the following laws:
+--
+-- * The set of elements for which 'isOrdered' returns true is totally ordered.
+--
+-- * The max (or min) of an insignificant element and a significant element
+-- is the significant one.
+--
+-- * The result of sorting a list should contain only significant elements.
+--
+-- * @max a b@ = @max b a@
+--
+-- * @min a b@ = @min b a@
+--
+-- The idea comes from floating point types, where non-comparable elements
+-- (NaNs) are the exception rather than the rule.  For these types, we can
+-- define 'max', 'min' and 'sortBy' to ignore insignificant elements.  Thus, a
+-- sort of floating point values will discard all NaNs and order the remaining
+-- elements.
+--
+-- Minimal complete definition: 'isOrdered'
+class Poset a => Sortable a where
+    sortBy :: (a -> a -> Ordering) -> [a] -> [a]
+    join :: a -> a -> a
+    meet :: a -> a -> a
+
+-- | Class for totally ordered data types.  Instances should satisfy
+-- @isOrdered a = True@ for all @a@.
+class Poset a => Ord a
+

+ src/Database/Design/Ampersand/Core/ToMeta.hs view
@@ -0,0 +1,345 @@+{-# LANGUAGE FlexibleInstances #-}
+module Database.Design.Ampersand.Core.ToMeta 
+  (toMeta)
+where
+import Database.Design.Ampersand.Misc
+import Database.Design.Ampersand.Core.ParseTree
+
+-- | When dealing with meta-stuff for Ampersand, (Like makeGenerics, makeRAP), 
+--   the names of Concepts should be different than 'normal', user-defined Concepts. 
+--   This function modifies everything in the context to reflect that.  
+toMeta :: MakeMeta a => Options -> (a -> a)
+toMeta opts = 
+  if metaTablesHaveUnderscore opts then makeMeta (string2Meta opts) else id
+
+string2Meta :: Options -> String -> String
+string2Meta opts str 
+              = if metaTablesHaveUnderscore opts 
+                then show ("__"++unquoted++"__")
+                else str
+  where
+    unquoted
+     | length str < 2 = str
+     | head str == '"' && last str == '"' = reverse . tail . reverse . tail $ str
+     | otherwise = str 
+
+class MakeMeta a where
+  makeMeta :: (String -> String) -> a -> a
+
+instance MakeMeta a => MakeMeta (Maybe a) where
+  makeMeta _ Nothing = Nothing
+  makeMeta f (Just a) = Just (makeMeta f a) 
+instance MakeMeta a => MakeMeta [a] where
+  makeMeta _ [] = []
+  makeMeta f xs = map (makeMeta f) xs
+    
+instance MakeMeta P_Context where
+  makeMeta f ctx
+   = PCtx{ ctx_nm    =            (ctx_nm ctx)  
+         , ctx_pos   = makeMeta f (ctx_pos ctx)
+         , ctx_lang  = makeMeta f (ctx_lang ctx)
+         , ctx_markup= makeMeta f (ctx_markup ctx)
+         , ctx_thms  =            (ctx_thms ctx)
+         , ctx_pats  = makeMeta f (ctx_pats ctx)
+         , ctx_PPrcs = makeMeta f (ctx_PPrcs ctx)
+         , ctx_rs    = makeMeta f (ctx_rs ctx)
+         , ctx_ds    = makeMeta f (ctx_ds ctx)
+         , ctx_cs    = makeMeta f (ctx_cs ctx)
+         , ctx_ks    = makeMeta f (ctx_ks ctx)
+         , ctx_rrules= makeMeta f (ctx_rrules ctx)
+         , ctx_rrels = makeMeta f (ctx_rrels ctx)
+         , ctx_vs    = makeMeta f (ctx_vs ctx)
+         , ctx_gs    = makeMeta f (ctx_gs ctx)
+         , ctx_ifcs  = makeMeta f (ctx_ifcs ctx)
+         , ctx_ps    = makeMeta f (ctx_ps ctx)
+         , ctx_pops  = makeMeta f (ctx_pops ctx)
+         , ctx_sql   = makeMeta f (ctx_sql ctx)
+         , ctx_php   = makeMeta f (ctx_php ctx)
+         , ctx_metas = makeMeta f (ctx_metas ctx)
+         } 
+
+instance MakeMeta P_Pattern where
+  makeMeta f p
+   = P_Pat { pt_nm  =            (pt_nm p)
+           , pt_pos = makeMeta f (pt_pos p)
+           , pt_end = makeMeta f (pt_end p)
+           , pt_rls = makeMeta f (pt_rls p)
+           , pt_gns = makeMeta f (pt_gns p)
+           , pt_dcs = makeMeta f (pt_dcs p)
+           , pt_RRuls = makeMeta f (pt_RRuls p)
+           , pt_RRels = makeMeta f (pt_RRels p)
+           , pt_cds = makeMeta f (pt_cds p)
+           , pt_ids = makeMeta f (pt_ids p)
+           , pt_vds = makeMeta f (pt_vds p)
+           , pt_xps = makeMeta f (pt_xps p)
+           , pt_pop = makeMeta f (pt_pop p)
+           }
+
+instance MakeMeta ConceptDef where
+  makeMeta f cd
+   = Cd  { cdpos  = makeMeta f (cdpos cd)
+         , cdcpt  =          f (cdcpt cd)
+         , cdplug =            (cdplug cd)
+         , cddef  =            (cddef cd)
+         , cdtyp  =            (cdtyp cd)
+         , cdref  =            (cdref cd)
+         , cdfrom =            (cdfrom cd)
+         }
+
+instance MakeMeta P_Declaration where
+  makeMeta f d
+   = P_Sgn { dec_nm   =          f (dec_nm d)
+           , dec_sign = makeMeta f (dec_sign d)
+           , dec_prps = makeMeta f (dec_prps d)
+           , dec_prL  =            (dec_prL d)
+           , dec_prM  =            (dec_prM d)
+           , dec_prR  =            (dec_prR d)
+           , dec_Mean = makeMeta f (dec_Mean d)
+           , dec_popu = makeMeta f (dec_popu d)
+           , dec_fpos = makeMeta f (dec_fpos d)
+           , dec_plug =            (dec_plug d)
+           }
+
+instance MakeMeta P_Sign where
+  makeMeta f sgn
+   = P_Sign { pSrc = makeMeta f (pSrc sgn)
+            , pTgt = makeMeta f (pTgt sgn)
+            }
+
+instance MakeMeta P_Concept where
+  makeMeta f cpt 
+    = case cpt of
+        PCpt{} -> PCpt{p_cptnm = f(p_cptnm cpt)}
+        P_Singleton -> cpt
+        
+instance MakeMeta a => MakeMeta (P_Rule a) where
+  makeMeta f rul
+   = P_Ru { rr_nm   =            (rr_nm rul)
+          , rr_exp  = makeMeta f (rr_exp rul)
+          , rr_fps  = makeMeta f (rr_fps rul)
+          , rr_mean = makeMeta f (rr_mean rul)
+          , rr_msg  = makeMeta f (rr_msg rul)
+          , rr_viol = makeMeta f (rr_viol rul)
+          }
+
+instance MakeMeta P_RoleRule where
+  makeMeta f rr
+   = Maintain
+          { mRoles =            (mRoles rr)
+          , mRules =            (mRules rr)
+          , mPos   = makeMeta f (mPos rr)
+          }
+instance MakeMeta P_RoleRelation where
+  makeMeta f rr
+   = P_RR { rr_Roles =            (rr_Roles rr)
+          , rr_Rels  = makeMeta f (rr_Rels rr)
+          , rr_Pos   = makeMeta f (rr_Pos rr)
+          }
+
+instance MakeMeta P_IdentDef where
+  makeMeta f ident
+   = P_Id { ix_pos = makeMeta f (ix_pos ident) 
+          , ix_lbl =          f (ix_lbl ident) -- TODO: HJO20150209: Not sure if it is wise to 'f' the label. Check with Michiel.
+          , ix_cpt = makeMeta f (ix_cpt ident)
+          , ix_ats = makeMeta f (ix_ats ident)
+          }
+instance MakeMeta P_IdentSegment where
+  makeMeta f sgmt
+   = P_IdentExp
+          { ks_obj = makeMeta f (ks_obj sgmt)
+          }
+instance MakeMeta a => MakeMeta (P_ViewD a) where
+  makeMeta f vd
+   = P_Vd { vd_pos = makeMeta f (vd_pos vd) 
+          , vd_lbl =            (vd_lbl vd) -- No need to meta these labels (only used as template variable names)
+          , vd_cpt = makeMeta f (vd_cpt vd)
+          , vd_isDefault =      (vd_isDefault vd)
+          , vd_html =           (vd_html vd) -- No need to meta the html template filename or inline html code
+          , vd_ats = makeMeta f (vd_ats vd)
+          }
+
+instance MakeMeta a => MakeMeta (P_ViewSegmt a) where
+  makeMeta f vs
+   = case vs of 
+      P_ViewExp{}  -> P_ViewExp { vs_obj = makeMeta f (vs_obj vs)
+                                }
+      P_ViewText{} -> vs
+      P_ViewHtml{} -> vs
+
+instance MakeMeta P_Gen where
+  makeMeta f gen
+   = case gen of 
+      P_Cy{} -> P_Cy { gen_spc = makeMeta f (gen_spc gen)
+                     , gen_rhs = makeMeta f (gen_rhs gen)
+                     , gen_fp  = makeMeta f (gen_fp gen)
+                     }
+      PGen{} -> PGen { gen_spc = makeMeta f (gen_spc gen)
+                     , gen_gen = makeMeta f (gen_gen gen)
+                     , gen_fp  = makeMeta f (gen_fp gen)
+                     }
+instance MakeMeta P_Interface where
+  makeMeta f ifc
+   = P_Ifc { ifc_Name   =            (ifc_Name ifc)
+           , ifc_Class  =            (ifc_Class ifc)
+           , ifc_Params = makeMeta f (ifc_Params ifc)
+           , ifc_Args   =            (ifc_Args ifc)
+           , ifc_Roles  =            (ifc_Roles ifc)
+           , ifc_Obj    = makeMeta f (ifc_Obj ifc)
+           , ifc_Pos    = makeMeta f (ifc_Pos ifc)
+           , ifc_Prp    =            (ifc_Prp ifc)
+           }
+instance MakeMeta PPurpose where
+  makeMeta f prp
+   = PRef2 { pexPos    = makeMeta f (pexPos prp)
+           , pexObj    = makeMeta f (pexObj prp)
+           , pexMarkup = makeMeta f (pexMarkup prp)
+           , pexRefIDs =            (pexRefIDs prp)
+           }
+
+instance MakeMeta P_Markup where
+  makeMeta f m
+   = P_Markup 
+          { mLang   = makeMeta f (mLang m)
+          , mFormat = makeMeta f (mFormat m)
+          , mString =            (mString m)
+          }
+instance MakeMeta PRef2Obj where
+  makeMeta f ref
+   = case ref of
+      PRef2ConceptDef s  -> PRef2ConceptDef (f s)
+      PRef2Declaration t -> PRef2Declaration (makeMeta f t)
+      PRef2Rule _        -> ref 
+      PRef2IdentityDef _ -> ref 
+      PRef2ViewDef _     -> ref 
+      PRef2Pattern _     -> ref 
+      PRef2Interface _   -> ref 
+      PRef2Context _     -> ref 
+      PRef2Fspc _        -> ref
+
+instance MakeMeta PMeaning where
+  makeMeta f (PMeaning m) = PMeaning (makeMeta f m)
+instance MakeMeta PMessage where
+  makeMeta f (PMessage m) = PMessage (makeMeta f m)
+instance MakeMeta P_Population where
+  makeMeta f pop 
+   = case pop of
+      P_RelPopu{} -> P_RelPopu { p_rnme  =          f (p_rnme pop)
+                               , p_orig  = makeMeta f (p_orig pop)
+                               , p_popps = makeMeta f (p_popps pop)
+                               }
+      P_TRelPop{} -> P_TRelPop { p_rnme  =          f (p_rnme pop)
+                               , p_type  = makeMeta f (p_type pop)
+                               , p_orig  = makeMeta f (p_orig pop)
+                               , p_popps = makeMeta f (p_popps pop)
+                               }
+      P_CptPopu{} -> P_CptPopu { p_cnme  =          f (p_rnme pop)
+                               , p_orig  = makeMeta f (p_orig pop)
+                               , p_popas =            (p_popas pop)
+                               }
+
+instance MakeMeta Meta where
+  makeMeta f m
+   = Meta { mtPos  = makeMeta f (mtPos m)
+          , mtObj  =            (mtObj m)
+          , mtName =            (mtName m)
+          , mtVal  =            (mtVal m)
+          }
+instance MakeMeta a => MakeMeta (P_ObjDef a) where
+  makeMeta f obj
+   = P_Obj { obj_nm   =          f (obj_nm obj)
+           , obj_pos  = makeMeta f (obj_pos obj)
+           , obj_ctx  = makeMeta f (obj_ctx obj)
+           , obj_mView =           (obj_mView obj)
+           , obj_msub = makeMeta f (obj_msub obj)
+           , obj_strs =            (obj_strs obj)
+           }
+
+instance MakeMeta a => MakeMeta (P_SubIfc a) where
+  makeMeta f sub
+   = case sub of
+      P_Box{}          -> P_Box         { si_ori   = makeMeta f (si_ori sub)
+                                        , si_class =            (si_class sub)
+                                        , si_box   = makeMeta f (si_box sub)
+                                        }
+      P_InterfaceRef{} -> P_InterfaceRef{ si_ori   = makeMeta f (si_ori sub)
+                                        , si_str   =            (si_str sub)
+                                        }
+
+instance MakeMeta a => MakeMeta (PairView a) where
+  makeMeta f pv
+    = PairView {ppv_segs = makeMeta f (ppv_segs pv)}
+instance MakeMeta a => MakeMeta (PairViewSegment a) where
+  makeMeta f sgmt
+    = case sgmt of
+       PairViewText{} -> sgmt
+       PairViewExp{}  -> sgmt{pvsExp = makeMeta f (pvsExp sgmt)}
+
+instance MakeMeta a => MakeMeta (Term a) where
+  makeMeta f t
+   = case t of
+       Prim a     -> Prim (makeMeta f a)
+       PEqu o a b -> PEqu o (makeMeta f a) (makeMeta f b)
+       PImp o a b -> PImp o (makeMeta f a) (makeMeta f b)
+       PIsc o a b -> PIsc o (makeMeta f a) (makeMeta f b)
+       PUni o a b -> PUni o (makeMeta f a) (makeMeta f b)
+       PDif o a b -> PDif o (makeMeta f a) (makeMeta f b)
+       PLrs o a b -> PLrs o (makeMeta f a) (makeMeta f b)
+       PRrs o a b -> PRrs o (makeMeta f a) (makeMeta f b)
+       PDia o a b -> PDia o (makeMeta f a) (makeMeta f b)
+       PCps o a b -> PCps o (makeMeta f a) (makeMeta f b)
+       PRad o a b -> PRad o (makeMeta f a) (makeMeta f b)
+       PPrd o a b -> PPrd o (makeMeta f a) (makeMeta f b)
+       PKl0 o a   -> PKl0 o (makeMeta f a)
+       PKl1 o a   -> PKl1 o (makeMeta f a)
+       PFlp o a   -> PFlp o (makeMeta f a)
+       PCpl o a   -> PCpl o (makeMeta f a)
+       PBrk o a   -> PBrk o (makeMeta f a)
+
+
+instance MakeMeta TermPrim where
+  makeMeta f t
+   = case t of
+      PI    _         -> t 
+      Pid   o c       -> Pid o (makeMeta f c)
+      Patm  o a c     -> Patm o a (makeMeta f c)
+      PVee  _         -> t
+      Pfull o src tgt -> Pfull o (makeMeta f src)(makeMeta f tgt)
+      PNamedR nr      -> PNamedR (makeMeta f nr)
+
+instance MakeMeta P_NamedRel where
+  makeMeta f (PNamedRel o nm      sgn)
+            = PNamedRel o (f nm) (makeMeta f sgn)
+   
+instance MakeMeta Paire where
+  makeMeta _ = id
+instance MakeMeta Origin where
+  makeMeta _ = id
+instance MakeMeta Lang where
+  makeMeta _ = id
+instance MakeMeta PandocFormat where
+  makeMeta _ = id
+instance MakeMeta Prop where
+  makeMeta _ = id
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+  
+ src/Database/Design/Ampersand/FSpec.hs view
@@ -0,0 +1,42 @@+module Database.Design.Ampersand.FSpec
+   ( module Database.Design.Ampersand.FSpec.FSpec
+   , module Database.Design.Ampersand.FSpec.Plug
+   , module Database.Design.Ampersand.FSpec.ShowHS
+   , module Database.Design.Ampersand.FSpec.ShowADL
+   , module Database.Design.Ampersand.FSpec.ShowECA
+   , module Database.Design.Ampersand.FSpec.ShowMeatGrinder
+   , module Database.Design.Ampersand.FSpec.Graphic.ClassDiagram
+   , module Database.Design.Ampersand.FSpec.Graphic.Graphics
+   , module Database.Design.Ampersand.FSpec.ToFSpec.Calc
+   , module Database.Design.Ampersand.FSpec.ToFSpec.ADL2FSpec
+   , module Database.Design.Ampersand.FSpec.ToFSpec.NormalForms
+   , module Database.Design.Ampersand.FSpec.Motivations
+   , module Database.Design.Ampersand.FSpec.ToFSpec.CreateFspec
+   )
+where
+import Database.Design.Ampersand.FSpec.FSpec
+       (FSpec(..), concDefs, ECArule(..), plugFields, lookupCpt, metaValues)
+import Database.Design.Ampersand.FSpec.Plug
+       (PlugInfo(..), PlugSQL(..), SqlField(..), SqlFieldUsage(..), SqlType(..), tblcontents,
+        Plugable(..),
+        showSQL, fldauto)
+import Database.Design.Ampersand.FSpec.ShowHS
+       (ShowHS(..), ShowHSName(..), fSpec2Haskell, haskellIdentifier)
+import Database.Design.Ampersand.FSpec.ShowADL (ShowADL(..), LanguageDependent(..))
+import Database.Design.Ampersand.FSpec.ShowECA (showECA)
+import Database.Design.Ampersand.FSpec.ShowMeatGrinder (makeMetaPopulationFile,MetaType(..))
+import Database.Design.Ampersand.FSpec.Graphic.ClassDiagram
+       (clAnalysis, cdAnalysis, ClassDiag(..))
+import Database.Design.Ampersand.FSpec.Graphic.Graphics
+       (makePicture,writePicture,Picture(..), PictureReq(..),imagePath)
+import Database.Design.Ampersand.FSpec.ToFSpec.Calc
+       (showProof,showPrf, commaEngPandoc, commaNLPandoc, commaEngPandoc', commaNLPandoc')
+import Database.Design.Ampersand.FSpec.ToFSpec.ADL2FSpec
+       (makeFSpec)
+import Database.Design.Ampersand.FSpec.ToFSpec.NormalForms
+       (conjNF, disjNF, cfProof, simplify)
+import Database.Design.Ampersand.FSpec.Motivations
+       (Meaning(..),Motivated(..))
+import Database.Design.Ampersand.FSpec.ToFSpec.CreateFspec 
+       (createFSpec,getPopulationsFrom)
+       
+ src/Database/Design/Ampersand/FSpec/Crud.hs view
@@ -0,0 +1,122 @@+module Database.Design.Ampersand.FSpec.Crud (CrudInfo(..), showCrudInfo, getCrudObjectsForInterface, mkCrudInfo) where
+
+import Data.Function
+import Data.List
+import Data.Map (Map) 
+import qualified Data.Map as Map 
+import Database.Design.Ampersand.Basics
+import Database.Design.Ampersand.Classes.ConceptStructure
+import Database.Design.Ampersand.Classes.Relational
+import Database.Design.Ampersand.Core.AbstractSyntaxTree
+
+fatal :: Int -> String -> a
+fatal = fatalMsg "Crud"
+
+-- For a description of the algorithms in this module, see https://github.com/AmpersandTarski/ampersand/issues/45 
+
+-- NOTE: The definitions of the various CRUD aspects are still a bit quirky and will most-likely need refinement. 
+--      (see notes/todo's here and in ampersand-models/Tests/NoSentinel/Crud.adl)
+
+data CrudInfo = CrudInfo { allCrudObjects :: [(A_Concept,[A_Concept])] -- crud concept together with its target concept in the surjective/total transitive closure of declarations 
+                         , crudObjsPerInterface :: [ (Interface, [(A_Concept,Bool,Bool,Bool,Bool)]) ]
+                         , crudObjsPerConcept :: [(A_Concept, ([Interface], [Interface], [Interface], [Interface]))]
+                         -- TODO: think about representation of these matrices
+                         } deriving Show
+
+showCrudInfo :: CrudInfo -> String
+showCrudInfo (CrudInfo crudObjs ifcCrudObjs _) =
+  "CRUD info\nObjects:\n" ++ unlines [ name crudCncpt ++" : " ++ show (map name crudDecls) | (crudCncpt, crudDecls) <- crudObjs] ++
+  "\nMatrices\n" ++ concat
+    [ "Interface " ++ name ifc ++
+      "\nC R U D Object\n" ++
+      (unlines $ map showCrud cObjs)
+    | (ifc, cObjs) <- ifcCrudObjs
+    ] ++ "\n"
+  where showCrud (cncpt, isC, isR, isU, isD) = concat [ showX isX ++ " " | isX <- [isC, isR, isU, isD] ] ++ show (name cncpt)
+        showX isX = if isX then "X" else " "
+
+getCrudObjectsForInterface :: CrudInfo -> Interface -> [(A_Concept,Bool,Bool,Bool,Bool)]
+getCrudObjectsForInterface crudInfo ifc = 
+  case lookup ifc $ crudObjsPerInterface crudInfo of
+    Nothing       -> fatal 33 $ "NO CRUD objects for interface " ++ show (name ifc)
+    Just crudObjs -> crudObjs
+  
+mkCrudInfo :: [A_Concept] -> [Declaration] -> [Interface] -> CrudInfo
+mkCrudInfo  allConceptsPrim allDecls allIfcs =
+  CrudInfo crudObjs crudObjsPerIfc (getCrudObjsPerConcept crudObjsPerIfc)
+  where allConcepts = [ c | c <- allConceptsPrim, not $ c == ONE || name c == "SESSION" ]
+        nonCrudConcpts = [ source d | d <- allDecls, isUni d && isSur d ] ++
+                         [ target d | d <- allDecls, isInj d && isTot d ]
+        crudCncpts = allConcepts \\ nonCrudConcpts
+        
+        transSurjClosureMap :: Map A_Concept [A_Concept]
+        transSurjClosureMap = transClosureMap . Map.fromListWith union $
+          [ (target d, [source d]) | d <- allDecls, isSur d ] ++ -- TODO: no isUni?
+          [ (source d, [target d]) | d <- allDecls, isTot d ]    -- TODO: no isInj?
+        
+        
+        -- crud concept together with its target concept in the surjective/total transitive closure of declarations
+        crudObjs :: [(A_Concept, [A_Concept])]
+        crudObjs = [ (crudCncpt, Map.findWithDefault [] crudCncpt transSurjClosureMap) -- TODO: should [] be a fatal? 
+                   | crudCncpt <- crudCncpts ]
+        
+        getCrudUpdateConcpts :: Declaration -> [A_Concept]
+        getCrudUpdateConcpts decl = 
+          if  isSur decl || isTot decl  -- TODO: no isUni?  -- TODO: no isInj?
+          then [ cObj | (cObj, cCncpts) <- crudObjs, source decl `elem` cCncpts && target decl `elem` cCncpts ]    
+          else []
+          
+        crudObjsPerIfc = [ (ifc, getCrudObjsPerIfc ifc) | ifc <- allIfcs ]
+        
+        -- Not the most efficient implementation, but it is easy to read, and the total number of concepts will not be enormous.
+        getCrudObjsPerIfc :: Interface -> [(A_Concept,Bool,Bool,Bool,Bool)]
+        getCrudObjsPerIfc ifc = [ (cObj, isC, isR, isU, isD)
+                                | cObj <- crudCncpts
+                                , let isC = cObj `elem` crudCreateCncpts
+                                , let isR = cObj `elem` crudReadCncpts
+                                , let isU = cObj `elem` crudUpdateCncpts
+                                , let isD = cObj `elem` crudDeleteCncpts
+                                , or [isC, isR, isU, isD]
+                                ]                            
+          where crudCreateCncpts = editableTgts
+                crudReadCncpts   = concs (relsUsedIn ifc) -- NOTE: this includes interface params, even if they do not appear in any of the field expressions
+                crudDeleteCncpts = crudCreateCncpts -- We can't currently distinguish between these two.
+                crudUpdateCncpts = concatMap getCrudUpdateConcpts editableDecls
+                (editableDecls, editableTgts) = unzip $ getEditableDeclsAndTargets allIfcs ifc
+                                             
+-- NOTE: editable target is not necessarily the target of decl, as it may have been flipped (in which case it's the source)
+getEditableDeclsAndTargets :: [Interface] -> Interface -> [(Declaration, A_Concept)]
+getEditableDeclsAndTargets allIfcs ifc = concatMap editableTarget $ getAllInterfaceExprs allIfcs ifc
+  where editableTarget expr = 
+          case getExpressionRelation expr of
+            Nothing                                                              -> []
+            Just (declSrc, decl, declTgt, isFlipped) | decl `elem` ifcParams ifc -> [(decl, if isFlipped then declSrc else declTgt)]
+                                                     | otherwise                 -> []
+
+getAllInterfaceExprs :: [Interface] -> Interface -> [Expression]
+getAllInterfaceExprs allIfcs ifc = getExprs $ ifcObj ifc
+  where getExprs Obj{objctx=expr, objmsub=subObj} = 
+          expr : case subObj of Nothing                -> []
+                                Just (InterfaceRef nm) ->
+                                  case filter (\rIfc -> name rIfc == nm) $ allIfcs of -- Follow interface ref
+                                    []      -> fatal 65 $ "Referenced interface " ++ nm ++ " missing"
+                                    (_:_:_) -> fatal 66 $ "Multiple declarations of referenced interface " ++ nm
+                                    [i]     -> getAllInterfaceExprs allIfcs i
+                                Just (Box _ _ objs)    -> concatMap getExprs objs
+
+getCrudObjsPerConcept :: [(Interface, [(A_Concept,Bool,Bool,Bool,Bool)])] ->
+                         [(A_Concept, ([Interface], [Interface], [Interface], [Interface]))]
+getCrudObjsPerConcept crudsPerIfc = sortBy (compare `on` fst)  conceptsAndInterfaces
+  where conceptsAndInterfaces :: [(A_Concept, ([Interface], [Interface], [Interface], [Interface]))]
+        conceptsAndInterfaces = concatMap toIfcPerConcept crudsPerIfc
+        
+        toIfcPerConcept :: (Interface, [(A_Concept,Bool,Bool,Bool,Bool)]) -> 
+                           [(A_Concept, ([Interface], [Interface], [Interface], [Interface]))]
+        toIfcPerConcept (ifc, ifcCrudObjs) = [ (cncpt, ( if isC then [ifc] else []
+                                                       , if isR then [ifc] else []
+                                                       , if isU then [ifc] else []
+                                                       , if isD then [ifc] else []
+                                                       )
+                                               )
+                                             | (cncpt, isC, isR, isU, isD) <- ifcCrudObjs
+                                             ]

+ src/Database/Design/Ampersand/FSpec/FPA.hs view
@@ -0,0 +1,119 @@+module Database.Design.Ampersand.FSpec.FPA (FPA(..), FP(..), FPType(..), ShowLang(..), fpAnalyze, fpVal, fpaPlugInfo, fpaInterface) where 
+                                           -- fpaPlugInfo and fpaInterface are exported for legacy modules Statistics and FSpec2Excel
+
+import Database.Design.Ampersand.Misc (Lang(..))
+import Database.Design.Ampersand.ADL1
+import Database.Design.Ampersand.Classes
+import Database.Design.Ampersand.FSpec.FSpec
+import Database.Design.Ampersand.Basics
+import Data.Maybe
+
+--fatal :: Int -> String -> a
+--fatal = fatalMsg "FSpec.FPA"
+
+data FPA = FPA { dataModelFPA :: ([FP], Int), userTransactionFPA :: ([FP],Int) } deriving Show
+
+-- NOTE: FPA constructors are in Dutch (so 'output function' is not OF, but UF)   
+
+data Complexity = Eenvoudig | Gemiddeld | Moeilijk deriving (Show, Eq, Ord)
+
+data FPType
+ = ILGV -- ^ bevat permanente, voor de gebruiker relevante gegevens. De gegevens worden door het systeem gebruikt en onderhouden. Onder "onderhouden" verstaat FPA het toevoegen, wijzigen of verwijderen van gegevens.
+ | KGV  -- ^ bevat permanente, voor de gebruiker relevante gegevens. Deze gegevens worden door het systeem gebruikt, maar worden door een ander systeem onderhouden (voor dat andere systeem is het dus een ILGV).
+ | IF   -- ^ verwerkt gegevens in een ILGV van het systeem. (dus create, update en delete functies)
+ | UF   -- ^ presenteert gegevens uit het systeem. Voorbeelden: het afdrukken van alle debiteuren; het aanmaken van facturen; het aanmaken van een diskette met betalingsopdrachten; het medium is hierbij niet van belang: papier, scherm, magneetband, datacom, enzovoorts.
+ | OF   -- ^ is een speciaal (eenvoudig) soort uitvoerfunctie. Een opvraagfunctie presenteert gegevens uit het systeem op basis van een uniek identificerend zoekgegeven, waarbij geen aanvullende bewerkingen (zoals berekeningen of het bijwerken van een gegevensverzameling) plaats hebben. Voorbeeld: Het tonen van de gegevens van de klant met klantnummer 123456789.
+  deriving Show
+
+data FP = FP { fpType :: FPType, fpName :: String, fpComplexity :: Complexity } deriving Show
+
+
+-- | Valuing of function points according to par. 3.9 (UK) or par. 2.9 (NL), see http://www.nesma.nl/sectie/fpa/hoefpa.asp
+fpVal :: FP -> Int
+fpVal FP{fpType=ILGV, fpComplexity=Eenvoudig} = 7
+fpVal FP{fpType=ILGV, fpComplexity=Gemiddeld} = 10
+fpVal FP{fpType=ILGV, fpComplexity=Moeilijk}  = 15
+fpVal FP{fpType=KGV,  fpComplexity=Eenvoudig} = 5
+fpVal FP{fpType=KGV,  fpComplexity=Gemiddeld} = 7
+fpVal FP{fpType=KGV,  fpComplexity=Moeilijk}  = 10
+fpVal FP{fpType=IF,   fpComplexity=Eenvoudig} = 3
+fpVal FP{fpType=IF,   fpComplexity=Gemiddeld} = 4
+fpVal FP{fpType=IF,   fpComplexity=Moeilijk}  = 6
+fpVal FP{fpType=UF,   fpComplexity=Eenvoudig} = 4
+fpVal FP{fpType=UF,   fpComplexity=Gemiddeld} = 5
+fpVal FP{fpType=UF,   fpComplexity=Moeilijk}  = 7
+fpVal FP{fpType=OF,   fpComplexity=Eenvoudig} = 3
+fpVal FP{fpType=OF,   fpComplexity=Gemiddeld} = 4
+fpVal FP{fpType=OF,   fpComplexity=Moeilijk}  = 6
+
+fpAnalyze :: FSpec -> FPA
+fpAnalyze fSpec = FPA (countFPs $ fpaDataModel fSpec) (countFPs $ fpaUserTransactions fSpec)
+  where countFPs :: [FP] -> ([FP], Int)
+        countFPs fps = (fps, sum $ map fpVal fps)
+
+-- Na overleg met Frank Vogelenzang zijn de volgende criteria voor functiepuntentelling toegepast
+fpaDataModel :: FSpec -> [FP]
+fpaDataModel fSpec = mapMaybe fpaPlugInfo $ plugInfos fSpec
+
+fpaPlugInfo :: PlugInfo -> Maybe FP
+fpaPlugInfo p@(InternalPlug (TblSQL{fields=flds})) | Just cmplxty <- ilgvComplexity $ length flds =
+  Just $ FP ILGV (name p) cmplxty
+  where ilgvComplexity :: Int -> Maybe Complexity
+        ilgvComplexity n | n <= 2    = Nothing 
+                         | n <= 15   = Just Eenvoudig
+                         | n <= 40   = Just Gemiddeld
+                         | otherwise = Just Moeilijk
+fpaPlugInfo _ = Nothing
+
+fpaUserTransactions :: FSpec -> [FP]
+fpaUserTransactions fSpec = map fpaInterface $ interfaceS fSpec
+
+fpaInterface :: Interface -> FP
+fpaInterface ifc = 
+   let nm = name ifc
+       cmplxty = depth2Cmplxty $ getDepth $ ifcObj ifc
+       tp = case ifc of
+              Ifc{ifcClass=Just "IF"} -> IF
+              Ifc{ifcClass=Just "UF"} -> UF
+              Ifc{ifcClass=Just "OF"} -> OF
+              
+              -- code for interfaces without CLASS comes from old FPA.hs
+              _ | (not.null.ifcParams)  ifc -> IF  -- In case there are editable relations, this must be an import function.
+                | (isUni.objctx.ifcObj) ifc -> OF  -- If there is max one atom, this is a simple function.
+                | otherwise                 -> UF  -- Otherwise, it is a UF
+    in FP tp nm cmplxty
+  where depth2Cmplxty :: Int -> Complexity
+        depth2Cmplxty d | d <= 1    = Eenvoudig
+                        | d == 2    = Gemiddeld
+                        | otherwise = Moeilijk 
+
+        getDepth Obj{objmsub=Nothing}             = 0
+        getDepth Obj{objmsub=Just InterfaceRef{}} = 1 -- TODO: shouldn't we follow the ref? (this def. is from old FPA.hs)
+        getDepth Obj{objmsub=Just (Box _ _ objs)}   = 1 + maximum (map getDepth objs)
+
+class ShowLang a where
+  showLang :: Lang -> a -> String
+
+instance ShowLang FP where
+  showLang lang fp = showLang lang (fpType fp) ++ " " ++ showLang lang (fpComplexity fp)
+
+
+instance ShowLang FPType where
+  showLang Dutch   ILGV = "ILGV" 
+  showLang Dutch   KGV  = "KGV" 
+  showLang Dutch   IF   = "IF"
+  showLang Dutch   UF   = "UF"
+  showLang Dutch   OF   = "OF"
+  showLang English ILGV = "ILF" -- Internal Logical File 
+  showLang English KGV  = "ELF" -- External Logical File 
+  showLang English IF   = "EI"  -- External Input
+  showLang English UF   = "EO"  -- External Output
+  showLang English OF   = "EQ"  -- External inQuiry
+
+instance ShowLang Complexity where
+  showLang Dutch   Eenvoudig = "Eenvoudig" 
+  showLang Dutch   Gemiddeld = "Gemiddeld"
+  showLang Dutch   Moeilijk  = "Moeilijk"
+  showLang English Eenvoudig = "Low" 
+  showLang English Gemiddeld = "Average"
+  showLang English Moeilijk  = "High"

+ src/Database/Design/Ampersand/FSpec/FSpec.hs view
@@ -0,0 +1,359 @@+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE FlexibleInstances #-}
+{- | The intentions behind FSpec (SJ 30 dec 2008):
+Generation of functional specifications is the core functionality of Ampersand.
+All items in a specification are generated into the following data structure, FSpec.
+It is built by compiling an Ampersand script and translating that to FSpec.
+In the future, other ways of 'filling' FSpec are foreseen.
+All generators (such as the code generator, the proof generator, the atlas generator, etc.)
+are merely different ways to show FSpec.
+-}
+module Database.Design.Ampersand.FSpec.FSpec
+          ( FSpec(..), concDefs, Atom(..), A_Pair(..)
+          , Fswitchboard(..), Quad(..)
+          , FSid(..)
+--        , InsDel(..)
+          , ECArule(..)
+--        , Event(..)
+--        , PAclause(..)
+          , Activity(..)
+          , PlugSQL(..),plugFields
+          , lookupCpt, getConceptTableFor
+          , metaValues
+          , SqlField(..)
+          , Object(..)
+          , PlugInfo(..)
+          , SqlType(..)
+          , SqlFieldUsage(..)
+          , getGeneralizations, getSpecializations
+          , lookupView, getDefaultViewForConcept
+          , Conjunct(..),DnfClause(..), dnf2expr, notCpl
+          , Language(..)
+          ) where
+          
+import Data.List
+import Data.Typeable
+import Database.Design.Ampersand.ADL1.Pair
+import Database.Design.Ampersand.ADL1.Expression (notCpl)
+import Database.Design.Ampersand.Basics
+import Database.Design.Ampersand.Classes
+import Database.Design.Ampersand.Core.AbstractSyntaxTree
+import Database.Design.Ampersand.FSpec.Crud
+import Database.Design.Ampersand.Misc.Options (Options)
+import Text.Pandoc.Builder (Blocks)
+
+fatal :: Int -> String -> a
+fatal = fatalMsg "FSpec.FSpec"
+
+data FSpec = FSpec { fsName ::       String                   -- ^ The name of the specification, taken from the Ampersand script
+                   , originalContext :: A_Context             -- ^ the original context. (for showADL)  
+                   , getOpts ::      Options                  -- ^ The command line options that were used when this FSpec was compiled  by Ampersand.
+                   , fspos ::        [Origin]                 -- ^ The origin of the FSpec. An FSpec can be a merge of a file including other files c.q. a list of Origin.
+                   , themes ::       [String]                 -- ^ The names of patterns/processes to be printed in the functional specification. (for making partial documentation)
+                     , pattsInScope :: [Pattern]
+                     , rulesInScope :: [Rule]
+                     , declsInScope :: [Declaration]
+                     , concsInScope :: [A_Concept]
+                     , cDefsInScope :: [ConceptDef]
+                     , gensInScope  :: [A_Gen]
+                   , fsLang ::       Lang                     -- ^ The default language for this specification (always specified, so no Maybe here!).
+                   , vplugInfos ::   [PlugInfo]               -- ^ All plugs defined in the Ampersand script
+                   , plugInfos ::    [PlugInfo]               -- ^ All plugs (defined and derived)
+                   , interfaceS ::   [Interface]              -- ^ All interfaces defined in the Ampersand script
+                   , interfaceG ::   [Interface]              -- ^ All interfaces derived from the basic ontology (the Lonneker interface)
+                   , fSwitchboard :: Fswitchboard             -- ^ The code to be executed to maintain the truth of invariants
+                   , fDeriveProofs :: Blocks                  -- ^ The proofs in Pandoc format
+                   , fActivities ::  [Activity]               -- ^ generated: One Activity for every ObjectDef in interfaceG and interfaceS
+                   , fRoleRels ::    [(Role,Declaration)]     -- ^ the relation saying which roles may change the population of which relation.
+                   , fRoleRuls ::    [(Role,Rule)]            -- ^ the relation saying which roles may change the population of which relation.
+                   , fRoles ::       [Role]                   -- ^ All roles mentioned in this context.
+                   , fallRules ::    [Rule]
+                   , vrules ::       [Rule]                   -- ^ All user defined rules that apply in the entire FSpec
+                   , grules ::       [Rule]                   -- ^ All rules that are generated: multiplicity rules and identity rules
+                   , invariants ::   [Rule]                   -- ^ All invariant rules
+                   , allUsedDecls :: [Declaration]            -- ^ All relations that are used in the fSpec
+                   , allDecls ::     [Declaration]            -- ^ All relations that are declared in the fSpec
+                   , vrels ::        [Declaration]            -- ^ All user defined and generated relations plus all defined and computed totals.
+                                                              --   The generated relations are all generalizations and
+                                                              --   one declaration for each signal.
+                   , allConcepts ::  [A_Concept]              -- ^ All concepts in the fSpec
+                   , kernels ::      [[A_Concept]]            -- ^ All concepts, grouped by their classifications
+                   , vIndices ::     [IdentityDef]            -- ^ All keys that apply in the entire FSpec
+                   , vviews ::       [ViewDef]                -- ^ All views that apply in the entire FSpec
+                   , vgens ::        [A_Gen]                  -- ^ All gens that apply in the entire FSpec
+                   , vconjs ::       [Conjunct]               -- ^ All conjuncts generated (by ADL2FSpec)
+                   , allConjsPerRule :: [(Rule,[Conjunct])]   -- ^ Maps each rule onto the conjuncts it consists of (note that a single conjunct may be part of several rules) 
+                   , allConjsPerDecl :: [(Declaration, [Conjunct])]   -- ^ Maps each declaration to the conjuncts it appears in   
+                   , allConjsPerConcept :: [(A_Concept, [Conjunct])]  -- ^ Maps each concept to the conjuncts it appears in (as source or targent of a constituent relation)
+                   , vquads ::       [Quad]                   -- ^ All quads generated (by ADL2FSpec)
+                   , vEcas ::        [ECArule]                -- ^ All ECA rules generated (by ADL2FSpec)
+                   , fsisa ::        [(A_Concept, A_Concept)] -- ^ generated: The data structure containing the generalization structure of concepts
+                   , vpatterns ::    [Pattern]                -- ^ All patterns taken from the Ampersand script
+                   , conceptDefs ::  [ConceptDef]             -- ^ All concept definitions defined throughout a context, including those inside patterns and processes
+                   , fSexpls ::      [Purpose]                -- ^ All purposes that have been declared at the top level of the current specification, but not in the processes, patterns and interfaces.
+                   , metas ::        [Meta]                   -- ^ All meta relations from the entire context
+                   , crudInfo ::     CrudInfo                 -- ^ Information for CRUD matrices 
+                   , initialPops ::  [Population]             -- ^ All user defined populations of relations and concepts
+                   , allAtoms ::     [Atom]
+                   , allLinks ::     [A_Pair]
+                   , initialConjunctSignals :: [(Conjunct,[Paire])] -- ^ All conjuncts that have process-rule violations.
+                   , allViolations ::  [(Rule,[Paire])]       -- ^ All invariant rules with violations.
+                   , allExprs      :: [Expression]            -- ^ All expressions in the fSpec
+                   , allSigns      :: [Sign]                  -- ^ All Signs in the fSpec
+                   } deriving Typeable
+instance Eq FSpec where
+ f == f' = name f == name f'
+instance Unique FSpec where
+ showUnique = name
+metaValues :: String -> FSpec -> [String]
+metaValues key fSpec = [mtVal m | m <-metas fSpec, mtName m == key]
+
+data Atom = Atom { atmRoots :: [A_Concept] -- The root concept(s) of the atom.
+                 , atmIn    :: [A_Concept] -- all concepts the atom is in. (Based on generalizations)
+                 , atmVal   :: String
+                 } deriving (Typeable,Eq)
+instance Unique Atom where
+  showUnique a = atmVal a++" in "
+         ++case atmRoots a of
+             []  -> fatal 110 "an atom must have at least one root concept"
+             [x] -> uniqueShow True x
+             xs  -> "["++intercalate ", " (map (uniqueShow True) xs)++"]"
+
+data A_Pair = Pair { lnkDcl :: Declaration
+                   , lnkLeft :: Atom
+                   , lnkRight :: Atom
+                   } deriving (Typeable,Eq)
+instance Association A_Pair where
+  sign = sign . lnkDcl
+instance Unique A_Pair where
+  showUnique x = uniqueShow False (lnkDcl x)
+              ++ uniqueShow False (lnkLeft x)
+              ++ uniqueShow False (lnkRight x)
+concDefs :: FSpec -> A_Concept -> [ConceptDef]
+concDefs fSpec c = [ cdef | cdef<-conceptDefs fSpec, name cdef==name c ]
+
+instance ConceptStructure FSpec where
+  concs     fSpec = allConcepts fSpec                     -- The set of all concepts used in this FSpec
+  expressionsIn fSpec = allExprs fSpec
+
+-- | A list of ECA rules, which is used for automated functionality.
+data Fswitchboard
+  = Fswtch { fsbEvIn :: [Event]
+           , fsbEvOut :: [Event]
+           , fsbConjs :: [(Rule, Expression)]
+           , fsbECAs :: [ECArule]
+           }
+
+--type Fields = [Field]
+--data Field  = Att { fld_name :: String        -- The name of this field
+--                  , fld_sub :: Fields        -- all sub-fields
+--                  , fld_expr :: Expression    -- The expression by which this field is attached to the interface
+--                  , fld_rel :: Relation      -- The relation to which the database table is attached.
+--                  , fld_editable :: Bool          -- can this field be changed by the user of this interface?
+--                  , fld_list :: Bool          -- can there be multiple values in this field?
+--                  , fld_must :: Bool          -- is this field obligatory?
+--                  , fld_new :: Bool          -- can new elements be filled in? (if no, only existing elements can be selected)
+--                  , fld_sLevel :: Int           -- The (recursive) depth of the current servlet wrt the entire interface. This is used for documentation.
+--                  , fld_insAble :: Bool          -- can the user insert in this field?
+--                  , fld_onIns :: ECArule       -- the PAclause to be executed after an insert on this field
+--                  , fld_delAble :: Bool          -- can the user delete this field?
+--                  , fld_onDel :: ECArule       -- the PAclause to be executed after a delete on this field
+--                  }
+
+{- from http://www.w3.org/TR/wsdl20/#InterfaceOperation
+ - "The properties of the Interface Operation component are as follows:
+ - ...
+ - * {interface message references} OPTIONAL. A set of Interface Message Reference components for the ordinary messages the operation accepts or sends.
+ - ..."
+-}
+
+data FSid = FS_id String     -- Identifiers in the Functional Specification Language contain strings that do not contain any spaces.
+        --  | NoName           -- some identified objects have no name...
+instance Named FSpec where
+  name = fsName
+
+instance Named FSid where
+  name (FS_id nm) = nm
+
+data Activity = Act { actRule ::   Rule
+                    , actTrig ::   [Declaration]
+                    , actAffect :: [Declaration]
+                    , actQuads ::  [Quad]
+                    , actEcas ::   [ECArule]
+                    , actPurp ::   [Purpose]
+                    } deriving Show
+
+instance Named Activity where
+  name act = name (actRule act)
+-- | A Quad is used in the "switchboard" of rules. It represents a "proto-rule" with the following meaning:
+--   whenever qDcl is affected (i.e. tuples in qDcl are inserted or deleted), qRule may have to be restored using functionality from qConjuncts.
+--   The rule is taken along for traceability.
+
+instance ConceptStructure Activity where
+ concs         act = concs (actRule act) `uni` concs (actAffect act)
+ expressionsIn act = expressionsIn (actRule act)
+
+data Quad = Quad { qDcl ::       Declaration   -- The relation that, when affected, triggers a restore action.
+                 , qRule ::      Rule          -- The rule from which qConjuncts is derived.
+                 , qConjuncts :: [Conjunct]    -- The conjuncts, with clauses included
+                 } deriving Show
+
+instance Eq Quad where
+  q == q'  = qDcl q == qDcl q' && qRule q == qRule q'
+
+instance Eq Activity where
+  a == a'  = actRule a == actRule a'
+
+--
+dnf2expr :: DnfClause -> Expression
+dnf2expr dnf
+ = case (antcs dnf, conss dnf) of
+    ([],[]) -> fatal 327 "empty dnf clause"
+    ([],cs ) -> foldr1 (.\/.) cs
+    (as,[]) -> notCpl (foldr1 (./\.) as)
+    (as,cs) -> notCpl (foldr1 (./\.) as) .\/. (foldr1 (.\/.) cs)
+
+data PlugInfo = InternalPlug PlugSQL
+              | ExternalPlug ObjectDef
+                deriving (Show, Eq,Typeable)
+instance Named PlugInfo where
+  name (InternalPlug psql) = name psql
+  name (ExternalPlug obj)  = name obj
+instance Unique PlugInfo where
+  showUnique (InternalPlug psql) = "SQLTable "++name psql
+  showUnique (ExternalPlug obj ) = "Object "++name obj++show (origin obj)
+instance ConceptStructure PlugInfo where
+  concs   (InternalPlug psql) = concs   psql
+  concs   (ExternalPlug obj)  = concs   obj
+  expressionsIn (InternalPlug psql) = expressionsIn psql
+  expressionsIn (ExternalPlug obj)  = expressionsIn obj
+instance ConceptStructure PlugSQL where
+  concs     p = concs   (plugFields p)
+  expressionsIn   p = expressionsIn (plugFields p)
+
+data PlugSQL
+   -- | stores a related collection of relations: a kernel of concepts and attribute relations of this kernel
+   --   i.e. a list of SqlField given some A -> [target r | r::A*B,isUni r,isTot r, isInj r]
+   --                                        ++ [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=fldexpr of kernel field holding instances of B, in practice r is I or a makeRelation(flipped declaration))
+   --      attribute relations = All concepts B, A in kernel for which there exists a r::A*B[UNI] and r not TOT and SUR
+   --              (r=fldexpr of attMor field, in practice r is a makeRelation(declaration))
+ = TblSQL  { sqlname :: String
+           , fields :: [SqlField]                          -- ^ the first field is the concept table of the most general concept (e.g. Person)
+                                                           --   then follow concept tables of specializations. Together with the first field this is called the "kernel"
+                                                           --   the remaining fields represent attributes.
+           , cLkpTbl :: [(A_Concept,SqlField)]             -- ^ lookup table that links all kernel concepts to fields in the plug
+                                                           -- cLkpTbl is een lijst concepten die in deze plug opgeslagen zitten, en hoe je ze eruit kunt halen
+           , mLkpTbl :: [(Expression,SqlField,SqlField)]   -- ^ lookup table that links concepts to column names in the plug (kernel+attRels)
+                                                           -- mLkpTbl is een lijst met relaties die in deze plug opgeslagen zitten, en hoe je ze eruit kunt halen
+           }
+   -- | stores one relation r in two ordered columns
+   --   i.e. a tuple of SqlField -> (source r,target r) with (fldexpr=I/\r;r~, fldexpr=r)
+   --   (note: if r TOT then (I/\r;r~ = I). Thus, the concept (source r) is stored in this plug too)
+   --   with tblcontents = [[Just x,Just y] |(x,y)<-contents r].
+   --   Typical for BinSQL is that it has exactly two columns that are not unique and may not contain NULL values
+ | BinSQL  { sqlname :: String
+           , columns :: (SqlField,SqlField)
+           , cLkpTbl :: [(A_Concept,SqlField)] --given that mLkp cannot be (UNI or INJ) (because then r would be in a TblSQL plug)
+                                                --if mLkp is TOT, then the concept (source mLkp) is stored in this plug
+                                                --if mLkp is SUR, then the concept (target mLkp) is stored in this plug
+           , mLkp :: Expression -- the relation links concepts implemented by this plug
+           }
+ -- |stores one concept c in one column
+ --  i.e. a SqlField -> c
+ --  with tblcontents = [[Just x] |(x,_)<-contents c].
+ --  Typical for ScalarSQL is that it has exactly one column that is unique and may not contain NULL values i.e. fldexpr=I[c]
+ | ScalarSQL
+           { sqlname :: String
+           , sqlColumn :: SqlField
+           , cLkp :: A_Concept -- the concept implemented by this plug
+           }
+   deriving (Show, Typeable)
+instance Named PlugSQL where
+  name = sqlname
+instance Eq PlugSQL where
+  x==y = name x==name y
+instance Unique PlugSQL where
+  showUnique = name
+instance Ord PlugSQL where
+  compare x y = compare (name x) (name y)
+
+plugFields :: PlugSQL->[SqlField]
+plugFields plug = case plug of
+    TblSQL{}    -> fields plug
+    BinSQL{}    -> [fst(columns plug),snd(columns plug)]
+    ScalarSQL{} -> [sqlColumn plug]
+
+-- | This returns all column/table pairs that serve as a concept table for cpt. When adding/removing atoms, all of these
+-- columns need to be updated
+lookupCpt :: FSpec -> A_Concept -> [(PlugSQL,SqlField)]
+lookupCpt fSpec cpt = [(plug,fld) |InternalPlug plug@TblSQL{}<-plugInfos fSpec, (c,fld)<-cLkpTbl plug,c==cpt]++
+                 [(plug,fld) |InternalPlug plug@BinSQL{}<-plugInfos fSpec, (c,fld)<-cLkpTbl plug,c==cpt]++
+                 [(plug,sqlColumn plug) |InternalPlug plug@ScalarSQL{}<-plugInfos fSpec, cLkp plug==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 -> String
+getConceptTableFor fSpec c = case lookupCpt fSpec c of
+                               []      -> fatal 297 $ "tableFor: No concept table for " ++ name c
+                               (t,_):_ -> name t -- in case there are more, we use the first one
+
+data SqlFieldUsage = TableKey Bool A_Concept  -- The field is the (primary) key of the table. (The boolean tells whether or not it is primary)
+                   | ForeignKey A_Concept  -- The field is a reference (containing the primary key value of) a TblSQL
+                   | PlainAttr             -- None of the above
+                   deriving (Eq, Show)
+
+data SqlField = Fld { fldname :: String
+                    , fldexpr :: Expression     -- ^ De target van de expressie geeft de waarden weer in de SQL-tabel-kolom.
+                    , fldtype :: SqlType
+                    , flduse ::  SqlFieldUsage
+                    , fldnull :: Bool           -- ^ True if there can be empty field-values (intended for data dictionary of DB-implementation)
+                    , flduniq :: Bool           -- ^ True if all field-values are unique? (intended for data dictionary of DB-implementation)
+                    } deriving (Eq, Show,Typeable)
+instance Named SqlField where
+  name = fldname
+instance Unique (PlugSQL,SqlField) where
+  showUnique (p,f) = showUnique p++"."++fldname f
+instance Ord SqlField where
+  compare x y = compare (fldname x) (fldname y)
+instance ConceptStructure SqlField where
+  concs     f = [target e' |let e'=fldexpr f,isSur e']
+  expressionsIn   f = expressionsIn   (fldexpr f)
+
+data SqlType = SQLChar    Int
+             | SQLBlob              -- cannot compare, but can show (as a file)
+             | SQLPass              -- password, encrypted: cannot show, but can compare
+             | SQLSingle
+             | SQLDouble
+             | SQLText              -- cannot compare, but can show (as a text)
+             | SQLuInt    Int
+             | SQLsInt    Int
+             | SQLId                -- autoincrement integer
+             | SQLVarchar Int
+             | SQLBool              -- exists y/n
+             deriving (Eq,Show)
+
+getGeneralizations :: FSpec -> A_Concept -> [A_Concept]
+getGeneralizations fSpec = largerConcepts (vgens fSpec)
+
+getSpecializations :: FSpec -> A_Concept -> [A_Concept]
+getSpecializations fSpec = smallerConcepts (vgens fSpec)
+
+-- Lookup view by id in fSpec.
+lookupView :: FSpec -> String -> ViewDef
+lookupView fSpec viewId =
+  case filter (\v -> vdlbl v == viewId) $ vviews fSpec of
+    []   -> fatal 174 $ "Undeclared view " ++ show viewId ++ "." -- Will be caught by static analysis
+    [vd] -> vd
+    vds  -> fatal 176 $ "Multiple views with id " ++ show viewId ++ ": " ++ show (map vdlbl vds) -- Will be caught by static analysis
+
+-- Return the default view for concpt, which is either the view for concpt itself (if it has one) or the view for
+-- concpt's smallest superconcept that has a view. Return Nothing if there is no default view.
+getDefaultViewForConcept :: FSpec -> A_Concept -> Maybe ViewDef
+getDefaultViewForConcept fSpec concpt =
+  case [ vd 
+       | vd@Vd{vdcpt = c, vdIsDefault = True} <- vviews fSpec
+       ,  c `elem` (concpt : largerConcepts (vgens fSpec) concpt) 
+       ] of
+    []     -> Nothing
+    (vd:_) -> Just vd

+ src/Database/Design/Ampersand/FSpec/FSpecAux.hs view
@@ -0,0 +1,127 @@+module Database.Design.Ampersand.FSpec.FSpecAux 
+  (getDeclarationTableInfo,getConceptTableInfo)
+where
+import Database.Design.Ampersand.Basics
+import Database.Design.Ampersand.Core.AbstractSyntaxTree
+import Database.Design.Ampersand.Classes.Relational(isTrue)
+import Database.Design.Ampersand.FSpec.ToFSpec.NormalForms(disjNF)
+import Database.Design.Ampersand.FSpec.Plug(plugpath)
+import Database.Design.Ampersand.FSpec.FSpec
+import Data.List
+
+fatal :: Int -> String -> a
+fatal = fatalMsg "FSpecAux"
+
+--WHY bestaat sqlRelPlugs?
+-- | sqlRelPlugs levert alle mogelijkheden om een plug met twee velden te vinden waarin (primitieve) expressie e is opgeslagen.
+-- | sqlRelPlugs mag alleen gebruikt worden voor primitieve expressies EDcD, EDcI, en EDcV
+-- | Als (plug,sf,tf) `elem` sqlRelPlugs fSpec e, dan geldt e = (fldexpr sf)~;(fldexpr tf)
+-- | Als sqlRelPlugs fSpec e = [], dan volstaat een enkele tabel lookup niet om e te bepalen
+-- | Opletten dus, met de nieuwe ISA-structuur van 2013, omdat daarin tabellen bestaan met disjuncte verzamelingen...
+sqlRelPlugs :: FSpec -> Expression  -> [(PlugSQL,SqlField,SqlField)] --(plug,source,target)
+sqlRelPlugs fSpec e
+   = [ (plug,fld0,fld1)
+     | InternalPlug plug<-plugInfos fSpec
+     , (fld0,fld1)<-sqlPlugFields fSpec plug e
+     ]
+
+-- return table name and source and target column names for relation rel, or nothing if the relation is not found
+getDeclarationTableInfo :: FSpec -> Declaration -> (PlugSQL,SqlField,SqlField)
+getDeclarationTableInfo fSpec decl =
+ case decl of
+   Sgn{} ->
+      case sqlRelPlugs fSpec (EDcD decl) of
+            [plugInfo] -> plugInfo
+            []         -> fatal 527 "Reference to a non-existing plug."
+            [(t1,src1,trg1),(t2,src2,trg2)]
+               -> if t1 ==t2 && src1 == trg2 && trg1 == src2
+                  then (t1,src1,trg1)
+                  else fatal 426 $ "Multiple plugs for relation "++ show decl ++"\n" ++
+                            intercalate "\n\n" (map showPInfo [(t1,src1,trg1),(t2,src2,trg2)])
+            pinfos     -> fatal 428 $ "Multiple plugs for relation "++ show decl ++"\n" ++
+                            intercalate "\n\n" (map showPInfo pinfos)
+                      -- TODO: some relations return multiple plugs (see ticket #217)
+   _     -> fatal 420 "getDeclarationTableInfo must not be used on this type of declaration!"
+   where
+    showPInfo (tab, src, trg) = intercalate "  \n"
+                                 [ "Table: "++name tab
+                                 , "  sourceField: "++fldname src
+                                 , "  targetField: "++fldname trg
+                                 ]
+
+
+getConceptTableInfo :: FSpec -> A_Concept -> (PlugSQL,SqlField)
+getConceptTableInfo fSpec cpt 
+  = case lookupCpt fSpec cpt of
+      []    -> fatal 55 $ "No plug found for concept '"++name cpt++"'."
+      (x:_) -> x  --Any of the resulting plugs should do. 
+
+--iff proven that e is equivalent to plugexpr
+--   AND not proven that e is not equivalent to plugexpr
+--then return (fld0,fld1)
+--TODO -> can you prove for all e whether e is equivalent to plugexpr or not?
+sqlPlugFields :: FSpec -> PlugSQL -> Expression  -> [(SqlField, SqlField)]
+sqlPlugFields fSpec p e' =
+    let e = disjNF (getOpts fSpec) e' -- SJ20140207 Why is this normalization necessary?
+    in nub
+        [(fld0,fld1)
+        | fld0<-[f |f<-plugFields p,target (fldexpr f)==source e] --fld0 must be a field matching the source of e
+        , fld1<-[f |f<-plugFields p,target (fldexpr f)==target e] --fld1 must be a field matching the target of e
+        , Just plugexpr <- [plugpath p fld0 fld1] --the smallest expression from fld0 to fld1 (both in same plug)
+        , let se = fldexpr fld0
+              te = fldexpr fld1
+              bs = (isTrue.disjNF (getOpts fSpec)) (notCpl e .\/. flp se .:. te)    --       e |- se~;te
+              bt = (isTrue.disjNF (getOpts fSpec)) (notCpl (flp se .:. te) .\/. e)  --       se~;te |- e
+        , --reasons why e is equivalent to plugexpr:
+           --because e and plugexpr are equal
+           e==plugexpr
+     --   || because1 e fld0 fld1
+     --OR e is equivalent to plugexpr for some other reason (requires reasoning)
+        || bs && bt     ]                                          --       e = se~;te
+        {- the above should be enough.. but the relation algebra calculations
+           are not good enough yet. In particular:
+             isFalse ((I/\x);e /\ -e)
+           and
+             isTrue  ((I/\e;e~);e \/ -e)
+           do not work (these should yield True instead of False in both cases)
+
+           The code below fixes exactly these ommissions
+      --
+        || (isProp (se) && (te == e)
+           && (isTrue$disjNF (getOpts fSpec)$ let c = source e in (EDcI c ./\. simplF [e,flp e] ) .\/. notCpl se))
+        || (isProp (te) && se==flp e
+           && (isTrue$disjNF (getOpts fSpec)$ let c = source e in (EDcI c ./\. simplF [e,flp e] ) .\/. notCpl te))
+        -- found another exception:
+        --     isFalse (I;I /\ -I)
+        --   and
+        --     isTrue  (I;I \/ -I)
+        --   yield False, but should yield True
+        --
+        || (  (se == te) && isIdent e && (isSur se)  )
+        , --TODO -> reasons why e is not equivalent to plugexpr:
+        True
+        ]
+  where
+  -- simplF: replace a;a~ by I if INJ&TOT
+  simplF ks = simplify ( if null fs || null (head fs) then replF ks else replF $ head fs )
+    where fs = [ts | ECps ts <- [simplify $ ECps ks]] -- if null, replF will probably not do a lot.
+  simplF ks = case simplify (foldr1 .:. ks) of
+                 t@ECps{} -> simplify (replF (exprCps2list t))
+                 _        -> simplify (replF ks)
+           -- null occurs especialy in cases of [I;e] and [e;I]
+
+  replF [k:k2]    | k == flp k2 && isInj k && isTot k = EDcI (source k)
+  replF (k:k2:ks) | k == flp k2 && isInj k && isTot k = replF ks
+  replF [a]                                           = a
+  replF (k:k2:ks) | fs /= [k2:ks]
+   = case res of ECps{} -> replF (exprCps2list res) ; _ -> ECps (k,res)
+     where res = replF (k2:ks)
+           fs  = case res of ECps{} -> [exprCps2list res] ; _ -> []
+
+  replF [] -- this should not occur here, and if it does, it might cause errors in other code that should be solved here
+   = fatal 542 "Could not define a properly typed I for ECps[] in replF in sqlPlugFields in Prototype/RelBinGenSQL.hs"
+           -- this error does not guarantee, however, that simplF yields no ECps []. In particular: simplify (ECps [I;I]) == ECps []
+  replF ks = ECps (ks)
+  -----------------
+  -}
+                                 
+ src/Database/Design/Ampersand/FSpec/GenerateUML.hs view
@@ -0,0 +1,272 @@+module Database.Design.Ampersand.FSpec.GenerateUML (generateUML) where
+
+import Database.Design.Ampersand.Basics
+import Database.Design.Ampersand.Core.AbstractSyntaxTree (explMarkup,aMarkup2String,Rule,Declaration,Purpose(..))
+import Database.Design.Ampersand.FSpec.Graphic.ClassDiagram
+import Database.Design.Ampersand.FSpec
+import Data.Map (Map)
+import Data.List
+import qualified Data.Map as Map
+import Control.Monad.State.Lazy  (State, gets, evalState, modify)
+
+fatal :: Int -> String -> a
+fatal = fatalMsg "FSpec.GenerateUML"
+
+-- TODO: escape
+-- TODO: names of model, package, assoc (empty?), etc.
+
+generateUML :: FSpec -> String
+generateUML fSpec = showUML (fSpec2UML fSpec)
+
+showUML :: UML -> String
+showUML uml = unlines $ evalState uml $ UMLState 0 Map.empty [] []
+
+fSpec2UML :: FSpec -> UML
+fSpec2UML fSpec =
+ do { packageId0 <- mkUnlabeledId "TopPackage"
+    ; packageId1 <- mkUnlabeledId "PackageClasses"
+    ; packageId2 <- mkUnlabeledId "PackageReqs"
+    ; diagramId <- mkUnlabeledId "Diagram"
+
+    ; _ <- mapM (mkLabeledId "Datatype") datatypeNames
+    ; _ <- mapM (mkLabeledId "Class") classNames
+
+    ; datatypesUML <- mapM genUMLDatatype datatypeNames
+    ; classesUML <- mapM genUMLClass (classes classDiag)
+    ; assocsUML <- mapM genUMLAssociation (assocs classDiag)
+    ; requirementsUML <- mapM genUMLRequirement (requirements fSpec)
+    ; diagramElements <- genDiagramElements
+    ; customProfileElements <- genCustomProfileElements
+    ; customReqElements <- genCustomReqElements fSpec packageId2
+    ; return $ [ "<?xml version=\"1.0\" encoding=\"UTF-8\"?>"
+               , "<!-- Generated by "++ampersandVersionStr++" -->"
+               , "<xmi:XMI xmi:version=\"2.1\" xmlns:uml=\"http://schema.omg.org/spec/UML/2.1\" xmlns:xmi=\"http://schema.omg.org/spec/XMI/2.1\" xmlns:thecustomprofile=\"http://www.sparxsystems.com/profiles/thecustomprofile/1.0\">"
+               -- WHY is the exporter not something like `Ampersand` (in the string below)?
+               -- BECAUSE then for some reason the importer doesn't show the properties of the requirements.
+               , " <xmi:Documentation exporter=\"Enterprise Architect\" exporterVersion=\"6.5\"/>"
+               , " <uml:Model xmi:type=\"uml:Model\" name=\""++contextName++"\" visibility=\"public\">"
+               , "  <packagedElement xmi:type=\"uml:Package\" xmi:id="++show packageId0++" name="++show contextName++" visibility=\"public\">" ] ++
+               [ "   <packagedElement xmi:type=\"uml:Package\" xmi:id="++show packageId1++" name="++show ("classesOf_"++contextName)++" visibility=\"public\">" ] ++
+               concat datatypesUML ++
+               concat classesUML ++
+               concat assocsUML ++
+               [ "   </packagedElement>" ] ++
+               [ "   <packagedElement xmi:type=\"uml:Package\" xmi:id="++show packageId2++" name="++show ("RequirementsOf_"++contextName)++" visibility=\"public\">" ] ++
+               concat requirementsUML ++
+               [ "   </packagedElement>" ] ++
+               [ "  </packagedElement>" ] ++
+               customProfileElements ++
+               [ " </uml:Model>"
+               , " <xmi:Extension extender=\"Enterprise Architect\" extenderID=\"6.5\">"
+               , "  <elements>"] ++
+               [ "    <element xmi:idref="++show packageId0++" xmi:type=\"uml:Package\" name="++show contextName++" scope=\"public\">"]++
+               [ "    </element>"]++
+               [ "    <element xmi:idref="++show packageId1++" xmi:type=\"uml:Package\" name="++show ("classesOf_"++contextName)++" scope=\"public\">"]++
+               [ "     <model package2="++show packageId1++" package="++show packageId0++" tpos=\"0\" ea_eleType=\"package\"/>"]++
+               [ "    </element>"]++
+               [ "    <element xmi:idref="++show packageId2++" xmi:type=\"uml:Package\" name="++show ("RequirementsOf_"++contextName)++" scope=\"public\">"]++
+               [ "     <model package2="++show packageId2++" package="++show packageId0++" tpos=\"0\" ea_eleType=\"package\"/>"]++
+               [ "    </element>"]++
+               customReqElements ++
+               [ "  </elements>"
+               , "  <diagrams>"
+               , "   <diagram xmi:id=\""++diagramId++"\">"
+               , "    <model package=\""++packageId1++"\" owner=\""++packageId1++"\"/>"
+               , "    <properties name=\"Data Model\" type=\"Logical\"/>"
+               , "    <elements>" ] ++
+               diagramElements ++
+               [ "    </elements>"
+               , "   </diagram>"
+               , "  </diagrams>"
+               , " </xmi:Extension>"
+               , "</xmi:XMI>" ]
+    }
+ where classDiag = cdAnalysis fSpec
+       contextName = cdName classDiag
+       allConcs = ooCpts classDiag
+       classNames    = map name (classes classDiag)
+       datatypeNames = map name allConcs >- classNames
+
+genUMLRequirement :: Req -> UML
+genUMLRequirement req =
+ do { reqLId <- mkUnlabeledId "Req"
+    ; addReqToState (reqLId, req)
+    ; return $ [ "    <packagedElement xmi:type=\"uml:Class\" xmi:id=\""++reqLId++"\" name=\""++reqId req++"\" visibility=\"public\"/> " ]
+    }
+
+genUMLDatatype :: String -> UML
+genUMLDatatype nm =
+ do { datatypeId <- refLabeledId nm
+    ; addToDiagram datatypeId
+    ; return [ "    <packagedElement xmi:type=\"uml:DataType\" xmi:id=\""++datatypeId++"\" name=\""++nm++"\" visibility=\"public\"/> " ]
+    }
+
+genUMLClass :: Class -> UML
+genUMLClass cl =
+ do { classId <- refLabeledId (clName cl)
+    ; addToDiagram classId
+    ; attributesUML <- mapM genUMAttribute (clAtts cl)
+    ; return $ [ "    <packagedElement xmi:type=\"uml:Class\" xmi:id=\""++classId++"\" name=\""++clName cl++"\" visibility=\"public\">"] ++
+               concat attributesUML ++
+               [ "    </packagedElement>"]
+    }
+
+genUMAttribute :: CdAttribute -> UML
+genUMAttribute  (OOAttr nm attrType optional) =
+ do { attrId <- mkUnlabeledId "Attr"
+    ; lIntId <- mkUnlabeledId "Int"
+    ; uIntId <- mkUnlabeledId "Int"
+    ; classId <- refLabeledId attrType
+    ; return [ "       <ownedAttribute xmi:type=\"uml:Property\" xmi:id=\""++attrId++"\" name=\""++nm++"\" visibility=\"public\" isStatic=\"false\""++
+                                    " isReadOnly=\"false\" isDerived=\"false\" isOrdered=\"false\" isUnique=\"true\" isDerivedUnion=\"false\">"
+             , "        <type xmi:idref=\""++classId++"\"/>"
+             , "        <lowerValue xmi:type=\"uml:LiteralInteger\" xmi:id=\""++lIntId++"\" value=\""++(if optional then "0" else "1")++"\"/>"
+             , "        <upperValue xmi:type=\"uml:LiteralInteger\" xmi:id=\""++uIntId++"\" value=\"1\"/>"
+             , "       </ownedAttribute>"]
+    }
+
+genUMLAssociation :: Association -> UML
+genUMLAssociation ass =
+ do { assocId <- mkUnlabeledId "Assoc"
+    ; lMemberAndOwnedEnd <- genMemberAndOwnedEnd (asslhm ass) assocId (assSrc ass)
+    ; rMemberAndOwnedEnd <- genMemberAndOwnedEnd (assrhm ass) assocId (assTgt ass)
+
+    ; return $
+        [ "    <packagedElement xmi:type=\"uml:Association\" xmi:id=\""++assocId++"\" name=\""++assrhr ass++"\" visibility=\"public\">"
+        ] ++
+        lMemberAndOwnedEnd ++
+        rMemberAndOwnedEnd ++
+        [ "    </packagedElement>"
+        ]
+    }
+ where genMemberAndOwnedEnd (Mult minVal maxVal) assocId type' =
+        do { endId <- mkUnlabeledId "MemberEnd"
+           ; typeId <- refLabeledId type'
+           ; lIntId <- mkUnlabeledId "Int"
+           ; uIntId <- mkUnlabeledId "Int"
+           ; return
+               [ "     <memberEnd xmi:idref=\""++endId++"\"/>"
+               , "     <ownedEnd xmi:type=\"uml:Property\" xmi:id=\""++endId++"\" visibility=\"public\" association=\""++assocId++"\" isStatic=\"false\""++
+                              " isReadOnly=\"false\" isDerived=\"false\" isOrdered=\"false\" isUnique=\"true\" isDerivedUnion=\"false\" aggregation=\"none\">"
+               , "      <type xmi:idref=\""++typeId++"\"/>"
+               , "      <lowerValue xmi:type=\"uml:LiteralInteger\" xmi:id=\""++lIntId++"\" value=\""++(if minVal == MinZero then "0" else "1")++"\"/>"
+               , case maxVal of
+                   MaxOne  -> "      <upperValue xmi:type=\"uml:LiteralInteger\" xmi:id=\""++uIntId++"\" value=\"1\"/>"
+                   MaxMany -> "      <upperValue xmi:type=\"uml:LiteralUnlimitedNatural\" xmi:id=\""++uIntId++"\" value=\"-1\"/>"
+               , "     </ownedEnd>"
+               ]
+           }
+
+genDiagramElements :: UML
+genDiagramElements =
+ do { elementIds <- gets diagramEltIds
+    ; return [ "      <element subject=\""++elementId++"\"/>" | elementId <- elementIds ]
+    }
+
+genCustomProfileElements :: UML
+genCustomProfileElements =
+ do { reqVals <- gets reqValues
+    ; return  [reqUML req | req <- reverse reqVals]
+    }
+  where
+    reqUML :: ReqValue2 -> String
+    reqUML (xmiId, req) = intercalate "\n"
+     ( ["   <thecustomprofile:Functional base_Requirement="++show xmiId++"/>"]++
+       [tagUML xmiId count puprtxt reftxt | (count, (puprtxt, reftxt)) <- zip [0::Int ..] [(aMarkup2String (explMarkup p), intercalate ";" (explRefIds p)) | p <- reqPurposes req]]
+     )
+    tagUML xmiId nr value reftxt = intercalate "\n"
+      [ "     <thecustomprofile:"++keyMeaning++" base_Requirement="++show xmiId++" "++keyMeaning++"="++show value++"/>"
+      , "     <thecustomprofile:"++keyRef    ++" base_Requirement="++show xmiId++" "++keyRef++"="++show reftxt++"/>"
+      ]
+        where keyMeaning = "Meaning"++show nr
+              keyRef     = "Reference"++show nr
+
+genCustomReqElements :: FSpec -> String -> UML
+genCustomReqElements fSpec parentPackageId =
+ do { reqVals <- gets reqValues
+    ; return [reqUML req | req <- reverse reqVals]
+    }
+  where
+    reqUML :: ReqValue2 -> String
+    reqUML (xmiId, req) = intercalate "\n"
+     ([ "    <element xmi:idref="++show xmiId++" xmi:type=\"uml:Requirement\" name="++show (reqId req)++" scope=\"public\""++">"
+      , "      <model package="++show parentPackageId++" ea_eleType=\"element\"/>"
+      , "      <properties documentation="++show (maybe "" aMarkup2String (meaning (fsLang fSpec) req))++" isSpecification=\"false\" sType=\"Requirement\" nType=\"0\" scope=\"public\" stereotype=\"Functional\"/>"
+      , "      <tags>"]++
+      [ "         <tag name=\"Purpose"++nr++"\" value="++show p++" modelElement="++show xmiId++"/>" | (nr ,p) <- zip ("" : map show [1::Int ..]) ([aMarkup2String (explMarkup p) | p <- reqPurposes req])  ]++
+      [ "      </tags>"
+      , "    </element>"
+      ])
+
+-- Requirements
+
+data Req = Req { reqId :: String
+            --   , reqRef :: String
+               , reqOrig :: Either Rule Declaration
+               , reqPurposes :: [Purpose]
+               }
+
+instance Meaning Req where
+  meaning l r = case reqOrig r of
+                  Right rul -> meaning l rul
+                  Left  dcl -> meaning l dcl
+
+requirements :: FSpec -> [Req]
+requirements fSpec
+   = [decl2req d | d <- vrels  fSpec]
+   ++[rule2req r | r <- vrules fSpec]
+  where
+    decl2req d = Req { reqId = name d
+                     , reqOrig = Right d
+                     , reqPurposes = purposesDefinedIn fSpec (fsLang fSpec) d
+                     }
+    rule2req r = Req { reqId = name r
+                     , reqOrig = Left r
+                     , reqPurposes = purposesDefinedIn fSpec (fsLang fSpec) r
+                     }
+
+-- State and Monad
+
+data UMLState = UMLState { idCounter :: Int
+                         , labelIdMap :: Map String String
+                         , diagramEltIds :: [String]
+                         , reqValues :: [ReqValue2]
+                         }
+
+type StateUML a = State UMLState a
+
+type UML = StateUML [String]
+
+type ReqValue2 = ( String -- the xmi-id
+                , Req
+                )
+
+addToDiagram :: String -> StateUML ()
+addToDiagram elementId =
+  modify $ \state' -> state' { diagramEltIds = elementId : diagramEltIds state'}
+
+addReqToState :: ReqValue2 -> StateUML ()
+addReqToState reqVal =
+  modify $ \state' -> state' { reqValues = reqVal : reqValues state'}
+
+mkUnlabeledId :: String -> StateUML String
+mkUnlabeledId tag =
+ do { idC <- gets idCounter
+    ; modify $ \state' -> state' { idCounter = idCounter state' + 1}
+    ; let unlabeledId = tag++"ID_"++show idC
+    ; return unlabeledId
+    }
+
+refLabeledId :: String -> StateUML String
+refLabeledId label =
+ do { lidMap <- gets labelIdMap
+    ; case Map.lookup label lidMap of
+          Just lid -> return lid
+          Nothing  -> fatal 147 $ "Requesting non-existent label "++label
+    }
+
+mkLabeledId :: String -> String -> StateUML ()
+mkLabeledId tag label =
+ do { let classId = tag++"ID_"++label
+    ; modify $ \state' -> state' { labelIdMap =  Map.insert label classId (labelIdMap state') }
+    }
+ src/Database/Design/Ampersand/FSpec/Graphic/ClassDiagram.hs view
@@ -0,0 +1,527 @@+--TODO -> clean and stuff. Among which moving classdiagram2dot to Graphviz library implementation (see Classes/Graphics.hs).
+--        I only helped it on its feet and I have put in the fSpec, now it generates stuff. I like stuff :)
+
+module Database.Design.Ampersand.FSpec.Graphic.ClassDiagram
+         (ClassDiag(..), Class(..), CdAttribute(..), Association(..),
+          Aggregation(..), Generalization(..), Deleting(..), Method(..),
+          Multiplicities(..), MinValue(..), MaxValue(..),
+          clAnalysis, cdAnalysis, tdAnalysis, classdiagram2dot) where
+
+import Data.List
+import Database.Design.Ampersand.Basics
+import Database.Design.Ampersand.Classes
+import Database.Design.Ampersand.ADL1  hiding (Association,Box)
+import Database.Design.Ampersand.Core.AbstractSyntaxTree hiding (Association)
+import Database.Design.Ampersand.FSpec.Plug
+import Database.Design.Ampersand.Misc
+import Database.Design.Ampersand.FSpec.FSpec
+import Database.Design.Ampersand.FSpec.Motivations
+import Data.String
+import Data.Maybe
+import Data.Either
+import Data.GraphViz.Types.Canonical hiding (attrs)
+import Data.GraphViz.Attributes.Complete as GVcomp
+import Data.GraphViz.Attributes as GVatt
+import Data.GraphViz.Attributes.HTML as Html
+
+fatal :: Int -> String -> a
+fatal = fatalMsg "FSpec.Graphic.ClassDiagram"
+
+class CdNode a where
+ nodes :: a->[String]
+
+instance CdNode ClassDiag where
+ nodes cd = nub (concat (  map nodes (classes cd)
+                         ++map nodes (assocs  cd)
+                         ++map nodes (aggrs   cd)
+                         ++map nodes (geners  cd)
+                )       )
+
+instance CdNode Class where
+ nodes cl = [clName cl]
+instance CdNode a => CdNode [a] where
+ nodes = concatMap nodes
+
+instance CdNode CdAttribute where
+ nodes (OOAttr _ t _) = [t]
+
+instance CdNode Method where
+ nodes _ = []
+
+instance CdNode Association where
+ nodes a = [assSrc a,assTgt a]
+
+instance CdNode Aggregation where
+ nodes (OOAggr _ s t) = map name [s,t]
+
+instance CdNode Generalization where
+ nodes g = map name ((concs.genAgen) g)
+
+-- | This function makes the classification diagram.
+-- It focuses on generalizations and specializations.
+clAnalysis :: FSpec -> ClassDiag
+clAnalysis fSpec =
+    OOclassdiagram { cdName  = "classification_"++name fSpec
+                   , classes = [ OOClass { clName = name c
+                                         , clcpt  = Just ( c , [p | p<-purposesDefinedIn fSpec (fsLang fSpec) c] )
+                                         , clAtts = attrs c
+                                         , clMths = []
+                                         } | c<-cpts]
+                   , assocs  = []
+                   , aggrs   = []
+                   , geners  = map OOGener (gensInScope fSpec)
+                   , ooCpts  = concs fSpec
+                   }
+
+ where
+    cpts       = concs (gensInScope fSpec)
+    attrs c    = [ OOAttr (fldname fld) (if isPropty fld then "Bool" else  (name.target.fldexpr) fld) (fldnull fld)
+                 | plug<-lookup' c, fld<-tail (plugFields plug), not (inKernel fld), source (fldexpr fld)==c]
+                 where inKernel fld = null([Uni,Inj,Sur]>-multiplicities (fldexpr fld)) && not (isPropty fld)
+    lookup' c = [plug |InternalPlug plug@TblSQL{}<-plugInfos fSpec , (c',_)<-cLkpTbl plug, c'==c]
+    isPropty fld = null([Sym,Asy]>-multiplicities (fldexpr fld))
+
+-- | This function, cdAnalysis, generates a conceptual data model.
+-- It creates a class diagram in which generalizations and specializations remain distinct entity types.
+-- This yields more classes than plugs2classdiagram does, as plugs contain their specialized concepts.
+-- Properties and identities are not shown.
+cdAnalysis :: FSpec -> ClassDiag
+cdAnalysis fSpec =
+  OOclassdiagram { cdName  = "logical_"++name fSpec
+                 , classes =
+                     [ OOClass{ clName = name root
+                              , clcpt  = Just ( root , [p | p<-purposesDefinedIn fSpec (fsLang fSpec) root] )
+                              , clAtts = map ooAttr ooClass
+                              , clMths = []
+                              }
+                     | ooClass <- ooClasses, let root=source (head ooClass)]
+                 , assocs  = lefts assocsAndAggrs
+                 , aggrs   = rights assocsAndAggrs
+                 , geners  = map OOGener (gensInScope fSpec)
+                 , ooCpts  = roots
+                 }
+
+ where
+   ooAttr :: Expression -> CdAttribute
+   ooAttr r = OOAttr { attNm = (name . head . relsMentionedIn) r
+                     , attTyp = if isPropty r then "Bool" else (name.target) r
+                     , attOptional = (not.isTot) r
+                     }
+   isPropty r = null([Sym,Asy]>-multiplicities r)
+   mults r = let minVal = if isTot r then MinOne else MinZero
+                 maxVal = if isUni r then MaxOne else MaxMany
+             in  Mult minVal maxVal
+   topLevelDcls = vrels fSpec \\
+                  (concatMap relsDefdIn (vpatterns fSpec))
+   allDcls = topLevelDcls `uni`
+             [ d -- restricted to those themes that must be printed.
+             | d@Sgn{} <- nub . concat $
+                            [relsDefdIn p ++ relsMentionedIn p  | p <- pattsInScope fSpec ] 
+             ]
+   assocsAndAggrs = [ decl2assocOrAggr d
+                    | d <- allDcls
+                    , not.isPropty $ d
+               {- SJ 20150416: the following restriction prevents printing attribute-relations to empty boxes.
+               -}
+                    , d `notElem` attribDcls  ||
+                      ( source d `elem` nodeConcepts && target d `elem` nodeConcepts && source d/= target d )
+                    ] where family c = [c] ++ smallerConcepts (vgens fSpec) c ++ largerConcepts  (vgens fSpec) c
+                            nodeConcepts = concatMap family roots
+                            
+
+   -- Aggregates are disabled for now, as the conditions we use to regard a relation as an aggregate still seem to be too weak
+   decl2assocOrAggr :: Declaration -> Either Association Aggregation
+   --decl2assocOrAggr d | isUni d && isTot d = Right $ OOAggr {aggDel = Close, aggChild = source d, aggParent = target d}
+   --decl2assocOrAggr d | isInj d && isSur d = Right $ OOAggr {aggDel = Close, aggChild = target d, aggParent = source d}
+   decl2assocOrAggr d | otherwise          = Left $
+     OOAssoc { assSrc = name $ source d
+             , assSrcPort = name d
+             , asslhm = mults . flp $ EDcD d
+             , asslhr = ""
+             , assTgt = name $ target d
+             , assrhm = mults d
+             , assrhr = name d
+             , asspurp = purposesDefinedIn fSpec (fsLang fSpec) d
+             , assmean = meaning (fsLang fSpec) d
+             }
+   attribDcls = [ d | d <- allDcls, Aut `notElem` multiplicities d, isUni d || isInj d ]
+   attribs = [ if isInj d then flp (EDcD d) else EDcD d | d<-attribDcls ]
+   ooClasses = eqCl source attribs      -- an equivalence class wrt source yields the attributes that constitute an OO-class.
+   roots = map (source.head) ooClasses
+
+-- | This function generates a technical data model.
+-- It is based on the plugs that are calculated.
+tdAnalysis :: FSpec -> ClassDiag
+tdAnalysis fSpec =
+  OOclassdiagram {cdName  = "technical_"++name fSpec
+                 ,classes = allClasses
+                 ,assocs  = allAssocs
+                 ,aggrs   = []
+                 ,geners  = []
+                 ,ooCpts  = roots
+                 }
+  where
+   allClasses =
+      [ OOClass{ clName = sqlname table
+               , clcpt  = primKey table
+               , clAtts = case table of
+                            TblSQL{fields=attribs, cLkpTbl=kernelLookupTbl, mLkpTbl=t} -> 
+                              let kernelFlds = map snd $ kernelLookupTbl -- extract kernel fields from kernel lookup table
+                              in  map (ooAttr kernelFlds . lookInFor t . fldexpr) attribs
+                            BinSQL{columns=(a,b)}      ->
+                              [ OOAttr { attNm       = fldname a
+                                       , attTyp      = (name.target.fldexpr) a
+                                       , attOptional = False
+                                       }
+                              , OOAttr { attNm       = fldname b
+                                       , attTyp      = (name.target.fldexpr) b
+                                       , attOptional = False
+                                       }
+                              ]
+                            _     -> fatal 166 "Unexpected type of table!"
+               , clMths = []
+               }
+      | table <- tables
+      , length (plugFields table) > 1
+      ]
+
+   lookInFor [] _ = fatal 191 "Expression not found!"
+   lookInFor ((expr,_,t):xs) a
+              | expr == a = t
+              | otherwise = lookInFor xs a
+   tables = [ pSql | InternalPlug pSql <- plugInfos fSpec, not (isScalar pSql)]
+      where isScalar ScalarSQL{} = True
+            isScalar _           = False
+   roots :: [A_Concept]
+   roots = (map fst.catMaybes.map primKey) tables
+   primKey :: PlugSQL -> Maybe (A_Concept, [Purpose])
+   primKey TblSQL{fields=(f:_)} = Just (source (fldexpr f), [])  -- purposes are no longer available in the technical data model.
+   primKey _                    = Nothing
+   ooAttr :: [SqlField] -> SqlField -> CdAttribute
+   ooAttr kernelFlds f =
+     OOAttr { attNm = fldname f
+            , attTyp = if null([Sym,Asy]>-multiplicities (fldexpr f)) && (f `notElem` kernelFlds)
+                       then "Bool"
+                       else (name.target.fldexpr) f
+            , attOptional = fldnull f
+            }
+   allAssocs = filter isAssocBetweenClasses $ concatMap relsOf tables
+     where
+       isAssocBetweenClasses a = let allClassNames = map clName allClasses in assSrc a `elem` allClassNames && assTgt a `elem` allClassNames
+       
+       kernelConcepts = map fst (concatMap cLkpTbl tables)
+
+       relsOf t =
+         case t of
+           TblSQL{} -> map (mkRel t) (catMaybes [relOf fld | fld <- fields t])
+           BinSQL{columns=(a,b)} ->
+                     [ OOAssoc { assSrc = sqlname t
+                               , assSrcPort = fldname a
+                               , asslhm = Mult MinZero MaxMany
+                               , asslhr = ""
+                               , assTgt = getConceptTableFor fSpec . target . fldexpr $ a
+                               , assrhm = Mult MinOne MaxOne
+                               , assrhr = ""
+                               , asspurp = []      -- in the technical data model, the purpose is not documented.
+                               , assmean = Nothing -- in the technical data model, the meaning is not documented.
+                               }
+                     , OOAssoc { assSrc = sqlname t
+                               , assSrcPort = fldname b
+                               , asslhm = Mult MinZero MaxMany
+                               , asslhr = ""
+                               , assTgt = getConceptTableFor fSpec . target . fldexpr $ b
+                               , assrhm = Mult MinOne MaxOne
+                               , assrhr = ""
+                               , asspurp = []      -- in the technical data model, the purpose is not documented.
+                               , assmean = Nothing -- in the technical data model, the meaning is not documented.
+                               
+                               }
+                     ]
+           _  -> fatal 195 "Unexpected type of table"
+       relOf f =
+         let expr = fldexpr f in
+         case expr of
+           EDcI{} -> Nothing
+           EDcD d -> if target d `elem` kernelConcepts then Just (expr,f) else Nothing
+           EFlp (EDcD d) -> if source d `elem` kernelConcepts then Just (expr,f) else Nothing
+           _ -> fatal 200 ("Unexpected expression: "++show expr)
+       mkRel :: PlugSQL -> (Expression,SqlField) -> Association
+       mkRel t (expr,f) =
+            OOAssoc { assSrc = sqlname t
+                    , assSrcPort = fldname f
+                    , asslhm = (mults.flp) expr
+                    , asslhr = fldname f
+                    , assTgt = getConceptTableFor fSpec (target expr)
+                    , assrhm = mults expr
+                    , assrhr = case [name d | d@Sgn{}<-relsMentionedIn expr] of h:_ -> h ; _ -> fatal 229 "no relations used in expr"
+                    , asspurp = [] -- in the technical data model, the purpose is not documented.
+                    , assmean = Nothing -- in the technical data model, the meaning is not documented.
+                    }
+   mults r = let minVal = if isTot r then MinOne else MinZero
+                 maxVal = if isUni r then MaxOne else MaxMany
+             in  Mult minVal maxVal
+
+---- In order to make classes, all relations that are univalent and injective are flipped
+---- attRels contains all relations that occur as attributes in classes.
+--       attRels    = [r |r<-rels, isUni r, not (isInj r)]        ++[flp r |r<-rels, not (isUni r), isInj r] ++
+--                    [r |r<-rels, isUni r,      isInj r, isSur r]++[flp r |r<-rels,      isUni r , isInj r, not (isSur r)]
+---- assRels contains all relations that do not occur as attributes in classes
+--       assRels    = [r |r<-relsLim, not (isUni r), not (isInj r)]
+--       attrs rs   = [ OOAttr ((name.head.relsMentionedIn) r) (name (target r)) (not(isTot r))
+--                    | r<-rs, not (isPropty r)]
+--       isPropty r = null([Sym,Asy]>-multiplicities r)
+
+-- | translate a ClassDiagram to a DotGraph, so it can be used to show it as a picture.
+classdiagram2dot :: Options -> ClassDiag -> DotGraph String
+classdiagram2dot opts cd
+ = DotGraph { strictGraph     = False
+            , directedGraph   = True
+            , graphID         = Nothing
+            , graphStatements = 
+                    DotStmts
+                        { attrStmts =  [ GraphAttrs [ RankDir FromLeft
+                                                    , bgColor White]
+                                       ]
+                                --    ++ [NodeAttrs  [ ]]
+                                    ++ [EdgeAttrs  [ FontSize 11
+                                                   , MinLen 4
+                                       ]           ]
+                        , subGraphs = []
+                        , nodeStmts = allNodes (classes cd) (nodes cd >- nodes (classes cd))
+                        , edgeStmts = (map association2edge (assocs cd))  ++
+                                      (map aggregation2edge (aggrs cd))  ++
+                                      (concatMap generalization2edges (geners cd))
+                        }
+            }
+     where
+       allNodes :: [Class] -> [String] -> [DotNode String]
+       allNodes cs others =
+          map class2node cs ++
+          map nonClass2node others
+
+       class2node :: Class -> DotNode String
+       class2node cl = DotNode
+         { nodeID         = name cl
+         , nodeAttributes = [ Shape PlainText
+                            , GVcomp.Color [WC (X11Color Purple) Nothing]
+                            , Label (HtmlLabel (Table htmlTable))
+                            ]
+         } where
+          htmlTable = HTable { tableFontAttrs = Nothing
+                             , tableAttrs     = [ Html.BGColor (X11Color White)
+                                                , Html.Color (X11Color Black) -- the color used for all cellborders
+                                                , Html.Border 0  -- 0 = no border
+                                                , CellBorder 1
+                                                , CellSpacing 0
+                                                ]
+                             , tableRows      = [ Cells -- Header row, containing the name of the class
+                                                   [ LabelCell
+                                                         [ Html.BGColor (X11Color Gray10)
+                                                         , Html.Color   (X11Color Black)
+                                                         ]
+                                                         (Html.Text [ Html.Font [ Html.Color   (X11Color White)
+                                                                              ]
+                                                                              [Html.Str (fromString (name cl))]
+                                                                   ]
+                                                         )
+                                                   ]
+                                                ]++
+                                                map attrib2row (clAtts cl) ++
+                                                map method2row (clMths cl)
+
+                             }
+              where
+                attrib2row a = Cells
+                                 [ Html.LabelCell [ Html.Align HLeft
+                                                  , (Port .PN .fromString) (attNm a)
+                                                  ]
+                                      ( Html.Text [ Html.Str (fromString (if attOptional a then "o " else "+ "))
+                                                  , Html.Str (fromString (name a))
+                                                  , Html.Str (fromString " : ")
+                                                  , Html.Str (fromString (attTyp a))
+                                                  ]
+                                      )
+                                 ]
+                method2row m = Cells
+                                 [ Html.LabelCell [ Html.Align HLeft]
+                                      ( Html.Text [ Html.Str (fromString "+ ")
+                                                  , Html.Str (fromString (show m))
+                                                  ]
+                                      )
+                                 ]
+
+       nonClass2node :: String -> DotNode String
+       nonClass2node str = DotNode { nodeID = str
+                                   , nodeAttributes = [ Shape Box3D
+                                                      , Label (StrLabel (fromString str))
+                                                      ]
+                                   }
+
+-------------------------------
+--        ASSOCIATIONS:      --
+-------------------------------
+       association2edge :: Association -> DotEdge String
+       association2edge ass =
+          DotEdge { fromNode       = assSrc ass
+                  , toNode         = assTgt ass
+                  , edgeAttributes = [ ArrowHead (AType [(ArrMod OpenArrow BothSides, NoArrow)])  -- No arrowHead
+                                     , HeadLabel (mult2Lable (assrhm ass))
+                                     , TailLabel (mult2Lable (asslhm ass))
+                                     , Label     (StrLabel (fromString (assrhr ass)))
+                                     , LabelFloat True
+                                     ]
+                                   ++[(TailPort (LabelledPort (PN ((fromString.assSrcPort) ass)) Nothing))]
+                  }
+           where
+              mult2Lable = StrLabel . fromString . mult2Str
+              mult2Str (Mult MinZero MaxOne)  = "0-1"
+              mult2Str (Mult MinZero MaxMany) = "*"
+              mult2Str (Mult MinOne  MaxOne)  = "1"
+              mult2Str (Mult MinOne  MaxMany) = "1-*"
+
+-------------------------------
+--        AGGREGATIONS:      --
+-------------------------------
+       aggregation2edge :: Aggregation -> DotEdge String
+       aggregation2edge agg =
+          DotEdge { fromNode       = name . aggChild  $ agg
+                  , toNode         = name . aggParent $ agg
+                  , edgeAttributes = [ ArrowHead (AType [(ArrMod (case aggDel agg of
+                                                                   Open -> OpenArrow
+                                                                   Close -> FilledArrow
+                                                                 ) BothSides , Diamond)
+                                                        ])
+                                     ]
+                  }
+
+-------------------------------
+--        GENERALIZATIONS:   --       -- Ampersand statements such as "SPEC Dolphin ISA Animal" are called generalization.
+--                           --       -- Generalizations are represented by a red arrow with a (larger) open triangle as arrowhead
+-------------------------------
+       generalization2edges :: Generalization -> [DotEdge String]
+       generalization2edges ooGen = sub2edges (genAgen ooGen)
+        where
+          sub2edges gen
+           = [DotEdge { fromNode = name spec
+                      , toNode   = name gener
+                      , edgeAttributes
+                                 = [ ArrowHead (AType [(ArrMod OpenArrow BothSides, Normal)])   -- Open normal arrowHead
+                                   , ArrowSize  2.0
+                                   ] ++
+                                   ( if blackWhite opts
+                                     then [Style [SItem Dashed []]]
+                                     else [GVcomp.Color [WC (X11Color Red) Nothing]]
+                                   )
+                      }
+             | (spec,gener)<-splits gen]
+          splits gen = case gen of
+                               Isa{} -> [(genspc gen, gengen gen)]
+                               IsE{} -> [(genspc gen, x ) | x<-(genrhs gen)]
+
+-------------- Class Diagrams ------------------
+data ClassDiag = OOclassdiagram {cdName :: String
+                                ,classes :: [Class]           --
+                                ,assocs :: [Association]      --
+                                ,aggrs ::  [Aggregation]      --
+                                ,geners :: [Generalization]   --
+                                ,ooCpts :: [A_Concept]}
+                         deriving Show
+instance Named ClassDiag where
+   name = cdName
+
+data Class          = OOClass  { clName :: String          -- ^ name of the class
+                               , clcpt ::  Maybe (A_Concept, [Purpose]) -- ^ Main concept of the class. (link tables do not have a main concept)
+                               , clAtts :: [CdAttribute]   -- ^ Attributes of the class
+                               , clMths :: [Method]        -- ^ Methods of the class
+                               } deriving Show
+instance Named Class where
+   name = clName
+data CdAttribute    = OOAttr   { attNm :: String            -- ^ name of the attribute
+                               , attTyp :: String           -- ^ type of the attribute (Concept name or built-in type)
+                               , attOptional :: Bool        -- ^ says whether the attribute is optional
+                               } deriving Show
+instance Named CdAttribute where
+   name = attNm
+data MinValue = MinZero | MinOne deriving (Show, Eq)
+
+data MaxValue = MaxOne | MaxMany deriving (Show, Eq)
+
+data Multiplicities = Mult MinValue MaxValue deriving Show
+
+data Association    = OOAssoc  { assSrc ::     String           -- ^ source: the name of the source class
+                               , assSrcPort :: String           -- ^ the name of the attribute in the source class
+                               , asslhm ::     Multiplicities   -- ^ left hand side multiplicities
+                               , asslhr ::     String           -- ^ left hand side role
+                               , assTgt ::     String           -- ^ target: the name of the target class
+                               , assrhm ::     Multiplicities   -- ^ right hand side multiplicities
+                               , assrhr ::     String           -- ^ right hand side role
+                               , asspurp ::    [Purpose]        -- ^ purposes of this association
+                               , assmean ::    Maybe A_Markup   -- ^ meaning, if available.
+                               } deriving Show
+data Aggregation    = OOAggr   { aggDel :: Deleting             --
+                               , aggChild  :: A_Concept         --
+                               , aggParent :: A_Concept         --
+                               } deriving (Show, Eq)
+data Generalization = OOGener  { genAgen :: A_Gen               --
+                               } deriving (Show)
+
+data Deleting       = Open | Close                      --
+                                 deriving (Show, Eq)
+data Method         = OOMethodC      String             -- name of this method, which creates a new object (producing a handle)
+                                     [CdAttribute]      -- list of parameters: attribute names and types
+                    | OOMethodR      String             -- name of this method, which yields the attribute values of an object (using a handle).
+                                     [CdAttribute]      -- list of parameters: attribute names and types
+                    | OOMethodS      String             -- name of this method, which selects an object using key attributes (producing a handle).
+                                     [CdAttribute]      -- list of parameters: attribute names and types
+                    | OOMethodU      String             -- name of this method, which updates an object (using a handle).
+                                     [CdAttribute]      -- list of parameters: attribute names and types
+                    | OOMethodD      String             -- name of this method, which deletes an object (using nothing but a handle).
+                    | OOMethod       String             -- name of this method, which deletes an object (using nothing but a handle).
+                                     [CdAttribute]      -- list of parameters: attribute names and types
+                                     String             -- result: a type
+
+instance Show Method where
+  showsPrec _ (OOMethodC nm cs)  = showString (nm++"("++intercalate "," [ n | OOAttr n _ _<-cs]++"):handle")
+  showsPrec _ (OOMethodR nm as)  = showString (nm++"(handle):["++intercalate "," [ n | OOAttr n _ _<-as]++"]")
+  showsPrec _ (OOMethodS nm ks)  = showString (nm++"("++intercalate "," [ n | OOAttr n _ _<-ks]++"):handle")
+  showsPrec _ (OOMethodD nm)     = showString (nm++"(handle)")
+  showsPrec _ (OOMethodU nm cs)  = showString (nm++"(handle,"++intercalate "," [ n | OOAttr n _ _<-cs]++")")
+  showsPrec _ (OOMethod nm cs r) = showString (nm++"("++intercalate "," [ n | OOAttr n _ _<-cs]++"): "++r)
+
+--
+--   testCD
+--    = OOclassdiagram
+--      [ OOClass "Plan" [ooAttr "afkomst" "Actor"] []
+--      , OOClass "Formulier" [ooAttr "plan" "Plan",ooAttr "van" "Actor",ooAttr "aan" "Actor",ooAttr "sessie" "Sessie"] []
+--      , OOClass "Dossier" [ooAttr "eigenaar" "Actor"] []
+--      , OOClass "Gegeven" [ooAttr "type" "Gegevenstype",ooAttr "in" "Dossier",ooAttr "veldnaam" "Veldnaam",ooAttr "waarde" "Waarde"] []
+--      , OOClass "Veld" [ooAttr "type" "Veldtype",ooAttr "waarde" "Waarde"] []
+--      , OOClass "Veldtype" [ooAttr "veldnaam" "Veldnaam",ooAttr "formuliertype" "Plan",ooAttr "gegevenstype" "Gegevenstype"] []
+--      , OOClass "Sessie" [ooAttr "dossier" "Dossier",ooAttr "uitgevoerd" "Actor"] []
+--      ]
+--      [ OOAssoc "Plan" "0..n" "" "Plan" "0..n" "stap"
+--      , OOAssoc "Formulier" "0..n" "" "Actor" "0..n" "inzage"
+--      , OOAssoc "Formulier" "0..n" "" "Formulier" "0..n" "in"
+--      , OOAssoc "Formulier" "0..n" "" "Plan" "0..n" "stap"
+--      , OOAssoc "Autorisatie" "0..n" "" "Actor" "0..n" "aan"
+--      , OOAssoc "Gegeven" "0..n" "" "Formulier" "0..n" "op"
+--      , OOAssoc "Gegeven" "0..n" "" "Actor" "0..n" "inzage"
+--      , OOAssoc "Actor" "0..n" "" "Actor" "0..n" "gedeeld"
+--      , OOAssoc "Formulier" "0..n" "" "Actor" "0..n" "inzagerecht"
+--      , OOAssoc "Gegeven" "0..n" "" "Actor" "0..n" "inzagerecht"
+--      , OOAssoc "Autorisatie" "0..n" "" "Gegeven" "0..n" "object"
+--      , OOAssoc "Actie" "0..n" "" "Gegeven" "0..n" "object"
+--      , OOAssoc "Autorisatie" "0..n" "" "Actie" "0..n" "op"
+--      , OOAssoc "Autorisatie" "0..n" "" "Actor" "0..n" "door"
+--      , OOAssoc "Actie" "0..n" "" "Actor" "0..n" "door"
+--      , OOAssoc "Veld" "0..n" "" "Gegeven" "0..n" "bindt"
+--      , OOAssoc "Sessie" "0..1" "" "Actor" "0..1" "actief"
+--      , OOAssoc "Formulier" "0..n" "" "Actor" "0..n" "openstaand"
+--      , OOAssoc "Gegeven" "0..n" "" "Actor" "0..n" "openstaand"
+--      ]
+--      [ OOAggr Close "Dossier" "Formulier"
+--      , OOAggr Close "Formulier" "Veld"
+--      ]
+--      []
+--      ("NoPat",[])
+--      where ooAttr nm t = OOAttr nm t True

+ src/Database/Design/Ampersand/FSpec/Graphic/Graphics.hs view
@@ -0,0 +1,514 @@+module Database.Design.Ampersand.FSpec.Graphic.Graphics
+          (makePicture, writePicture, Picture(..), PictureReq(..),imagePath
+    )where
+
+import Data.GraphViz
+import Database.Design.Ampersand.ADL1
+import Database.Design.Ampersand.FSpec.FSpec
+import Database.Design.Ampersand.Classes
+import Database.Design.Ampersand.FSpec.Switchboard
+import Database.Design.Ampersand.Misc
+import Database.Design.Ampersand.Basics
+import Database.Design.Ampersand.FSpec.Graphic.ClassDiagram -- (ClassDiag,classdiagram2dot)
+import Data.GraphViz.Attributes.Complete
+import Data.List
+import Data.String
+
+import System.FilePath hiding (addExtension)
+import System.Directory
+
+fatal :: Int -> String -> a
+fatal = fatalMsg "FSpec.Graphic.Graphics"
+
+data PictureReq = PTClassDiagram
+                | PTRelsUsedInPat Pattern
+                | PTDeclaredInPat Pattern
+                | PTConcept A_Concept
+                | PTSwitchBoard Activity
+                | PTFinterface Activity
+                | PTIsaInPattern Pattern  -- Not used at all...
+                | PTSingleRule Rule
+                | PTLogicalDM
+                | PTTechnicalDM
+
+data Picture = Pict { pType :: PictureReq             -- ^ the type of the picture
+                    , scale :: String                 -- ^ a scale factor, intended to pass on to LaTeX, because Pandoc seems to have a problem with scaling.
+                    , dotSource :: DotGraph String    -- ^ the string representing the .dot
+                    , dotProgName :: GraphvizCommand  -- ^ the name of the program to use  ("dot" or "neato" or "fdp" or "Sfdp")
+                    , caption :: String               -- ^ a human readable name of this picture
+                    }
+
+makePicture :: FSpec -> PictureReq -> Picture
+makePicture fSpec pr =
+  case pr of
+   PTClassDiagram      -> Pict { pType = pr
+                               , scale = scale'
+                               , dotSource = classdiagram2dot (getOpts fSpec) (clAnalysis fSpec)
+                               , dotProgName = Dot
+                               , caption =
+                                   case fsLang fSpec of
+                                      English -> "Classification of " ++ name fSpec
+                                      Dutch   -> "Classificatie van " ++ name fSpec
+                               }
+   PTLogicalDM         -> Pict { pType = pr
+                               , scale = scale'
+                               , dotSource = classdiagram2dot (getOpts fSpec) (cdAnalysis fSpec)
+                               , dotProgName = Dot
+                               , caption =
+                                   case fsLang fSpec of
+                                      English -> "Logical data model of " ++ name fSpec
+                                      Dutch   -> "Logisch gegevensmodel van " ++ name fSpec
+                               }
+   PTTechnicalDM       -> Pict { pType = pr
+                               , scale = scale'
+                               , dotSource = classdiagram2dot (getOpts fSpec) (tdAnalysis fSpec)
+                               , dotProgName = Dot
+                               , caption =
+                                   case fsLang fSpec of
+                                      English -> "Technical data model of " ++ name fSpec
+                                      Dutch   -> "Technisch gegevensmodel van " ++ name fSpec
+                               }
+   PTConcept cpt       -> Pict { pType = pr
+                               , scale = scale'
+                               , dotSource = conceptualGraph' fSpec pr
+                               , dotProgName = graphVizCmdForConceptualGraph
+                               , caption =
+                                   case fsLang fSpec of
+                                      English -> "Concept diagram of the rules about " ++ name cpt
+                                      Dutch   -> "Conceptueel diagram van de regels rond " ++ name cpt
+                               }
+   PTDeclaredInPat pat -> Pict { pType = pr
+                               , scale = scale'
+                               , dotSource = conceptualGraph' fSpec pr
+                               , dotProgName = graphVizCmdForConceptualGraph
+                               , caption =
+                                   case fsLang fSpec of
+                                      English -> "Concept diagram of relations in " ++ name pat
+                                      Dutch   -> "Conceptueel diagram van relaties in " ++ name pat
+                               }
+   PTIsaInPattern pat  -> Pict { pType = pr
+                               , scale = scale'
+                               , dotSource = conceptualGraph' fSpec pr
+                               , dotProgName = graphVizCmdForConceptualGraph
+                               , caption =
+                                   case fsLang fSpec of
+                                      English -> "Classifications of " ++ name pat
+                                      Dutch   -> "Classificaties van " ++ name pat
+                               }
+   PTRelsUsedInPat pat -> Pict { pType = pr
+                               , scale = scale'
+                               , dotSource = conceptualGraph' fSpec pr
+                               , dotProgName = graphVizCmdForConceptualGraph
+                               , caption =
+                                   case fsLang fSpec of
+                                      English -> "Concept diagram of the rules in " ++ name pat
+                                      Dutch   -> "Conceptueel diagram van de regels in " ++ name pat
+                               }
+   PTFinterface act    -> Pict { pType = pr
+                               , scale = scale'
+                               , dotSource = conceptualGraph' fSpec pr
+                               , dotProgName = graphVizCmdForConceptualGraph
+                               , caption =
+                                   case fsLang fSpec of
+                                      English -> "Concept diagram of interface " ++ name act
+                                      Dutch   -> "Conceptueel diagram van interface " ++ name act
+                               }
+   PTSingleRule rul    -> Pict { pType = pr
+                               , scale = scale'
+                               , dotSource = conceptualGraph' fSpec pr
+                               , dotProgName = graphVizCmdForConceptualGraph
+                               , caption =
+                                   case fsLang fSpec of
+                                      English -> "Concept diagram of rule " ++ name rul
+                                      Dutch   -> "Conceptueel diagram van regel " ++ name rul
+                               }
+   PTSwitchBoard act   -> Pict { pType = pr
+                               , scale = scale'
+                               , dotSource = sbdotGraph (switchboardAct fSpec act)
+                               , dotProgName = graphVizCmdForConceptualGraph
+                               , caption =
+                                   case fsLang fSpec of
+                                      English -> "Switchboard diagram of " ++ name act
+                                      Dutch   -> "Schakelpaneel van " ++ name act
+                               }
+ where
+   scale' =
+      case pr of
+            PTClassDiagram -> "1.0"
+            PTRelsUsedInPat{}-> "0.7"
+            PTDeclaredInPat{}-> "0.5"
+            PTSwitchBoard{}  -> "0.4"
+            PTIsaInPattern{} -> "0.7"
+            PTSingleRule{}   -> "0.7"
+            PTConcept{}      -> "0.7"
+            PTFinterface{}   -> "0.7"
+            PTLogicalDM    -> "1.2"
+            PTTechnicalDM  -> "1.2"
+   graphVizCmdForConceptualGraph = Sfdp
+
+pictureID :: PictureReq -> String
+pictureID pr =
+     case pr of
+      PTClassDiagram   -> "Classification"
+      PTLogicalDM      -> "LogicalDataModel"
+      PTTechnicalDM    -> "TechnicalDataModel"
+      PTConcept cpt    -> "RulesWithConcept"++name cpt
+      PTDeclaredInPat pat -> "RelationsInPattern"++name pat
+      PTIsaInPattern  pat -> "IsasInPattern"++name pat
+      PTRelsUsedInPat pat -> "RulesInPattern"++name pat
+      PTFinterface act    -> "KnowledgeGraph"++name act
+      PTSwitchBoard x     -> "SwitchBoard"++name x
+      PTSingleRule r      -> "SingleRule"++name r
+
+conceptualGraph' :: FSpec -> PictureReq -> DotGraph String
+conceptualGraph' fSpec pr = conceptual2Dot (getOpts fSpec) cstruct
+  where
+    cstruct =
+      case pr of
+        PTConcept c ->
+          let gs = fsisa fSpec
+              cpts' = concs rs
+              rs    = [r | r<-vrules fSpec, c `elem` concs r]
+          in
+          CStruct { csCpts = nub$cpts' ++ [g |(s,g)<-gs, elem g cpts' || elem s cpts'] ++ [s |(s,g)<-gs, elem g cpts' || elem s cpts']
+                  , csRels = [r | r@Sgn{} <- relsMentionedIn rs   -- the use of "relsMentionedIn" restricts relations to those actually used in rs
+                             , not (isProp r)
+                             ]
+                  , csIdgs = [(s,g) |(s,g)<-gs, elem g cpts' || elem s cpts']  --  all isa edges
+                  }
+        --  PTRelsUsedInPat makes a picture of at least the relations within pat;
+        --  extended with a limited number of more general concepts;
+        --  and rels to prevent disconnected concepts, which can be connected given the entire context.
+        PTRelsUsedInPat pat ->
+          let orphans = [c | c<-cpts, not(c `elem` map fst idgs || c `elem` map snd idgs || c `elem` map source rels  || c `elem` map target rels)]
+              xrels = nub [r | c<-orphans, r@Sgn{}<-vrels fSpec
+                        , (c == source r && target r `elem` cpts) || (c == target r  && source r `elem` cpts)
+                        , source r /= target r, decusr r
+                        ]
+              idgs = [(s,g) |(s,g)<-gs, g `elem` cpts, s `elem` cpts]    --  all isa edges within the concepts
+              gs   = fsisa fSpec
+              cpts = cpts' `uni` [g |cl<-eqCl id [g |(s,g)<-gs, s `elem` cpts'], length cl<3, g<-cl] -- up to two more general concepts
+              cpts' = concs pat `uni` concs rels
+              rels = [r | r@Sgn{}<-relsMentionedIn pat
+                             , not (isProp r)    -- r is not a property
+                             ]
+          in
+          CStruct { csCpts = cpts' `uni` [g |cl<-eqCl id [g |(s,g)<-gs, s `elem` cpts'], length cl<3, g<-cl] -- up to two more general concepts
+                  , csRels = rels `uni` xrels -- extra rels to connect concepts without rels in this picture, but with rels in the fSpec
+                  , csIdgs = idgs
+                  }
+
+        -- PTDeclaredInPat makes a picture of relations and gens within pat only
+        PTDeclaredInPat pat ->
+          let gs   = fsisa fSpec
+              cpts = concs decs `uni` concs (gens pat)
+              decs = relsDefdIn pat `uni` relsMentionedIn (udefrules pat)
+          in
+          CStruct { csCpts = cpts
+                  , csRels = [r | r@Sgn{}<-decs
+                             , not (isProp r), decusr r    -- r is not a property
+                             ]
+                  , csIdgs = [(s,g) |(s,g)<-gs, g `elem` cpts, s `elem` cpts]    --  all isa edges within the concepts
+                  }
+        PTIsaInPattern pat ->
+          let gs    = fsisa fSpec
+              cpts  = concs edges
+              cpts' = concs pat >- concs gs
+              edges = clos gs idgs
+              idgs  = [(s,g) |(s,g)<-gs, elem g cpts' || elem s cpts']  --  all isa edges
+              clos tuples ts = f (tuples>-ts) ts []
+               where f  []  new result = result++new
+                     f  _   []  result = result
+                     f tups new result = f (tups>-new) [ t |t<-tups, (not.null) (concs t `isc` concs result') ] result'
+                                             where result' = result++new
+          in
+          CStruct { csCpts = cpts
+                  , csRels = []
+                  , csIdgs = idgs
+                  }
+
+        PTFinterface ifc ->
+          let gs   = fsisa fSpec
+              cpts = nub $ cpts' ++ [c |(s,g)<-idgs, c<-[g,s]]
+              cpts'  = concs rs
+              rs         = filter affected (vrules fSpec)
+              affected r = (not.null) [d | d@Sgn{} <- relsMentionedIn r `isc` relsMentionedIn ifc]
+              idgs = [(s,g) |(s,g)<-gs, elem g cpts' || elem s cpts']  --  all isa edges
+              rels = [r | r@Sgn{}<-relsMentionedIn ifc, decusr r
+                        , not (isProp r)    -- r is not a property
+                     ]
+          in
+          CStruct { csCpts = cpts -- involve all concepts involved either in the affected rules or in the isa-links
+                  , csRels = rels
+                  , csIdgs = idgs -- involve all isa links from concepts touched by one of the affected rules
+                  }
+        PTSingleRule r ->
+          let idgs = [(s,g) | (s,g)<-fsisa fSpec
+                     , g `elem` concs r || s `elem` concs r]  --  all isa edges
+          in
+          CStruct { csCpts = nub $ concs r++[c |(s,g)<-idgs, c<-[g,s]]
+                  , csRels = [d | d@Sgn{}<-relsMentionedIn r, decusr d
+                             , not (isProp d)    -- d is not a property
+                             ]
+                  , csIdgs = idgs -- involve all isa links from concepts touched by one of the affected rules
+                  }
+        _  -> fatal 276 "No conceptual graph defined for this type."
+
+writePicture :: Options -> Picture -> IO()
+writePicture opts pict
+    = sequence_ (
+      [createDirectoryIfMissing True  (takeDirectory (imagePath opts pict)) | genAtlas opts ]++
+      [writeDot Canon  | {- genFSpec opts || -} genAtlas opts ]++
+--      [writeDot XDot   | genFSpec opts || genAtlas opts ]++
+      [writeDot Png    | genFSpec opts || genAtlas opts ]++
+      [writeDot Cmapx  |                   genAtlas opts ]
+          )
+   where
+     writeDot :: GraphvizOutput
+              -> IO ()
+     writeDot  gvOutput  =
+         do verboseLn opts ("Generating "++show gvOutput++" using "++show gvCommand++".")
+            path <- addExtension (runGraphvizCommand gvCommand (dotSource pict)) gvOutput ((dropExtension . imagePath opts) pict)
+            verboseLn opts (path++" written.")
+       where  gvCommand = dotProgName pict
+
+class ReferableFromPandoc a where
+  imagePath :: Options -> a -> FilePath   -- ^ the full file path to the image file
+
+instance ReferableFromPandoc Picture where
+  imagePath opts p =
+     (if genAtlas opts then dirPrototype opts </> "images" else dirOutput opts)
+     </> (escapeNonAlphaNum . pictureID . pType ) p <.> "png"
+
+class Named a => Navigatable a where
+   interfacename :: a -> String
+   itemstring :: a -> String
+   theURL :: Options -> a -> EscString    -- url of the web page in Atlas used when clicked on a node or edge in a .map file
+   theURL opts x
+     = fromString ("Atlas.php?content=" ++ interfacename x
+                   ++  "&User=" ++ user
+                   ++  "&Script=" ++ script
+                   ++  "&"++interfacename x ++"="++qualify++itemstring x
+                  )
+      where --copied from atlas.hs
+      script = fileName opts
+      user = namespace opts
+      qualify = "("++user ++ "." ++ script ++ ")"
+
+instance Navigatable A_Concept where
+   interfacename _ = "Concept" --see Atlas.adl
+   itemstring = name  --copied from atlas.hs
+
+instance Navigatable Declaration where
+   interfacename _ = "Relatiedetails"
+   itemstring x = name x ++ "["
+                  ++ (if source x==target x then name(source x) else name(source x)++"*"++name(target x))
+                  ++ "]"
+
+data ConceptualStructure = CStruct { csCpts :: [A_Concept]               -- ^ The concepts to draw in the graph
+                                   , csRels :: [Declaration]   -- ^ The relations, (the edges in the graph)
+                                   , csIdgs :: [(A_Concept, A_Concept)]  -- ^ list of Isa relations
+                                   }
+
+conceptual2Dot :: Options -> ConceptualStructure -> DotGraph String
+conceptual2Dot opts (CStruct cpts' rels idgs)
+     = DotGraph { strictGraph = False
+                , directedGraph = True
+                , graphID = Nothing
+                , graphStatements
+                      = DotStmts { attrStmts = [GraphAttrs (handleFlags TotalPicture opts)]
+                                 , subGraphs = []
+                                 , nodeStmts = conceptNodes ++ relationNodes
+                                 , edgeStmts = relationEdges ++ isaEdges
+                                 }
+                }
+       where
+        cpts = cpts' `uni` concs rels `uni` concs idgs
+        conceptNodes = [constrNode (baseNodeId c) (CptOnlyOneNode c) opts | c<-cpts]
+        (relationNodes,relationEdges) = (concat a, concat b)
+              where (a,b) = unzip [relationNodesAndEdges r | r<-zip rels [1..]]
+        isaEdges = [constrEdge (baseNodeId s) (baseNodeId g) IsaOnlyOneEdge opts | (s,g)<-idgs]
+
+        baseNodeId :: A_Concept -> String  -- returns the NodeId of the node where edges to this node should connect to.
+        baseNodeId c
+            = case lookup c (zip cpts [(1::Int)..]) of
+                Just i -> "cpt_"++show i
+                _      -> fatal 169 $ "element "++name c++" not found by nodeLabel."
+
+        -- | This function constructs a list of NodeStatements that must be drawn for a concept.
+        relationNodesAndEdges ::
+             (Declaration,Int)           -- ^ tuple contains the declaration and its rank
+          -> ([DotNode String],[DotEdge String]) -- ^ the resulting tuple contains the NodeStatements and EdgeStatements
+        relationNodesAndEdges (r,n)
+          | doubleEdges opts
+             = (  [ relNameNode ]    -- node to place the name of the relation
+               ,  [ constrEdge (baseNodeId (source r)) (nodeID relNameNode)   (RelSrcEdge r) opts     -- edge to connect the source with the hinge
+                  , constrEdge (nodeID relNameNode)   (baseNodeId (target r)) (RelTgtEdge r) opts]     -- edge to connect the hinge to the target
+               )
+          | otherwise
+               = ( [] --No intermediate node
+                 , [constrEdge (baseNodeId (source r)) (baseNodeId (target r)) (RelOnlyOneEdge r)  opts]
+                 )
+          where
+        --    relHingeNode   = constrNode ("relHinge_"++show n) RelHingeNode   opts
+            relNameNode    = constrNode ("relName_"++show n) (RelIntermediateNode r) opts
+
+constrNode :: a -> PictureObject -> Options -> DotNode a
+constrNode nodeId pObj opts
+  = DotNode { nodeID = nodeId
+            , nodeAttributes = [ FontSize 10
+                               , FontName (fromString(pangoFont opts))
+                           --    , Width 0.1
+                           --    , Height  0.1
+                               ]++handleFlags pObj opts
+            }
+
+constrEdge :: a -> a -> PictureObject -> Options -> DotEdge a
+constrEdge nodeFrom nodeTo pObj opts
+  = DotEdge { fromNode = nodeFrom
+            , toNode   = nodeTo
+            , edgeAttributes = [ FontSize 12
+                               , FontName (fromString(pangoFont opts))
+                               , Dir Forward
+                            --   , LabelAngle (-25.0)
+                               , Color [WC(X11Color Gray35)Nothing]
+                               , LabelFontColor (X11Color Black)
+                               , LabelFloat False
+                               , Decorate False
+                            --   , LabelDistance 2.0
+                            --   , (HeadLabel . StrLabel . fromString) "Test"
+                               ]++handleFlags pObj opts
+            }
+--DESCR -> a picture consists of arcs (relations), concepts, and ISA relations between concepts
+--         arcs are attached to a source or target concept
+--         arcs and concepts are points attached to a label
+-- for Haddock support on GraphViz, click on:
+--       http://hackage.haskell.org/packages/archive/graphviz/2999.6.0.0/doc/html/doc-index.html     or
+--       http://hackage.haskell.org/packages/archive/graphviz/latest/doc/html/doc-index.html
+
+data PictureObject = CptOnlyOneNode A_Concept    -- ^ Node of a concept that serves as connector and shows the name
+                   | CptConnectorNode A_Concept  -- ^ Node of a concept that serves as connector of relations to that concept
+                   | CptNameNode A_Concept       -- ^ Node of a concept that shows the name
+                   | CptEdge                     -- ^ Edge of a concept to connect its nodes
+                   | RelOnlyOneEdge Declaration  -- ^ Edge of a relation that connects to the source and the target
+                   | RelSrcEdge     Declaration  -- ^ Edge of a relation that connects to the source
+                   | RelTgtEdge     Declaration  -- ^ Edge of a relation that connects to the target
+                   | RelIntermediateNode    Declaration  -- ^ Intermediate node, as a hindge for the relation edges
+                   | IsaOnlyOneEdge              -- ^ Edge of an ISA relation without a hinge node
+                   | TotalPicture                -- ^ Graph attributes
+
+handleFlags :: PictureObject  -> Options -> [Attribute]
+handleFlags po opts =
+    case po of
+      CptConnectorNode c
+         -> if crowfoot opts
+            then
+                 [ (Label . StrLabel . fromString . name) c
+                 , Shape PlainText
+                 , Style [filled]
+                 , URL (theURL opts c)
+                 ]
+            else [ Shape PointShape
+                 , Style [filled]
+                 ]
+      CptNameNode c  -> if crowfoot opts
+                        then [ Shape PointShape
+                             , Style [invis]]
+                        else
+                             [ (Label . StrLabel . fromString . name) c
+                             , Shape PlainText
+                             , Style [filled]
+                             , URL (theURL opts c)
+                             ]
+      CptEdge    -> [Style [invis]
+                    ]
+      CptOnlyOneNode c ->
+                          [(Label . StrLabel . fromString . name) c
+                          , Shape BoxShape
+                          , Style [filled]
+                          , URL (theURL opts c)
+                          ]
+      RelOnlyOneEdge r -> [ URL (theURL opts r)
+                          , (XLabel . StrLabel .fromString.name) r
+                          ]
+                    --    ++[ (HeadLabel . StrLabel .fromString) "1" | isTot r && isUni r]
+                    --    ++[ (TailLabel . StrLabel .fromString) "1" | isSur r && isInj r]
+                        ++[ ArrowTail noArrow, ArrowHead noArrow
+                          , Dir Forward  -- Note that the tail arrow is not supported , so no crowfoot notation possible with a single edge.
+                          , Style [SItem Tapered []] , PenWidth 5
+                          ]
+      RelSrcEdge r -> [ ArrowHead ( if crowfoot opts  then normal                    else
+                                    if isFunction r    then noArrow                   else
+                                    if isInvFunction r then noArrow                   else
+                                    noArrow
+                                  )
+                      , ArrowTail ( if crowfoot opts  then crowfootArrowType False r else
+                                    if isFunction r    then noArrow                   else
+                                    if isInvFunction r then normal                    else
+                                    noArrow
+                                  )
+                      ,HeadClip False
+                --      , Dir Both  -- Needed because of change in graphviz. See http://www.graphviz.org/bugs/b1951.html
+                      ]
+      RelTgtEdge r -> [ (Label . StrLabel . fromString . name) r
+                      , ArrowHead ( if crowfoot opts  then crowfootArrowType True r  else
+                                    if isFunction r    then normal                    else
+                                    if isInvFunction r then noArrow                   else
+                                    noArrow
+                                  )
+                      , ArrowTail ( if crowfoot opts  then noArrow                   else
+                                    if isFunction r    then noArrow                   else
+                                    if isInvFunction r then AType [(noMod ,Inv)]      else
+                                    AType [(noMod ,Inv)]
+                                  )
+                   --   , Dir Both  -- Needed because of change in graphviz. See http://www.graphviz.org/bugs/b1951.html
+                      ,TailClip False
+                      ]
+      RelIntermediateNode r ->
+                       [ Label (StrLabel (fromString("")))
+                       , Shape PlainText
+                       , bgColor White
+                       , URL (theURL opts r)
+                       ]
+      IsaOnlyOneEdge-> [ ArrowHead (AType [(open,Normal)])
+                       , ArrowTail noArrow
+                       , if blackWhite opts then Style [dotted] else Color [WC(X11Color Red)Nothing]
+                       ]
+      TotalPicture -> [ Sep (DVal (if doubleEdges opts then 1/2 else 2)) -- The minimal amount of whitespace between nodes
+                      , OutputOrder  EdgesFirst --make sure the nodes are always on top...
+                      , Overlap ScaleXYOverlaps
+                      , Splines PolyLine  -- SplineEdges could work as well.
+                      , Landscape False
+                      ]
+
+isInvFunction :: Declaration -> Bool
+isInvFunction d = isInj d && isSur d
+
+crowfootArrowType :: Bool -> Declaration -> ArrowType
+crowfootArrowType isHead r
+   = AType (case isHead of
+               True  -> getCrowfootShape (isUni r) (isTot r)
+               False -> getCrowfootShape (isInj r) (isSur r)
+           )
+       where
+         getCrowfootShape :: Bool -> Bool -> [( ArrowModifier , ArrowShape )]
+         getCrowfootShape a b =
+           case (a,b) of
+            (True ,True ) -> [my_tee          ]
+            (False,True ) -> [my_crow, my_tee ]
+            (True ,False) -> [my_odot, my_tee ]
+            (False,False) -> [my_crow, my_odot]
+
+         my_tee :: ( ArrowModifier , ArrowShape )
+         my_tee = ( noMod , Tee )
+         my_odot :: ( ArrowModifier , ArrowShape )
+         my_odot= ( open, DotArrow )
+         my_crow :: ( ArrowModifier , ArrowShape )
+         my_crow= ( open, Crow )
+
+noMod :: ArrowModifier
+noMod = ArrMod { arrowFill = FilledArrow
+               , arrowSide = BothSides
+               }
+open :: ArrowModifier
+open  = noMod {arrowFill = OpenArrow}

+ src/Database/Design/Ampersand/FSpec/Motivations.hs view
@@ -0,0 +1,378 @@+--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
+module Database.Design.Ampersand.FSpec.Motivations (Motivated(purposeOf,purposesDefinedIn,explanations,explForObj), Meaning(..))
+where
+import Database.Design.Ampersand.Core.AbstractSyntaxTree
+import Database.Design.Ampersand.FSpec.FSpec(FSpec(..),Activity(..)) 
+import Database.Design.Ampersand.Basics
+import Text.Pandoc
+
+fatal :: Int -> String -> a
+fatal = fatalMsg "FSpec.Motivations"
+
+-- The general idea is that an Ampersand declaration such as:
+--     PURPOSE RELATION r[A*B] IN ENGLISH
+--     {+This text explains why r[A*B] exists-}
+-- produces the exact right text in the functional specification
+
+-- The class Motivated exists so that we can write the Haskell expression 'purposeOf fSpec l x'
+-- anywhere we like for every type of x that could possibly be motivated in an Purpose.
+-- 'purpose fSpec l x' produces all explanations related to x from the context (fSpec)
+--  that are available in the language specified in 'l'.
+-- The other functions in this class are solely meant to be used in the definition of purpose.
+-- They are defined once for each instance of Explainable, not be used in other code.
+-- TODO: Han, kan dat worden afgeschermd, zodat de programmeur alleen 'purpose' ziet en de andere functies
+--       dus niet kan gebruiken?
+--     @Stef: Ja, het is al zoveel mogelijk afgeschermd (zie definities die deze module exporteert, hierboven)
+--     maar er wordt nog gebruik van gemaakt voor oa foutmeldingen in de atlas, en het prototype.
+--     Zodra iemand iets anders verzint voor het gebruik van "ExplainOutputFormat(..),format",
+--     kunnen deze uit de export-list van deze module worden verwijderd.
+class  Named a => Motivated a where
+  purposeOf :: FSpec -> Lang -> a -> Maybe [Purpose] -- ^ explains the purpose of a, i.e. the reason why a exists. The purpose could be either given by the user, or generated by Ampersand.
+                                                    --   Multiple purposes are allowed for the following reasons:
+                                                    --  * Different purposes from different sources make me want to document them all.
+                                                    --  * Combining two overlapping scripts from (i.e. from different authors) may cause multiple purposes.
+  purposeOf fSpec l x = case expls of
+                        []  -> Nothing -- fatal 40 "No purpose is generated! (should be automatically generated and available in FSpec.)"
+                        ps  -> Just ps
+
+   where expls = [e | e<-explanations fSpec
+                    , explForObj x (explObj e)                  -- informally: "if x and e are the same"
+                    , markupMatchesLang (explMarkup e)
+                 ]
+         markupMatchesLang m = amLang m == l
+  explForObj :: a -> ExplObj -> Bool    -- ^ Given an Explainable object and an ExplObj, return TRUE if they concern the identical object.
+  explanations :: a -> [Purpose]  -- ^ The explanations that are defined inside a (including that of a itself)
+  purposesDefinedIn :: FSpec -> Lang -> a -> [Purpose]  -- ^ The explanations that are defined inside a (including that of a itself)
+  purposesDefinedIn fSpec l x
+   = [e | e<-explanations fSpec
+        , amLang (explMarkup e) == l
+        , explForObj x (explObj e)                  -- informally: "if x and e are the same"
+     ]
+instance Motivated ConceptDef where
+--  meaning _ cd = fatal 49 ("Concept definitions have no intrinsic meaning, (used with concept definition of '"++cdcpt cd++"')")
+  explForObj x (ExplConceptDef x') = x == x'
+  explForObj _ _ = False
+  explanations _ = []
+
+instance Motivated A_Concept where
+--  meaning _ c = fatal 54 ("Concepts have no intrinsic meaning, (used with concept '"++name c++"')")
+  explForObj x (ExplConceptDef cd) = name x == name cd
+  explForObj _ _ = False
+  explanations _ = []
+
+instance Motivated Declaration where
+--  meaning l decl = if null (decMean decl)
+--                   then concat [explCont expl | expl<-autoMeaning l decl, Just l == explLang expl || Nothing == explLang expl]
+--                   else decMean decl
+  explForObj d1 (ExplDeclaration d2) = d1 == d2
+  explForObj _ _ = False
+  explanations _ = []
+--  autoMeaning lang d
+--   = [Expl { explPos   = decfpos d
+--           , explObj   = ExplDeclaration d
+--           , explLang  = Just lang
+--           , explRefIds = []
+--           , explCont  = [Para langInlines]
+--           } ]
+--     where
+--      langInlines =
+--       case lang of
+--         English
+--              | null ([Sym,Asy]         >- multiplicities d) -> [Emph [Str (name d)]]
+--                                                              ++[Str " is a property of a "]
+--                                                              ++[Str ((unCap.name.source) d)]
+--                                                              ++[Str "."]
+--              | null ([Sym,Rfx,Trn]     >- multiplicities d) -> [Emph [Str (name d)]]
+--                                                              ++[Str " is an equivalence relation on "]
+--                                                              ++[Str ((unCap.plural English .name.source) d)]
+--                                                              ++[Str "."]
+--              | null ([Asy,Trn]         >- multiplicities d) -> [Emph [Str (name d)]]
+--                                                              ++[Str " is an ordering relation on "]
+--                                                              ++[Str ((unCap.plural English .name.source) d)]
+--                                                              ++[Str "."]
+--              | null ([Uni,Tot,Inj,Sur] >- multiplicities d) -> applyM d [Str ("each "++(unCap.name.source) d)]
+--                                                                         [Str ("exactly one "++(unCap.name.target) d)]
+--                                                              ++[Str " and vice versa."]
+--              | null ([Uni,Tot,Inj    ] >- multiplicities d) -> applyM d [Str ("each "++(unCap.name.source) d)]
+--                                                                         [Str ("exactly one "++(unCap.name.target) d)]
+--                                                              ++[Str ", but not for each "]
+--                                                              ++[Str ((unCap.name.target) d++" there must be a "++(unCap.name.source) d)]
+--                                                              ++[Str "."]
+--              | null ([Uni,Tot,    Sur] >- multiplicities d) -> applyM d [Str ("each "++(unCap.name.source) d)]
+--                                                                         [Str ("exactly one "++(unCap.name.target) d)]
+--                                                              ++[Str ", but each "]
+--                                                              ++[Str ((unCap.name.target) d++" is related to one or more "++(unCap.plural English .name.source) d)]
+--                                                              ++[Str "."]
+--              | null ([Uni,    Inj,Sur] >- multiplicities d) -> [Str ("There is exactly one "++(unCap.name.source) d++" (")]
+--                                                              ++[Math InlineMath "a"]
+--                                                              ++[Str (") for each "++(unCap.name.target) d++" (")]
+--                                                              ++[Math InlineMath "b"]
+--                                                              ++[Str "), for which: "]
+--                                                              ++applyM d [Math InlineMath "b"] [Math InlineMath "a"]
+--                                                              ++[Str (", but not for each "++(unCap.name.source) d++" there must be a "++(unCap.name.target) d++".")]
+--              | null ([    Tot,Inj,Sur] >- multiplicities d) -> [Str ("There is exactly one "++(unCap.name.source) d++" (")]
+--                                                              ++[Math InlineMath "a"]
+--                                                              ++[Str (") for each "++(unCap.name.target) d++" (")]
+--                                                              ++[Math InlineMath "b"]
+--                                                              ++[Str "), for which: "]
+--                                                              ++applyM d [Math InlineMath "b"] [Math InlineMath "a"]
+--                                                              ++[Str (", but each "++(unCap.name.source) d++" is related to one or more "++(unCap.plural English .name.target) d)]
+--                                                              ++[Str "."]
+--              | null ([Uni,Tot        ] >- multiplicities d) -> applyM d [Str ("each "++(unCap.name.source) d)]
+--                                                                         [Str ("exactly one "++(unCap.name.target) d)]
+--                                                              ++[Str "."]
+--              | null ([Uni,    Inj    ] >- multiplicities d) -> applyM d [Str ("each "++(unCap.name.source) d)]
+--                                                                         [Str ("at most one "++(unCap.name.target) d)]
+--                                                              ++[Str (" and each "++(unCap.name.target) d++" is related to at most one "++(unCap.name.source) d)]
+--                                                              ++[Str "."]
+--              | null ([Uni,        Sur] >- multiplicities d) -> applyM d [Str ("each "++(unCap.name.source) d)]
+--                                                                         [Str ("at most one "++(unCap.name.target) d)]
+--                                                              ++[Str (", whereas each "++(unCap.name.target) d++" is related to at least one "++(unCap.name.source) d)]
+--                                                              ++[Str "."]
+--              | null ([    Tot,Inj    ] >- multiplicities d) -> applyM d [Str ("each "++(unCap.name.source) d)]
+--                                                                         [Str ("at least one "++(unCap.name.target) d)]
+--                                                              ++[Str (", whereas each "++(unCap.name.target) d++" is related to at most one "++(unCap.name.source) d)]
+--                                                              ++[Str "."]
+--              | null ([    Tot,    Sur] >- multiplicities d) -> applyM d [Str ("each "++(unCap.name.source) d)]
+--                                                                         [Str ("at least one "++(unCap.name.target) d)]
+--                                                              ++[Str (" and each "++(unCap.name.target) d++" is related to at least one "++(unCap.name.source) d)]
+--                                                              ++[Str "."]
+--              | null ([        Inj,Sur] >- multiplicities d) -> [Str ("There is exactly one "++(unCap.name.source) d++" (")]
+--                                                              ++[Math InlineMath "a"]
+--                                                              ++[Str (") for each "++(unCap.name.target) d++" (")]
+--                                                              ++[Math InlineMath "b"]
+--                                                              ++[Str "), for which: "]
+--                                                              ++applyM d [Math InlineMath "b"] [Math InlineMath "a"]
+--                                                              ++[Str "."]
+--              | null ([            Sur] >- multiplicities d) -> [Str ("There is at least one "++(unCap.name.source) d++" (")]
+--                                                              ++[Math InlineMath "a"]
+--                                                              ++[Str (") for each "++(unCap.name.target) d++" (")]
+--                                                              ++[Math InlineMath "b"]
+--                                                              ++[Str "), for which: "]
+--                                                              ++applyM d [Math InlineMath "b"] [Math InlineMath "a"]
+--                                                              ++[Str "."]
+--              | null ([        Inj    ] >- multiplicities d) -> [Str ("There is at most one "++(unCap.name.source) d++" (")]
+--                                                              ++[Math InlineMath "a"]
+--                                                              ++[Str (") for each "++(unCap.name.target) d++" (")]
+--                                                              ++[Math InlineMath "b"]
+--                                                              ++[Str "), for which: "]
+--                                                              ++applyM d [Math InlineMath "b"] [Math InlineMath "a"]
+--                                                              ++[Str "."]
+--              | null ([    Tot        ] >- multiplicities d) -> applyM d [Str ("each "++(unCap.name.source) d)]
+--                                                                         [Str ("at least one "++(unCap.name.target) d)]
+--                                                              ++[Str "."]
+--              | null ([Uni            ] >- multiplicities d) -> applyM d [Str ("each "++(unCap.name.source) d)]
+--                                                                         [Str ("zero or one "++(unCap.name.target) d)]
+--                                                              ++[Str "."]
+--              | otherwise                                    -> [Str "The sentence: "]
+--                                                              ++[Quoted DoubleQuote
+--                                                                  (applyM d [Math InlineMath ((var [].source) d)]
+--                                                                            [Math InlineMath ((var [source d].target) d)])
+--                                                                ]
+--                                                              ++[Str (" is meaningful (i.e. it is either true or false) for any "++(unCap.name.source) d++" ")]
+--                                                              ++[(Math InlineMath . var [] . source) d]
+--                                                              ++[Str (" and "++(unCap.name.target) d++" ")]
+--                                                              ++[(Math InlineMath . var [source d] . target) d]
+--                                                              ++[Str "."]
+--         Dutch
+--              | null ([Sym,Asy]         >- multiplicities d) -> [Emph [Str (name d)]]
+--                                                              ++[Str " is een eigenschap van een "]
+--                                                              ++[Str ((unCap.name.source) d)]
+--                                                              ++[Str "."]
+--              | null ([Sym,Rfx,Trn]     >- multiplicities d) ->[Emph [Str (name d)]]
+--                                                              ++[Str " is een equivalentierelatie tussen "]
+--                                                              ++[Str ((unCap.plural Dutch .name.source) d)]
+--                                                              ++[Str "."]
+--              | null ([Asy,Trn]         >- multiplicities d) ->[Emph [Str (name d)]]
+--                                                              ++[Str " is een ordeningsrelatie tussen "]
+--                                                              ++[Str ((unCap.plural Dutch .name.source) d)]
+--                                                              ++[Str "."]
+--              | null ([Uni,Tot,Inj,Sur] >- multiplicities d) -> applyM d [Str ("elke "++(unCap.name.source) d)]
+--                                                                              [Str ("precies één "++(unCap.name.target) d)]
+--                                                              ++[Str " en vice versa."]
+--              | null ([Uni,Tot,Inj]     >- multiplicities d) -> applyM d [Str ("elke "++(unCap.name.source) d)]
+--                                                                         [Str ("precies één "++(unCap.name.target) d)]
+--                                                              ++[Str ", maar niet voor elke "]
+--                                                              ++[Str ((unCap.name.target) d)]
+--                                                              ++[Str " hoeft er een "]
+--                                                              ++[Str ((unCap.name.source) d)]
+--                                                              ++[Str " te zijn."]
+--              | null ([Uni,Tot,    Sur] >- multiplicities d) -> applyM d [Str ("elke "++(unCap.name.source) d)]
+--                                                                         [Str ("precies één "++(unCap.name.target) d)]
+--                                                              ++[Str ", maar elke "]
+----                                                            ++[Str ((unCap.name.target) d)]
+--                                                              ++[Str (" is gerelateerd aan één of meer ")]
+--                                                              ++[Str ((unCap.plural Dutch .name.source) d)]
+--                                                              ++[Str "."]
+--              | null ([Uni,    Inj,Sur] >- multiplicities d) -> [Str ("Er is precies één "++(unCap.name.source) d++" (")]
+--                                                              ++[Math InlineMath "a"]
+--                                                              ++[Str (") voor elke "++(unCap.name.target) d++" (")]
+--                                                              ++[Math InlineMath "b"]
+--                                                              ++[Str "), waarvoor geldt: "]
+--                                                              ++applyM d [Math InlineMath "b"] [Math InlineMath "a"]
+--                                                              ++[Str (", maar niet voor elke "++(unCap.name.source) d++" hoeft er een "++(unCap.name.target) d++" te zijn.")]
+--              | null ([    Tot,Inj,Sur] >- multiplicities d) -> [Str ("Er is precies één "++(unCap.name.source) d++" (")]
+--                                                              ++[Math InlineMath "a"]
+--                                                              ++[Str (") voor elke "++(unCap.name.target) d++" (")]
+--                                                              ++[Math InlineMath "b"]
+--                                                              ++[Str "), waarvoor geldt: "]
+--                                                              ++applyM d [Math InlineMath "b"] [Math InlineMath "a"]
+--                                                              ++[Str (", maar elke "++(unCap.name.source) d++" mag gerelateerd zijn aan meerdere "++(unCap.plural Dutch .name.target) d++".")]
+--              | null ([Uni,Tot        ] >- multiplicities d) -> applyM d [Str ("elke "++(unCap.name.source) d)]
+--                                                                         [Str ("precies één "++(unCap.name.target) d)]
+--                                                              ++[Str "."]
+--              | null ([Uni,    Inj    ] >- multiplicities d) -> applyM d [Str ("elke "++(unCap.name.source) d)]
+--                                                                         [Str ("ten hoogste één "++(unCap.name.target) d)]
+--                                                              ++[Str " en elke "]
+--                                                              ++[Str ((unCap.name.target) d)]
+--                                                              ++[Str (" is gerelateerd aan ten hoogste één ")]
+--                                                              ++[Str ((unCap.name.source) d++".")]
+--                                                              ++[Str "."]
+--              | null ([Uni,        Sur] >- multiplicities d) -> applyM d [Str ("elke "++(unCap.name.source) d)]
+--                                                                         [Str ("ten hoogste één "++(unCap.name.target) d)]
+--                                                              ++[Str ", terwijl elke "]
+--                                                              ++[Str ((unCap.name.target) d)]
+--                                                              ++[Str (" is gerelateerd aan tenminste één ")]
+--                                                              ++[Str ((unCap.name.source) d)]
+--                                                              ++[Str "."]
+--              | null ([    Tot,Inj    ] >- multiplicities d) -> applyM d [Str ("elke "++(unCap.name.source) d)]
+--                                                                         [Str ("tenminste één "++(unCap.name.target) d)]
+--                                                              ++[Str ", terwijl elke "]
+--                                                              ++[Str ((unCap.name.target) d)]
+--                                                              ++[Str (" is gerelateerd aan ten hoogste één ")]
+--                                                              ++[Str ((unCap.name.source) d)]
+--                                                              ++[Str "."]
+--              | null ([    Tot,    Sur] >- multiplicities d) -> applyM d [Str ("elke "++(unCap.name.source) d)]
+--                                                                         [Str ("tenminste één "++(unCap.name.target) d)]
+--                                                              ++[Str (" en elke "++(unCap.name.target) d++" is gerelateerd aan tenminste één "++(unCap.name.source) d++".")]
+--              | null ([        Inj,Sur] >- multiplicities d) -> [Str ("Er is precies één "++(unCap.name.source) d++" (")]
+--                                                              ++[Math InlineMath "a"]
+--                                                              ++[Str (") voor elke "++(unCap.name.target) d++" (")]
+--                                                              ++[Math InlineMath "b"]
+--                                                              ++[Str "), waarvoor geldt: "]
+--                                                              ++applyM d [Math InlineMath "b"] [Math InlineMath "a"]
+--                                                              ++[Str "."]
+--              | null ([            Sur] >- multiplicities d) -> [Str ("Er is tenminste één "++(unCap.name.source) d++" (")]
+--                                                              ++[Math InlineMath "a"]
+--                                                              ++[Str (") voor elke "++(unCap.name.target) d++" (")]
+--                                                              ++[Math InlineMath "b"]
+--                                                              ++[Str "), waarvoor geldt: "]
+--                                                              ++applyM d [Math InlineMath "b"] [Math InlineMath "a"]
+--                                                              ++[Str "."]
+--              | null ([        Inj    ] >- multiplicities d) -> [Str ("Er is hooguit één "++(unCap.name.source) d++" (")]
+--                                                              ++[Math InlineMath "a"]
+--                                                              ++[Str (") voor elke "++(unCap.name.target) d++" (")]
+--                                                              ++[Math InlineMath "b"]
+--                                                              ++[Str "), waarvoor geldt: "]
+--                                                              ++applyM d [Math InlineMath "b"] [Math InlineMath "a"]
+--                                                              ++[Str "."]
+--              | null ([    Tot        ] >- multiplicities d) -> applyM d [Str ("elke "++(unCap.name.source) d)]
+--                                                                         [Str ("tenminste één "++(unCap.name.target) d)]
+--                                                              ++[Str "."]
+--              | null ([Uni            ] >- multiplicities d) -> applyM d [Str ("elke "++(unCap.name.source) d)]
+--                                                                         [Str ("nul of één "++(unCap.name.target) d)]
+--                                                              ++[Str "."]
+--              | otherwise                                    -> [Str "De zin: "]
+--                                                              ++[Quoted DoubleQuote
+--                                                                  (applyM d [(Math InlineMath . var [] . source) d]
+--                                                                            [(Math InlineMath . var [source d] . target) d])
+--                                                                ]
+--                                                              ++[Str (" heeft betekenis (dus: is waar of niet waar) voor een "++(unCap.name.source) d++" ")]
+--                                                              ++[(Math InlineMath . var [].source) d]
+--                                                              ++[Str (" en een "++(unCap.name.target) d++" ")]
+--                                                              ++[(Math InlineMath . var [source d].target) d]
+--                                                              ++[Str "."]
+--
+--      applyM :: Declaration -> [Inline] -> [Inline] -> [Inline]
+--      applyM decl a b =
+--               case decl of
+--                 Sgn{} | null (prL++prM++prR)
+--                            -> a++[Space,Str "corresponds",Space,Str "to",Space]++b++[Space,Str "in",Space,Str "relation",Space,Str(name decl)]
+--                       | null prL
+--                            -> a++[Space,Str prM,Space]++b++[Space,Str prR]
+--                       | otherwise
+--                            -> [Str (upCap prL),Space]++a++[Space,Str prM,Space]++b++if null prR then [] else [Space,Str prR]
+--                              where prL = decprL decl
+--                                    prM = decprM decl
+--                                    prR = decprR decl
+--                 Isn{}     -> a++[Space,Str "equals",Space]++b
+--                 Vs{}      -> [Str (show True)]
+--
+--      var :: Named a => [a] -> a -> String     -- TODO Vervangen door mkvar, uit predLogic.hs
+--      var seen c = low c ++ ['\'' | c'<-seen, low c == low c']
+--                      where low idt= if null (name idt) then "x" else [(toLower.head.name) idt]
+
+instance Motivated Rule where
+--  meaning l rule
+--   = head (expls++map explCont (autoMeaning l rule))
+--     where
+--        expls = [econt | Means l' econt<-rrxpl rule, l'==Just l || l'==Nothing]
+  explForObj x (ExplRule str) = name x == str
+  explForObj _ _ = False
+  explanations _ = []
+--  autoMeaning lang r
+--   = [Expl { explObj   = ExplRule (name r)
+--           , explPos   = origin r
+--           , explLang  = Just lang
+--           , explRefIds = []
+--           , explCont  = [Plain [RawInline (Text.Pandoc.Builder.Format "latex") (showPredLogic lang r++".")]]
+--           } ]
+
+instance Motivated Pattern where
+--  meaning _ pat = fatal 324 ("Patterns have no intrinsic meaning, (used with pattern '"++name pat++"')")
+  explForObj x (ExplPattern str) = name x == str
+  explForObj _ _ = False
+  explanations = ptxps
+
+instance Motivated Interface where
+--  meaning _ obj = fatal 342 ("Interfaces have no intrinsic meaning, (used with interface '"++name obj++"')")
+  explForObj x (ExplInterface str) = name x == str
+  explForObj _ _ = False
+  explanations _ = []
+
+class Meaning a where
+  meaning :: Lang -> a -> Maybe A_Markup
+  meaning2Blocks :: Lang -> a -> [Block]
+  meaning2Blocks l a = case meaning l a of
+                         Nothing -> []
+                         Just m  -> amPandoc m
+
+instance Meaning Rule where
+  meaning l r = case filter isLang (ameaMrk (rrmean r)) of
+                  []   -> Nothing
+                  [m]  -> Just m
+                  _    -> fatal 381 ("In the "++show l++" language, too many meanings given for rule "++name r ++".")
+                  where isLang m = l == amLang m
+
+instance Meaning Declaration where
+  meaning l d =
+    case d of
+      Sgn{} -> let isLang m = l == amLang m
+               in case filter isLang (ameaMrk (decMean d)) of
+                    []   -> Nothing
+                    [m]  -> Just m
+                    _    -> fatal 388 ("In the "++show l++" language, too many meanings given for declaration "++name d ++".")
+      Isn{} -> fatal 370 "meaning is undefined for Isn"
+      Vs{}  -> fatal 371 "meaning is undefined for Vs"
+
+instance Motivated FSpec where
+--  meaning _ fSpec = fatal 329 ("No FSpec has an intrinsic meaning, (used with FSpec '"++name fSpec++"')")
+  explForObj x (ExplContext str) = name x == str
+  explForObj _ _ = False
+  explanations fSpec
+    = fSexpls fSpec ++
+      (concatMap explanations . vpatterns)  fSpec ++
+      (concatMap explanations . interfaceS) fSpec
+
+-- Ampersand allows multiple purposes for everything.
+-- The diagnosis report must make mention of this (so the user will notice if (s)he reads the diagnosis).
+-- Multiple purposes are simply concatenated, so the user sees them all.
+instance Motivated Activity where
+  explForObj _ _ = False
+  explanations activity = actPurp activity
+  purposeOf _ l x = case [ e | e <- actPurp x, amLang (explMarkup e) == l ] of
+                    []    -> Nothing
+                    purps -> Just purps
+
+   
+ src/Database/Design/Ampersand/FSpec/Plug.hs view
@@ -0,0 +1,296 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}
+-- SJC: is it possible to move this to the prototype part of ampersand? I mean,
+--      do functions like plugFields and plug-path really need to be here?
+--      perhaps we can at least move the largest part?
+module Database.Design.Ampersand.FSpec.Plug
+     (Plugable(..), PlugInfo(..)
+     ,SqlField(..)
+     ,SqlFieldUsage(..)
+     ,SqlType(..)
+     ,showSQL
+     ,plugpath
+
+     ,tblcontents
+     ,fldauto
+     ,PlugSQL(..)
+     )
+where
+import Database.Design.Ampersand.ADL1
+import Database.Design.Ampersand.Classes (fullContents,atomsOf,Relational(..))
+import Database.Design.Ampersand.Basics
+import Data.List
+import GHC.Exts (sortWith)
+import Database.Design.Ampersand.FSpec.FSpec
+import Prelude hiding (Ordering(..))
+
+fatal :: Int -> String -> a
+fatal = fatalMsg "FSpec.Plug"
+
+----------------------------------------------
+--Plug
+----------------------------------------------
+--TODO151210 -> define what a plug is and what it should do
+--Plugs are of the class Object just like Activities(??? => PHP plug isn't an instance of Object)
+--An Object is an entity to do things with like reading, updating, creating,deleting.
+--A Interface is an Object using only Plugs for reading and writing data; a Plug is a data service maintaining the rules for one object:
+-- + GEN Interface,Plug ISA Object
+-- + cando::Operation*Object
+-- + uses::Interface*Plug [TOT].
+-- + maintains::Plug*Rule.
+-- + signals::Interface*SignalRule.
+--
+--Plugs can currently be implemented in PHP or SQL.
+--type Plugs = [Plug]
+--data Plug = PlugSql PlugSQL | PlugPhp PlugPHP deriving (Show,Eq)
+
+class (Named p, Eq p, Show p) => Plugable p where
+  makePlug :: PlugInfo -> p
+
+instance Plugable PlugSQL where
+  makePlug (InternalPlug p) = p
+  makePlug (ExternalPlug _) = fatal 112 "external plug is not Plugable"
+
+----------------------------------------------
+--PlugSQL
+----------------------------------------------
+--TblSQL, BinSQL, and ScalarSQL hold different entities. See their definition FSpec.hs
+
+--           all kernel fields can be related to an imaginary concept ID for the plug (a SqlField with type=SQLID)
+--             i.e. For all kernel fields k1,k2, where concept k1=A, concept k2=B, fldexpr k1=r~, fldexpr k2=s~
+--                  You can imagine :
+--                    - a relation value::ID->A[INJ] or value::ID->A[INJ,SUR]
+--                    - a relation value::ID->B[INJ] or value::ID->B[INJ,SUR]
+--                    such that s~=value~;value;r~ and r~=value~;value;s~
+--                    because value is at least uni,tot,inj, all NULL in k0 imply NULL in k1 xor v.v.
+--                    if value also sur then all NULL in k0 imply NULL in k1 and v.v.
+--           Without such an ID, the surjective or total property between any two kernel fields is required.
+--           Because you can imagine an ID concept the surjective or total property between two kernel field has become a design choice.
+--
+--           With or without ID we choose to keep kernel = A closure of concepts A,B for which there exists a r::A->B[INJ] instead of r::A*B[UNI,INJ]
+--           By making this choice:
+--             - nice database table size
+--             - we do not need the imaginary concept ID  (and relation value::ID->A[INJ] or value::ID->A[INJ,SUR]), because:
+--                  with ID    -> there will always be one or more kernel field k1 such that (value;(fldexpr k1)~)[UNI,INJ,TOT,SUR].
+--                                any of those k1 can serve as ID of the plug (a.k.a. concept p / source p)
+--                  without ID -> any of those k1 can still serve as ID of the plug (a.k.a. concept p / source p)
+--               In other words, the imaginary concept is never needed
+--                               because there always is an existing one with the correct properties by definition of kernel.
+--               Implementation without optional ID:
+--                        -> fldexpr of some kernel field k1 will be r~
+--                           k1 holds the target of r~
+--                           the source of r~ is a kernel concept too
+--                           r~ may be I
+--                        -> fldexpr of some attMor field a1 will be s
+--                           a1 holds the target of s
+--                           the source of s is a kernel concept
+--                        -> sqlRelFields r = (r,k1,a1) (or (r,k1,k2)) in mLkpTbl
+--                           is used to generate SQL code and PHP-objects without needing the ID field.
+--                           The ID field can be ignored and does not have to be generated because r=(fldexpr k1)~;(fldexpr a1)
+--                           You could generate the ID-field with autonum if you want, because it will not be used
+--                        -> TODO151210 -> sqlRelFields e where e is not in mLkpTbl
+--                           option1) Generate the ID field (see entityfield)
+--                                    sqlRelFields e = (e, idfld;k1, idfld;a1) where e=(fldexpr k1)~;value~;value;(fldexpr a1)
+--                                    remark: binary tables can be binary tables without kernels, but with ID field
+--                                            (or from a different perspective: ID is the only kernel field)
+--                                            sqlRelFields r = (r,idfld/\r;r~,idfld;m1) where r = (idfld/\r;r~)~;idfld;(fldexpr m1)
+--                                            (sqlRelFields r~  to get the target of r)
+--                                            (scalar tables can of course also have an ID field)
+--                           option2) sqlRelFields e = (e, k1;k2;..kn, a1)
+--                                    where e=(fldexpr kn)~;..;(fldexpr k2)~;(fldexpr k1)~;(fldexpr k1)(fldexpr k2);..;(fldexpr kn);(fldexpr a1)
+--                           If I am right the function isTrue tries to support sqlRelFields e by ignoring the type error in kn;a1.
+--                           That is wrong!
+
+--the entityfield is not implemented as part of the data type PlugSQL
+--It is a constant which may or may not be used (you may always imagine it)
+--TODO151210 -> generate the entityfield if options = --autoid -p
+--REMARK151210 -> one would expect I[entityconcept p],
+--                but any p (as instance of Object) has one always existing concept p suitable to replace entityconcept p.
+--                concept p and entityconcept p are related uni,tot,inj,sur.
+
+--the entity stored in a plug is an imaginary concept, that is uni,tot,inj,sur with (concept p)
+--REMARK: there is a (concept p) because all kernel fields are related SUR with (concept p)
+
+--Maintain rule: Object ObjectDef = Object (makeUserDefinedSqlPlug :: ObjectDef -> PlugSQL)
+--TODO151210 -> Build a check which checks this rule for userdefined/showADL generated plugs(::[ObjectDef])
+--TODO151210 -> The ObjectDef of a BinSQL plug for relation r is that:
+--           1) SQLPLUG mybinplug: r      , or
+--           2) SQLPLUG labelforsourcem : I /\ r;r~ --(or just I if r is TOT)
+--               = [labelfortargetm : r]
+--           The first option has been implemented in instance ObjectPlugSQL i.e. attributes=[], ctx=ERel r _
+instance Object PlugSQL where
+ concept p = case p of
+   TblSQL{mLkpTbl = []} -> fatal 263 $ "empty lookup table for plug "++name p++"."
+   TblSQL{}             -> --TODO151210-> deze functieimplementatie zou beter moeten matchen met onderstaande beschrijving
+                            --        nu wordt aangenomen dat de source van het 1e rel in mLkpTbl de source van de plug is.
+                            --a relation between kernel concepts r::A*B is at least [UNI,INJ]
+                            --to be able to point out one concept to be the source we are looking for one without NULLs in its field
+                            -- i.e. there is a concept A such that
+                            --      for all kernel field expr (s~)::B*C[UNI,INJ]:
+                            --      s~ is total and there exists an expr::A*B[UNI,INJ,TOT,SUR] (possibly A=B => I[A][UNI,INJ,TOT,SUR])
+                            --If A is such a concept,
+                            --   and A is not B,
+                            --   and there exist an expr::A*B[UNI,INJ,TOT,SUR]
+                            --then (concept PlugSQL{}) may be A or B
+                            --REMARK -> (source p) used to be implemented as (source . fldexpr . head . fields) p. That is different!
+                            head [source r |(r,_,_)<-mLkpTbl p]
+   BinSQL{} -> source (mLkp p) --REMARK151210 -> the concept is actually ID such that I[ID]=I[source r]/\r;r~
+   ScalarSQL{} -> cLkp p
+-- Usually source a==concept p. Otherwise, the attribute computation is somewhat more complicated. See ADL2FSpec for explanation about kernels.
+ attributes p@TblSQL{}
+  = [ Obj (fldname tFld)                                                        -- objnm
+          (Origin "This object is generated by attributes (Object PlugSQL)")    -- objpos
+          (if source a==concept p then a  else f (source a) [[a]])              -- objctx
+          Nothing 
+          Nothing
+          []                                                            -- objats and objstrs
+    | (a,_,tFld)<-mLkpTbl p]
+    where
+     f c mms
+      = case sortWith length stop of
+         []  -> f c mms'  -- a path from c to a is not found (yet), so add another step to the recursion
+         (hd:_) -> case hd of
+                    []  -> fatal 201 "Empty head should be impossible."
+                    _  -> case [(l,r) | (l,r)<-zip (init hd) (tail hd), target l/=source r] of
+                            [] -> foldr1 (.:.) hd  -- pick the shortest path and turn it into an expression.
+                            lrs -> fatal 204 ("illegal compositions " ++show lrs)
+      where
+        mms' = if [] `elem` mms
+               then fatal 295 "null in mms."
+               else [a:ms | ms<-mms, (a,_,_)<-mLkpTbl p, target a==source (head ms)]
+        stop = if [] `elem` mms'
+               then fatal 298 "null in mms'."
+               else [ms | ms<-mms', source (head ms)==c]  -- contains all found paths from c to a
+ attributes _ = [] --no attributes for BinSQL and ScalarSQL
+ contextOf p@BinSQL{} = mLkp p
+ contextOf p = EDcI (concept p)
+
+fldauto::SqlField->Bool -- is the field auto increment?
+fldauto f = (fldtype f==SQLId) && not (fldnull f) && flduniq f -- && isIdent (fldexpr f)
+
+showSQL :: SqlType -> String
+showSQL (SQLChar    n) = "CHAR("++show n++")"
+showSQL (SQLBlob     ) = "BLOB"
+showSQL (SQLPass     ) = "VARCHAR(255)"
+showSQL (SQLSingle   ) = "FLOAT" -- todo
+showSQL (SQLDouble   ) = "FLOAT"
+showSQL (SQLText     ) = "TEXT"
+showSQL (SQLuInt    n) = "INT("++show n++") UNSIGNED"
+showSQL (SQLsInt    n) = "INT("++show n++")"
+showSQL (SQLId       ) = "INT"
+showSQL (SQLVarchar n) = "VARCHAR("++show n++")"
+showSQL (SQLBool     ) = "BOOLEAN"
+
+-- Every kernel field is a key, kernel fields are in cLkpTbl or the column of ScalarSQL (which has one column only)
+-- isPlugIndex refers to UNIQUE key -- TODO: this is wrong
+--isPlugIndex may contain NULL, but their key (the entityfield of the plug) must be unique for a kernel field (isPlugIndex=True)
+--the field that is isIdent and isPlugIndex (i.e. concept plug), or any similar (uni,inj,sur,tot) field is also UNIQUE key
+--IdentityDefs define UNIQUE key (fld1,fld2,..,fldn)
+--REMARK -> a kernel field does not have to be in cLkpTbl, in that cast there is another kernel field that is
+--          thus I must check whether fldexpr isUni && isInj && isSur
+isPlugIndex :: PlugSQL->SqlField->Bool
+isPlugIndex plug f =
+  case plug of
+    ScalarSQL{} -> sqlColumn plug==f
+    BinSQL{}  --mLkp is not uni or inj by definition of BinSQL, if mLkp total then the (fldexpr srcfld)=I/\r;r~=I i.e. a key for this plug
+     | isUni(mLkp plug) || isInj(mLkp plug) -> fatal 366 "BinSQL may not store a univalent or injective rel, use TblSQL instead."
+     | otherwise                            -> False --binary does not have key, but I could do a SELECT DISTINCT iff f==fst(columns plug) && (isTot(mLkp plug))
+    TblSQL{}    -> elem f (fields plug) && isUni(fldexpr f) && isInj(fldexpr f) && isSur(fldexpr f)
+
+
+
+composeCheck :: Expression -> Expression -> Expression
+composeCheck l r
+ = if target l/=source r then fatal 316 ("\nl: "++show l++"with target "++show (target l)++"\nl: "++show r++"with source "++show (source r)) else
+   l .:. r
+
+--composition from srcfld to trgfld, if there is an expression for that
+plugpath :: PlugSQL -> SqlField -> SqlField -> Maybe Expression
+plugpath p srcfld trgfld =
+ case p of
+  BinSQL{}
+   | srcfld==trgfld -> let tm=mLkp p --(note: mLkp p is the relation from fst to snd column of BinSQL)
+                       in if srcfld==fst(columns p)
+                          then Just$ tm .:. flp tm --domain of r
+                          else Just$ flp tm .:. tm --codomain of r
+   | srcfld==fst(columns p) && trgfld==snd(columns p) -> Just$ fldexpr trgfld
+   | trgfld==fst(columns p) && srcfld==snd(columns p) -> Just$ flp(fldexpr srcfld)
+   | otherwise -> fatal 444 $ "BinSQL has only two fields:"++show(fldname srcfld,fldname trgfld,name p)
+  ScalarSQL{}
+   | srcfld==trgfld -> Just$ fldexpr trgfld
+   | otherwise -> fatal 447 $ "scalarSQL has only one field:"++show(fldname srcfld,fldname trgfld,name p)
+  TblSQL{}
+   | srcfld==trgfld && isPlugIndex p trgfld -> Just$ EDcI (target (fldexpr trgfld))
+   | srcfld==trgfld && not(isPlugIndex p trgfld) -> Just$ composeCheck (flp (fldexpr srcfld)) (fldexpr trgfld) --codomain of r of morAtt
+   | (not . null) (paths srcfld trgfld)
+      -> case head (paths srcfld trgfld) of
+          []    -> fatal 338 ("Empty head (paths srcfld trgfld) should be impossible.")
+          ps    -> Just$ foldr1 composeCheck ps
+   --bijective kernel fields, which are bijective with ID of plug have fldexpr=I[X].
+   --thus, path closures of these kernel fields are disjoint (path closure=set of fields reachable by paths),
+   --      because these kernel fields connect to themselves by r=I[X] (i.e. end of path).
+   --connect two paths over I[X] (I[X];srce)~;(I[X];trge) => filter I[X] => srcpath~;trgpath
+   | (not.null) (pathsoverIs srcfld trgfld) -> Just$      foldr1 composeCheck (head (pathsoverIs srcfld trgfld))
+   | (not.null) (pathsoverIs trgfld srcfld) -> Just$ flp (foldr1 composeCheck (head (pathsoverIs trgfld srcfld)))
+   | otherwise -> Nothing
+  --paths from s to t by connecting r from mLkpTbl
+  --the (r,srcfld,trgfld) from mLkpTbl form paths longer paths if connected: (trgfld m1==srcfld m2) => (m1;m2,srcfld m1,trgfld m2)
+  where
+  paths s t = [e |(e,es,et)<-eLkpTbl p,s==es,t==et]
+  --paths from I to field t
+  pathsfromIs t = [(e,es,et) |(e,es,et)<-eLkpTbl p,et==t,not (null e),isIdent(head e)]
+  --paths from s to t over I[X]
+  pathsoverIs s t = [flpsrce++tail trge
+                    |(srce,srces,_)<-pathsfromIs s
+                    ,(trge,trges,_)<-pathsfromIs t
+                    ,srces==trges, let flpsrce = (map flp.reverse.tail) srce]
+
+--the expression LkpTbl of a plug is the transitive closure of the mLkpTbl of the plug
+--Warshall's transitive closure algorithm clos1 :: (Eq a) => [(a,a)] -> [(a,a)] is extended to combine paths i.e. r++r'
+--[Expression] implies a 'composition' from a kernel SqlField to another SqlField
+--use plugpath to get the Expression from srcfld to trgfld
+--plugpath also combines expressions with head I like (I;tail1)~;(I;tail2) <=> tail1;tail2
+eLkpTbl::PlugSQL -> [([Expression],SqlField,SqlField)]
+eLkpTbl p = clos1 [([r],s,t)|(r,s,t)<-mLkpTbl p]
+  where
+  clos1 :: [([Expression],SqlField,SqlField)] -> [([Expression],SqlField,SqlField)]     -- e.g. a list of SqlField pairs
+  clos1 xs
+     = foldl f xs (nub (map (\(_,x,_)->x) xs) `isc` nub (map (\(_,_,x)->x) xs))
+       where
+        f q x = q `uni` [( r++r' , a, b') | (r ,a, b) <- q, b == x, (r', a', b') <- q, a' == x]
+
+
+-- | tblcontents 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 String is used rather than String.
+type TblRecord = [Maybe String]
+tblcontents :: [A_Gen] -> [Population] -> PlugSQL -> [TblRecord]
+tblcontents gs udp plug
+   = case plug of
+     ScalarSQL{} -> [[Just x] | x<-atomsOf gs udp (cLkp plug)]
+     BinSQL{}    -> [[(Just . srcPaire) p,(Just . trgPaire) p] |p<-fullContents gs udp (mLkp plug)]
+     TblSQL{}    -> 
+ --TODO15122010 -> remove the assumptions (see comment data PlugSQL)
+ --fields are assumed to be in the order kernel+other,
+ --where NULL in a kernel field implies NULL in the following kernel fields
+ --and the first field is unique and not null
+ --(r,s,t)<-mLkpTbl: s is assumed to be in the kernel, fldexpr t is expected to hold r or (flp r), s and t are assumed to be different
+       case fields plug of 
+         []   -> fatal 593 "no fields in plug."
+         f:fs -> transpose
+                 ( map Just cAtoms
+                 : [case fExp of
+                       EDcI c -> [ if a `elem` atomsOf gs udp c then Just a else Nothing | a<-cAtoms ]
+                       _      -> [ (lkp a . fullContents gs udp) fExp | a<-cAtoms ]
+                   | fld<-fs, let fExp=fldexpr fld
+                   ]
+                 )
+                 where
+                   cAtoms = (atomsOf gs udp . source . fldexpr) f
+                   lkp a pairs
+                    = case [ p | p<-pairs, a==srcPaire p ] of
+                       [] -> Nothing
+                       [p] -> Just (trgPaire p)
+                       ps -> fatal 428 ("(this could happen when using --dev flag, when there are violations)\n"++
+                               "Looking for: '"++a++"'.\n"++
+                               "Multiple values in one field: \n"++
+                               "  [ "++intercalate "\n  , " (map show ps)++"\n  ]")
+                       
+ src/Database/Design/Ampersand/FSpec/ShowADL.hs view
@@ -0,0 +1,484 @@+{-# LANGUAGE FlexibleInstances #-}
+  -- The purpose of ShowADL is to print things in Ampersand source format.
+  -- Rule: The semantics of each fSpec produced by the compiler is identical to the semantics  of (parse (showADL fSpec)).
+  -- Rule: The standard show is used only for simple error messages during testing.
+  -- Question (SJC): If STRING is the code produced by showADL, would STRING == showADL (parse STRING) (context (parse STRING)) be true?
+  -- Answer (SJ):   No, not for every STRING. Yet, for every fSpec we want  semantics fSpec == semantics (parse (showADL fSpec)).
+  --                Note that 'parse' and 'semantics' do not exist in this shape, so the actual expression is slightly more complicated.
+  --
+  -- Every Expression should be disambiguated before printing to ensure unambiguity.
+module Database.Design.Ampersand.FSpec.ShowADL
+    ( ShowADL(..), LanguageDependent(..), showPAclause, showREL)
+where
+import Database.Design.Ampersand.Core.ParseTree
+import Database.Design.Ampersand.Core.AbstractSyntaxTree
+import Database.Design.Ampersand.Basics      (fatalMsg,Collection(..),Named(..))
+import Database.Design.Ampersand.Classes
+import Database.Design.Ampersand.ADL1 (insParentheses)
+import Database.Design.Ampersand.FSpec.FSpec
+import Data.List
+import Prelude
+--import Debug.Trace
+
+fatal :: Int -> String -> a
+fatal = fatalMsg "FSpec.ShowADL"
+
+class ShowADL a where
+ showADL :: a -> String
+
+-- there are data types yielding language dependent data like an Expression
+-- the LanguageDependent class provides function(s) to map language dependent functions on those data if any.
+-- for example to print all expressions in a data structure with a practical amount of type directives
+-- (instances have been created when needed)
+--
+-- LanguageDependent is part of ShowAdl because the only application at time of writing is to disambiguate expressions for the purpose of printing
+-- SJ 31-12-2012: Since 'disambiguate' has become obsolete, do we still need this?
+class LanguageDependent a where
+  mapexprs :: (Language l, ConceptStructure l, Named l) => (l -> Expression -> Expression) -> l -> a -> a
+  mapexprs _ _ = id
+
+instance LanguageDependent a => LanguageDependent (Maybe a) where
+  mapexprs _ _ Nothing  = Nothing
+  mapexprs f l (Just x) = Just $ mapexprs f l x
+
+instance LanguageDependent (a, Expression) where
+  mapexprs f l (x,e) = (x, f l e)
+instance LanguageDependent Rule where
+  mapexprs f l rul = rul{rrexp = f l (rrexp rul)}
+instance LanguageDependent Interface where
+  mapexprs f l ifc = ifc{ifcObj = mapexprs f l (ifcObj ifc)}
+instance LanguageDependent ObjectDef where
+  mapexprs f l obj = obj{objctx = f l (objctx obj), objmsub = mapexprs f l $ objmsub obj}
+instance LanguageDependent SubInterface where
+  mapexprs _ _ iref@(InterfaceRef _) = iref
+  mapexprs f l (Box o cl objs) = Box o cl $ map (mapexprs f l) objs
+instance LanguageDependent Declaration where
+  mapexprs _ _ = id
+instance LanguageDependent ECArule where
+  mapexprs _ _ = id
+instance LanguageDependent Event where
+  mapexprs _ _ = id
+--------------------------------------------------------------
+instance ShowADL (P_SubIfc a) where
+  showADL (P_Box{}) = "BOX"
+  showADL (P_InterfaceRef _ nm) = " INTERFACE "++showstr nm
+
+instance ShowADL ObjectDef where
+-- WHY (HJ)? In deze instance van ShowADL worden diverse zaken gebruikt die ik hier niet zou verwachten.
+--              Het vertroebelt de code ook een beetje, want nu moeten er dingen als 'source' en
+--              'target' hier al bekend zijn.
+--              Dat lijkt me hier nog niet op z'n plaats, als je alleen maar wat wilt kunnen 'prettyprinten'.
+-- BECAUSE (SJ): Dit blijft nog even zo, omdat showADL gebruikt wordt in het genereren van interfaces.
+--              Zolang we dat nog niet onder de knie hebben blijft de code wat troebel.
+ showADL obj = " : "++showADL (objctx obj)++
+               recur "\n  " (objmsub obj)
+  where recur :: String -> Maybe SubInterface -> String
+        recur _   Nothing = ""
+        recur ind (Just (InterfaceRef nm)) = ind++" INTERFACE "++showstr nm
+        recur ind (Just (Box _ cl objs))
+         = ind++" BOX" ++ showClass cl ++ " [ "++
+           intercalate (ind++"     , ")
+                               [ showstr (name o)++
+                                  (if null (objstrs o) then "" else " {"++intercalate ", " [showstr (unwords ss) | ss<-objstrs o]++"}")++
+                                  " : "++showADL (objctx o)++
+                                  recur (ind++"      ") (objmsub o)
+                               | o<-objs
+                               ]++
+           ind++"     ]"
+        showClass Nothing = ""
+        showClass (Just cl) = "<" ++ cl ++ ">" -- TODO: parser cannot handle these class annotations yet
+
+instance ShowADL Meta where
+ showADL (Meta _ metaObj nm val) =
+   "META "++(if null $ showADL metaObj then "" else showADL metaObj++" ") ++show nm++" "++show val
+
+instance ShowADL MetaObj where
+ showADL ContextMeta = ""
+
+instance ShowADL Purpose where
+ showADL expl = "PURPOSE "++showADL (explObj expl)
+                ++" "++showADL (amLang (explMarkup expl))
+                ++" "++showADL (amFormat (explMarkup expl))
+                ++(if null (explRefIds expl) then "" else " REF "++intercalate ";" (explRefIds expl))
+                ++ "{+"++aMarkup2String (explMarkup expl)++"-}"
+
+instance ShowADL PandocFormat where
+ showADL LaTeX = "LATEX "
+ showADL HTML  = "HTML "
+ showADL ReST  = "REST "
+ showADL Markdown = "MARKDOWN "
+
+instance ShowADL A_Markup where
+ showADL m
+     = showADL (amLang m)
+    ++ " "++showADL (amFormat m)
+    ++ "{+"++aMarkup2String m++"-}"
+
+instance ShowADL Lang where
+ showADL Dutch   = "IN DUTCH"
+ showADL English = "IN ENGLISH"
+
+instance ShowADL ExplObj where
+ showADL e = case e of
+      ExplConceptDef cd  -> "CONCEPT "++cdcpt cd
+      ExplDeclaration d  -> "RELATION "++show (name d)
+      ExplRule str       -> "RULE "++showstr str
+      ExplIdentityDef str-> "IDENT "++showstr str
+      ExplViewDef str    -> "VIEW "++showstr str
+      ExplPattern str    -> "PATTERN "++ showstr str
+      ExplInterface str  -> "INTERFACE "++showstr str
+      ExplContext str    -> "CONTEXT "++showstr str
+
+showstr :: String -> String
+showstr str = "\""++str++"\""
+
+
+-- TODO: making these tuples instance of ShowADL is very hacky
+instance ShowADL (String,Rule) where
+ showADL (role,rul) = "ROLE "++role++" MAINTAINS "++show (name rul)
+
+instance ShowADL (String,Declaration) where
+ showADL           (role,rel) = "ROLE "++role++" EDITS "++showADL rel
+
+instance ShowADL (String,Interface) where
+ showADL (role,ifc) = "ROLE "++role++" USES "++show (name ifc)
+
+instance ShowADL Pattern where
+-- TODO: This function is VERY outdated
+ showADL pat
+  = "PATTERN " ++ showstr (name pat) ++ "\n"
+    ++ (if null (ptrls pat)  then "" else "\n  " ++intercalate "\n  " (map showADL (ptrls pat)) ++ "\n")
+    ++ (if null (ptgns pat)  then "" else "\n  " ++intercalate "\n  " (map showADL (ptgns pat)) ++ "\n")
+    ++ (if null (ptdcs pat)  then "" else "\n  " ++intercalate "\n  " (map showADL (ptdcs pat)) ++ "\n")
+-- concept definitions are not printed, because we have no way of telling where they come from....
+    ++ (if null (ptids pat)  then "" else "\n  " ++intercalate "\n  " (map showADL (ptids pat)) ++ "\n")
+    ++ "ENDPATTERN"
+
+instance ShowADL (PairViewSegment Expression) where
+ showADL (PairViewText _ str)       = "TXT " ++ show str
+ showADL (PairViewExp _ srcOrTgt e) = showADL srcOrTgt ++ " " ++ showADL e
+
+instance ShowADL SrcOrTgt where
+ showADL Src = "SRC"
+ showADL Tgt = "TGT"
+
+instance ShowADL Rule where
+ showADL r
+  = "RULE \""++rrnm r++"\" : "++showADL (rrexp r)
+     ++ concat ["\n     MEANING "++showADL mng | mng <- ameaMrk $ rrmean r ]
+     ++ concat ["\n     MESSAGE "++showADL msg | msg <- rrmsg r]
+     ++ case rrviol r of
+          Nothing                -> ""
+          Just (PairView pvSegs) -> "\n     VIOLATION ("++intercalate ", " (map showADL pvSegs)++")"
+
+instance ShowADL A_Gen where
+ showADL g =
+   case g of
+    Isa{} -> "CLASSIFY "++showADL (genspc g)++" ISA "++showADL (gengen g)
+    IsE{} -> "CLASSIFY "++showADL (genspc g)++" IS "++intercalate " /\\ " (map showADL (genrhs g))
+
+instance ShowADL A_RoleRelation where
+ showADL r
+  = "ROLE "++intercalate ", " (map show (rrRoles r))++" EDITS "++intercalate ", " (map showADL (rrRels r))
+
+instance ShowADL P_RoleRule where
+ showADL r 
+  = "ROLE "++intercalate ", " (map show (mRoles r))++" MAINTAINS "++intercalate ", " (map show (mRules r))
+
+instance ShowADL Interface where
+ showADL ifc
+  = "INTERFACE "++showstr(name ifc)
+          ++ maybe "" ((" CLASS "++) . showstr) (ifcClass ifc)
+          ++(if null (ifcParams ifc) then "" else "("++intercalate ", " [showADL r | r<-ifcParams ifc]++")")
+          ++(if null (ifcArgs ifc) then "" else "{"++intercalate ", " [showstr(unwords strs) | strs<-ifcArgs ifc]++"}")
+          ++(if null (ifcRoles ifc) then "" else " FOR "++intercalate ", " (map name (ifcRoles ifc)))
+          ++showADL (ifcObj ifc)
+
+instance ShowADL IdentityDef where
+ showADL identity
+  = "IDENT "++idLbl identity
+          ++ ": " ++name (idCpt identity)
+          ++ "(" ++intercalate ", " (map showADL $ identityAts identity) ++ ")"
+
+instance ShowADL IdentitySegment where
+ showADL (IdentityExp objDef) = (if null (name objDef) then "" else "\""++name objDef++"\":") ++ showADL (objctx objDef)
+
+instance ShowADL ViewDef where
+ showADL vd
+  = "VIEW "++vdlbl vd
+          ++ ": " ++name (vdcpt vd)
+          ++ "(" ++intercalate ", " (map showADL $ vdats vd) ++ ")"
+
+instance ShowADL ViewSegment where
+ showADL (ViewExp objDef) = (if null (name objDef) then "" else "\""++name objDef++"\":") ++ showADL (objctx objDef)
+ showADL (ViewText str) = "TXT " ++ show str
+ showADL (ViewHtml str) = "PRIMHTML " ++ show str
+
+-- showADL Relation only prints complete signatures to ensure unambiguity.
+-- therefore, when printing expressions, do not apply this function to print relations, but apply one that prints names only
+--instance ShowADL Relation where
+-- showADL rel = show rel
+
+instance ShowADL Expression where
+ showADL = showExpr (" = ", " |- ", " /\\ ", " \\/ ", " - ", " / ", " \\ ", " <> ", ";", "!", "*", "*", "+", "~", ("-"++), "(", ")", "[", "*", "]")
+-- NOTE: retain space after \\, because of unexpected side effects if it is used just before an 'r' or 'n'....
+   where
+     showExpr :: (String,String,String,String,String,String,String,String,String,String,String,String,String,String,String -> String,String,String,String,String,String)
+            -> Expression -> String
+     showExpr    (equi,  impl,  inter, union',diff,  lresi, rresi, rDia, rMul  , rAdd , rPrd ,closK0,closK1,flp',  compl,           lpar,  rpar,  lbr,   star,  rbr)  expr
+      = showchar (insParentheses expr)
+        where
+          showchar (EEqu (l,r)) = showchar l++equi++showchar r
+          showchar (EImp (l,r)) = showchar l++impl++showchar r
+          showchar (EIsc (l,r)) = showchar l++inter++showchar r
+          showchar (EUni (l,r)) = showchar l++union'++showchar r
+          showchar (EDif (l,r)) = showchar l++diff ++showchar r
+          showchar (ELrs (l,r)) = showchar l++lresi++showchar r
+          showchar (ERrs (l,r)) = showchar l++rresi++showchar r
+          showchar (EDia (l,r)) = showchar l++rDia++showchar r
+          showchar (ECps (l,r)) = showchar l++rMul++showchar r
+          showchar (ERad (l,r)) = showchar l++rAdd++showchar r
+          showchar (EPrd (l,r)) = showchar l++rPrd++showchar r
+          showchar (EKl0 e)     = showchar e++closK0
+          showchar (EKl1 e)     = showchar e++closK1
+          showchar (EFlp e)     = showchar e++flp'
+          showchar (ECpl e)     = compl (showchar e)
+          showchar (EBrk e)     = lpar++showchar e++rpar
+          showchar (EDcD dcl)   = name dcl
+          showchar (EDcI c)     = "I"++lbr++name c++rbr
+          showchar (EEps i _)   = "I{-Eps-}"++lbr++name i++rbr --HJO, 20140622: Modified this, because the output must comply to Ampersand syntax.
+          showchar (EDcV sgn)   = "V"++lbr++name (source sgn)++star++name (target sgn)++rbr
+          showchar (EMp1 a c)   = "'"++a++"'"++lbr++name c++rbr
+
+instance ShowADL DnfClause where
+ showADL dnfClause = showADL (dnf2expr dnfClause)
+
+instance ShowADL Declaration where
+ showADL decl =
+  case decl of
+     Sgn{} -> name decl++" :: "++name (source decl)++(if null ([Uni,Tot]>-multiplicities decl) then " -> " else " * ")++name (target decl)++
+              (let mults=if null ([Uni,Tot]>-multiplicities decl) then multiplicities decl>-[Uni,Tot] else multiplicities decl in
+               if null mults then "" else "["++intercalate "," (map showADL mults)++"]")++
+              (if null(decprL decl++decprM decl++decprR decl) then "" else
+               " PRAGMA "++unwords (map show [decprL decl,decprM decl,decprR decl]))
+               ++ concatMap meaning (ameaMrk (decMean decl))
+     Isn{} -> "I["++show (detyp decl)++"]" -- Isn{} is of type Declaration and it is implicitly defined
+     Vs{}  -> "V"++show (decsgn decl)      -- Vs{}  is of type Declaration and it is implicitly defined
+   where
+     meaning :: A_Markup -> String
+     meaning pmkup = " MEANING "++showADL pmkup
+
+showREL :: Declaration-> String
+showREL decl = show decl
+{-
+  case decl of
+     Sgn{} -> name decl++showSign (sign decl)
+     Isn{} -> "I["++show (detyp decl)++"]" -- Isn{} is of type Declaration and it is implicitly defined
+     Vs{}  -> "V"++show (decsgn decl)
+-}
+
+instance ShowADL P_Markup where
+ showADL (P_Markup lng fmt str) = case lng of
+                                     Nothing -> ""
+                                     Just l  -> "IN "++show l++" "
+                                 ++
+                                  case fmt of
+                                     Nothing -> ""
+                                     Just f  -> " "++show f++" "
+                                 ++
+                                  "{+"++str++"-} "
+
+instance ShowADL Prop where
+ showADL = show
+
+instance ShowADL A_Concept where
+ showADL c = show (name c)
+
+instance ShowADL ConceptDef where
+ showADL cd
+  = "\n  CONCEPT "++show (cdcpt cd)++" "++show (cddef cd)++" "++(if null (cdref cd) then "" else show (cdref cd))
+
+instance ShowADL A_Context where
+ showADL context
+  = "CONTEXT " ++name context
+    ++ (if null (ctxmetas context) then "" else "\n"      ++intercalate "\n\n" (map showADL (ctxmetas context))++ "\n")
+    ++ (if null (ctxifcs context)  then "" else "\n"      ++intercalate "\n\n" (map showADL (ctxifcs context)) ++ "\n")
+    ++ (if null (ctxpats context)  then "" else "\n"      ++intercalate "\n\n" (map showADL (ctxpats context)) ++ "\n")
+    ++ (if null (ctxrs context)    then "" else "\n"      ++intercalate "\n"   (map showADL (ctxrs context))   ++ "\n")
+    ++ (if null (ctxds context)    then "" else "\n"      ++intercalate "\n"   (map showADL (ctxds context))   ++ "\n")
+    ++ (if null (ctxks context)    then "" else "\n"      ++intercalate "\n"   (map showADL (ctxks context))   ++ "\n")
+    ++ (if null (ctxgs context)    then "" else "\n"      ++intercalate "\n"   (map showADL (ctxgs context))   ++ "\n")
+    ++ (if null (ctxcds context)   then "" else "\n"      ++intercalate "\n"   (map showADL (ctxcds context))  ++ "\n")
+    ++ (if null (ctxpopus context) then "" else "\n"      ++intercalate "\n"   (map showADL (ctxpopus context))++ "\n")
+    ++ (if null (ctxsql context)   then "" else "\n"      ++intercalate "\n\n" (map showADL (ctxsql context)) ++ "\n")
+    ++ (if null (ctxphp context)   then "" else "\n"      ++intercalate "\n\n" (map showADL (ctxphp context)) ++ "\n")
+    ++ "\n\nENDCONTEXT"
+
+instance ShowADL (Maybe String) where
+  showADL _ = ""
+instance ShowADL ECArule where
+  showADL eca = "ECA #"++show (ecaNum eca)
+
+instance ShowADL Event where
+  showADL ev = " On " ++show (eSrt ev)++" "++showREL (eDcl ev)
+
+instance (ShowADL a, ShowADL b) => ShowADL (a,b) where
+ showADL (a,b) = "(" ++ showADL a ++ ", " ++ showADL b ++ ")"
+
+instance ShowADL P_Population where
+ showADL pop
+  = "POPULATION "++name pop
+  ++ case pop of
+        P_TRelPop{} -> "["++(name.pSrc.p_type) pop++"*"++(name.pTgt.p_type) pop++"]"
+        _ -> ""
+  ++ " CONTAINS\n"
+  ++ if (case pop of
+            P_RelPopu{} -> null (p_popps pop)
+            P_TRelPop{} -> null (p_popps pop)
+            P_CptPopu{} -> null (p_popas pop)
+        )
+     then ""
+     else indent++"[ "++intercalate ("\n"++indent++", ") showContent++indent++"]"
+    where indent = "   "
+          showContent = case pop of
+                          P_RelPopu{} -> map showPaire (p_popps pop)
+                          P_TRelPop{} -> map showPaire (p_popps pop)
+                          P_CptPopu{} -> map showAtom  (p_popas pop)
+showPaire :: Paire -> String
+showPaire p = showAtom (srcPaire p)++", "++ showAtom (trgPaire p)
+instance ShowADL Paire where
+ showADL p = "("++showAtom (srcPaire p)++","++ showAtom (trgPaire p)++")"
+instance ShowADL Pairs where
+ showADL ps = "["++intercalate ", " (map showADL ps)++"]"
+  
+instance ShowADL Population where
+ showADL pop
+  = "POPULATION "
+  ++ case pop of
+        PRelPopu{} -> (name.popdcl) pop++(show.sign.popdcl) pop
+        PCptPopu{} -> (name.popcpt) pop
+  ++ " CONTAINS\n"
+  ++ if (case pop of
+            PRelPopu{} -> null (popps pop)
+            PCptPopu{} -> null (popas pop)
+        )
+     then ""
+     else indent++"[ "++intercalate ("\n"++indent++", ") showContent++indent++"]"
+    where indent = "   "
+          showContent = case pop of
+                          PRelPopu{} -> map showPaire (popps pop)
+                          PCptPopu{} -> map showAtom  (popas pop)
+
+-- showADL (PRelPopu r pairs)
+--  = "POPULATION "++showADL r++" CONTAINS\n"++
+--    indent++"[ "++intercalate ("\n"++indent++", ") (map (\(x,y)-> showatom x++" * "++ showatom y) pairs)++indent++"]"
+--    where indent = "   "
+
+showAtom :: String -> String
+showAtom x = "'"++[if c=='\'' then '`' else c|c<-x]++"'"
+
+instance ShowADL TermPrim where
+ showADL (PI _)                                   = "I"
+ showADL (Pid _ c)                                = "I["++showADL c++"]"
+ showADL (Patm _ a Nothing)                       = "'"++a++"'"
+ showADL (Patm _ a (Just c))                      = "'"++a++"'["++show c++"]"
+ showADL (PVee _)                                 = "V"
+ showADL (Pfull _ s t)                            = "V["++show s++"*"++show t++"]"
+ showADL (PNamedR rel)                            = showADL rel
+ 
+instance ShowADL P_NamedRel where
+ showADL (PNamedRel _ rel mSgn)                    = rel++maybe "" showsign mSgn
+  where     showsign (P_Sign src trg)                         = "["++showADL src++"*"++showADL trg++"]"
+
+--used to compose error messages at p2a time
+instance (ShowADL a, Traced a) => ShowADL (Term a) where
+ showADL = showPExpr (" = ", " |- ", " /\\ ", " \\/ ", " - ", " / ", " \\ ", "<>", ";", "!", "*", "*", "+", "~", "(", ")")
+   where
+    showPExpr (equi,impl,inter,union',diff,lresi,rresi,rDia,rMul,rAdd,rPrd,closK0,closK1,flp',lpar,rpar) expr
+     = showchar (insP_Parentheses expr)
+      where
+       showchar (Prim a) = showADL a
+       showchar (PEqu _ l r)                             = showchar l++equi++showchar r
+       showchar (PImp _ l r)                             = showchar l++impl++showchar r
+       showchar (PIsc _ l r)                             = showchar l++inter++showchar r
+       showchar (PUni _ l r)                             = showchar l++union'++showchar r
+       showchar (PDif _ l r)                             = showchar l++diff ++showchar r
+       showchar (PLrs _ l r)                             = showchar l++lresi++showchar r
+       showchar (PRrs _ l r)                             = showchar l++rresi++showchar r
+       showchar (PDia _ l r)                             = showchar l++rDia++showchar r
+       showchar (PCps _ l r)                             = showchar l++rMul++showchar r
+       showchar (PRad _ l r)                             = showchar l++rAdd++showchar r
+       showchar (PPrd _ l r)                             = showchar l++rPrd++showchar r
+       showchar (PKl0 _ e)                               = showchar e++closK0
+       showchar (PKl1 _ e)                               = showchar e++closK1
+       showchar (PFlp _ e)                               = showchar e++flp'
+       showchar (PCpl _ e)                               = '-':showchar e
+       showchar (PBrk _ e)                               = lpar++showchar e++rpar
+
+insP_Parentheses :: (Traced a) => Term a -> Term a
+insP_Parentheses = insPar 0
+      where
+       wrap :: (Traced a) => Integer -> Integer -> Term a -> Term a
+       wrap i j e' = if i<=j then e' else PBrk (origin e') e'
+       insPar :: (Traced a) => Integer -> Term a -> Term a
+       insPar i (PEqu o l r) = wrap i     0 (PEqu o (insPar 1 l) (insPar 1 r))
+       insPar i (PImp o l r) = wrap i     0 (PImp o (insPar 1 l) (insPar 1 r))
+       insPar i (PIsc o l r) = wrap (i+1) 2 (PIsc o (insPar 2 l) (insPar 2 r))
+       insPar i (PUni o l r) = wrap (i+1) 2 (PUni o (insPar 2 l) (insPar 2 r))
+       insPar i (PDif o l r) = wrap i     4 (PDif o (insPar 5 l) (insPar 5 r))
+       insPar i (PLrs o l r) = wrap i     6 (PLrs o (insPar 7 l) (insPar 7 r))
+       insPar i (PRrs o l r) = wrap i     6 (PRrs o (insPar 7 l) (insPar 7 r))
+       insPar i (PDia o l r) = wrap i     6 (PDia o (insPar 7 l) (insPar 7 r))
+       insPar i (PCps o l r) = wrap (i+1) 8 (PCps o (insPar 8 l) (insPar 8 r))
+       insPar i (PRad o l r) = wrap (i+1) 8 (PRad o (insPar 8 l) (insPar 8 r))
+       insPar i (PPrd o l r) = wrap (i+1) 8 (PPrd o (insPar 8 l) (insPar 8 r))
+       insPar _ (PKl0 o e)   = PKl0 o (insPar 10 e)
+       insPar _ (PKl1 o e)   = PKl1 o (insPar 10 e)
+       insPar _ (PFlp o e)   = PFlp o (insPar 10 e)
+       insPar _ (PCpl o e)   = PCpl o (insPar 10 e)
+       insPar i (PBrk _ e)   = insPar i e
+       insPar _ x            = x
+
+--used to compose error messages at p2a time
+instance ShowADL P_Concept where
+ showADL = name
+
+instance ShowADL PAclause where
+    showADL = showPAclause "\n "
+
+showPAclause :: String -> PAclause -> String
+showPAclause indent pa@Do{}
+       = ( case paSrt pa of
+            Ins -> "INSERT INTO "
+            Del -> "DELETE FROM ")++
+         showREL (paTo pa) ++
+         indent++" SELECTFROM "++
+         showADL (paDelta pa)++
+         indent++motivate indent "TO MAINTAIN " (paMotiv pa)
+showPAclause indent (New c clause cj_ruls)
+       = "NEW x:"++show c++";"++indent'++showPAclause indent' (clause "x")++motivate indent "MAINTAINING" cj_ruls
+         where indent'  = indent++"  "
+showPAclause indent (Rmv c clause cj_ruls)
+       = "REMOVE x:"++show c++";"++indent'++showPAclause indent' (clause "x")++motivate indent "MAINTAINING" cj_ruls
+         where indent'  = indent++"  "
+showPAclause indent (CHC ds cj_ruls)
+       = "ONE OF "++intercalate indent' [showPAclause indent' d | d<-ds]++motivate indent "MAINTAINING" cj_ruls
+         where indent'  = indent++"       "
+showPAclause indent (GCH ds cj_ruls)
+       = "ONE NONEMPTY ALTERNATIVE OF "++intercalate indent'
+         ["PICK a,b FROM "++showADL links++indent'++"THEN "++showPAclause (indent'++"     ") p| (_,links,p)<-ds]++
+         motivate indent "MAINTAINING" cj_ruls
+         where indent'  = indent++"       "
+showPAclause indent (ALL ds cj_ruls)
+       = "ALL of "++intercalate indent' [showPAclause indent' d | d<-ds]++motivate indent "MAINTAINING" cj_ruls
+         where indent'  = indent++"       "
+showPAclause indent (Nop cj_ruls)
+       = "DO NOTHING"++motivate indent "TO MAINTAIN" cj_ruls
+showPAclause indent (Blk cj_ruls)
+       = "BLOCK"++motivate indent "CANNOT CHANGE" cj_ruls
+showPAclause  _ (Let _ _ _)  = fatal 55 "showPAclause is missing for `Let`. Contact your dealer!"
+showPAclause  _ (Ref _)      = fatal 56 "showPAclause is missing for `Ref`. Contact your dealer!"
+
+motivate :: [Char] -> [Char] -> [(Expression, [Rule])] -> [Char]
+motivate indent motive motives = concat [ indent++showConj cj_rul | cj_rul<-motives ]
+   where showConj (conj,rs) = "("++motive++" "++showADL conj++" FROM "++intercalate ", " (map name rs) ++")"
+ src/Database/Design/Ampersand/FSpec/ShowECA.hs view
@@ -0,0 +1,20 @@+module Database.Design.Ampersand.FSpec.ShowECA (showECA) where
+
+import Database.Design.Ampersand.Core.AbstractSyntaxTree
+import Database.Design.Ampersand.FSpec.ShowADL (showPAclause, showREL)
+
+class ECA a where
+  showECA :: String -> a -> String
+
+instance ECA ECArule where
+  showECA indent er = showECA indent (ecaTriggr er) ++ " EXECUTE    -- (ECA rule "
+                                                    ++ show (ecaNum er)
+                                                    ++ ")"
+                                                    ++
+                     indent ++ showECA indent (ecaAction er)
+instance ECA Event where
+  showECA _ (On Ins rel) = "ON INSERT Delta IN " ++ showREL rel
+  showECA _ (On Del rel) = "ON DELETE Delta FROM " ++ showREL rel
+
+instance ECA PAclause where
+  showECA indent = showPAclause indent

+ src/Database/Design/Ampersand/FSpec/ShowHS.hs view
@@ -0,0 +1,811 @@+{-# OPTIONS_GHC -XFlexibleInstances #-}
+module Database.Design.Ampersand.FSpec.ShowHS (ShowHS(..),ShowHSName(..),fSpec2Haskell,haskellIdentifier) where
+import Database.Design.Ampersand.Core.ParseTree
+import Database.Design.Ampersand.Core.AbstractSyntaxTree
+import Text.Pandoc hiding (Meta)
+import Data.Char                  (isAlphaNum)
+import Database.Design.Ampersand.Basics hiding (indent)
+import Database.Design.Ampersand.FSpec.Plug
+import Database.Design.Ampersand.FSpec.FSpec
+import Database.Design.Ampersand.FSpec.ShowADL    (ShowADL(..))  -- for traceability, we generate comments in the Haskell code.
+--import Database.Design.Ampersand.FSpec.FPA   (fpa)
+import Data.List
+import Database.Design.Ampersand.Classes
+import qualified Database.Design.Ampersand.Input.ADL1.UU_Scanner
+import Database.Design.Ampersand.Misc
+import Data.Hashable
+import Data.Ord
+import Data.Function
+
+fatal :: Int -> String -> a
+fatal = fatalMsg "FSpec.ShowHS"
+
+fSpec2Haskell :: FSpec -> String
+fSpec2Haskell fSpec
+        = "{-# OPTIONS_GHC -Wall #-}"
+          ++"\n{-Generated code by "++ampersandVersionStr++" at "++show (genTime (getOpts fSpec))++"-}"
+          ++"\nmodule Main where\n"
+          ++"\nimport Database.Design.Ampersand"
+          ++"\nimport Text.Pandoc hiding (Meta)"
+          ++"\nimport Prelude hiding (writeFile,readFile,getContents,putStr,putStrLn)"
+          ++"\n"
+          ++"\nmain :: IO ()"
+          ++"\nmain = do (getOpts fSpec) <- getOptions"
+          ++"\n          putStr (showHS (getOpts fSpec) \"\\n  \" fSpec_"++baseName (getOpts fSpec)++")\n"
+          ++"\nfSpec_"++baseName (getOpts fSpec)++" :: FSpec"
+          ++"\nfSpec_"++baseName (getOpts fSpec)++" =\n  "++showHS (getOpts fSpec) "\n  " fSpec
+
+wrap :: String->String->(String->a->String)->[a]->String
+wrap initStr indent f xs
+ = initStr++
+   case xs of
+     []  -> "[]"
+     [x] -> "[ "++f (indent++"  ") x++" ]"
+     _   -> "[ "++intercalate (indent++", ") [f (indent++"  ") x | x<-xs]++indent++"]"
+
+class ShowHSName a where
+ showHSName :: a -> String
+
+class ShowHS a where
+ showHS :: Options -> String -> a -> String
+
+instance ShowHSName a => ShowHSName [a] where
+ showHSName xs = "["++intercalate "," (map showHSName xs)++"]"
+
+instance ShowHS a => ShowHS [a] where
+ showHS opts indent = wrap "" (indent++" ") (showHS opts)
+
+instance ShowHSName a => ShowHSName (Maybe a) where
+ showHSName Nothing  = "Nothing"
+ showHSName (Just x) = showHSName x
+
+instance ShowHS a => ShowHS (Maybe a) where
+ showHS _ _ Nothing  = "Nothing"
+ showHS opts indent (Just x) = "Just (" ++ showHS opts indent x ++ ")"
+
+instance (ShowHSName a , ShowHSName b) => ShowHSName (a,b) where
+ showHSName (a,b) = "( "++showHSName a++" , "++showHSName b++" )"
+-- | The following is used to showHS opts for signs: (Concept, Concept)
+--   instance (ShowHS a , ShowHS b) => ShowHS (a,b) where
+--    showHS opts indent (a,b) = "("++showHS opts (indent++" ") a++","++showHS opts (indent++" ") b++")"
+
+instance ShowHSName PlugSQL where
+ showHSName plug = haskellIdentifier ("plug_"++name plug)
+
+instance ShowHS PlugSQL where
+ showHS opts indent plug
+   = case plug of
+       TblSQL{} -> intercalate indent
+                   ["let " ++ intercalate (indent++"    ")
+                                          [showHSName f++indent++"     = "++showHS opts (indent++"       ") f | f<-fields plug] ++indent++"in"
+                   ,"TblSQL { sqlname = " ++ (show.name) plug
+                   ,"       , fields  = ["++intercalate ", " (map showHSName (fields plug))++"]"
+                   ,"       , cLkpTbl = [ "++intercalate (indent++"                   , ") ["("++showHSName c++", "++showHSName cn++")" | (c,cn)<-cLkpTbl plug] ++ "]"
+                   ,"       , mLkpTbl = [ "++intercalate (indent++"                   , ") ["("++showHS opts "" r++", "++showHSName ms++", "++showHSName mt++")" | (r,ms,mt)<-mLkpTbl plug] ++ "]"
+               --    ,"       , sqlfpa  = " ++ showHS opts "" (fpa plug)
+                   ,"       }"
+                   ]
+       BinSQL{} -> intercalate indent
+                   ["let " ++ showHSName (fst (columns plug))++indent++"     = "++showHS opts (indent++"       ") (fst (columns plug))
+                           ++ (indent++"    ") ++ showHSName (snd (columns plug))++indent++"     = "++showHS opts (indent++"       ") (snd (columns plug))
+                           ++indent++"in"
+                   ,"BinSQL { sqlname = " ++ (show.name) plug
+                   ,"       , columns = ("++showHSName (fst (columns plug))++ ", " ++showHSName (snd (columns plug))++")"
+                   ,"       , cLkpTbl = [ "++intercalate (indent++"                   , ") ["("++showHSName c++", "++showHSName cn++")" | (c,cn)<-cLkpTbl plug] ++ "]"
+                   ,"       , mLkp = "++showHS opts "" (mLkp plug)
+               --    ,"       , sqlfpa  = " ++ showHS opts "" (fpa plug)
+                   ,"       }"
+                   ]
+       ScalarSQL{} -> intercalate indent
+                   ["ScalarSQL { sqlname   = "++ (show.name) plug
+                   ,"          , sqlColumn = "++ showHS opts (indent++"                     ") (sqlColumn plug)
+                   ,"          , cLkp      = "++ showHSName (cLkp plug)
+               --    ,"          , sqlfpa    = "++ showHS opts "" (fpa plug)
+                   ,"          }"
+                   ]
+
+instance ShowHSName (ECArule) where
+ showHSName r = "ecaRule"++show (ecaNum r)
+
+instance ShowHS (ECArule) where
+ showHS opts indent r
+   =         "ECA { ecaTriggr = " ++ showHS opts "" (ecaTriggr r) ++
+     indent++"    , ecaDelta  = " ++ showHSName (ecaDelta r)++
+     indent++"    , ecaAction = " ++ showHS opts (indent++"                  ")  (ecaAction r)++
+     indent++"    , ecaNum    = " ++ show (ecaNum r)++
+     indent++"    }"
+
+instance ShowHS Event where
+ showHS _ indent e
+   = if "\n" `isPrefixOf` indent
+     then "On " ++ show (eSrt e)++indent++"   " ++ showHSName (eDcl e)++indent++"   "
+     else "On " ++ show (eSrt e)++          " " ++ showHSName (eDcl e)++           ""
+
+instance ShowHS (InsDel, Expression, PAclause) where
+ showHS opts indent (tOp, links, p)
+   = "( "++show tOp++indent++", "++showHS opts (indent++"  ") links++indent++", "++showHS opts (indent++"  ") p++indent++")"
+
+instance ShowHS PAclause where
+ showHS opts indent p
+   = case p of
+        CHC{} -> wrap "CHC " (indent ++"    ") (showHS opts) (paCls p)++
+                 wrap (if null ms then "" else indent ++"    ") (indent ++"    ") showMotiv ms
+        GCH{} -> wrap "GCH " (indent ++"    ") (showHS opts) (paGCls p)++
+                 wrap (if null ms then "" else indent ++"    ") (indent ++"    ") showMotiv ms
+        ALL{} -> wrap "ALL " (indent ++"    ") (showHS opts) (paCls p)++
+                 wrap (if null ms then "" else indent ++"    ") (indent ++"    ") showMotiv ms
+        Do{}  ->  "Do "++show (paSrt p)++" "++showHSName (paTo p)++
+                         indent++"       ("++showHS opts (indent++"        ") (paDelta p)++indent++"       )"++
+                 wrap (if null ms then "" else indent ++"    ") (indent ++"    ") showMotiv ms
+        New{} -> "New ("++showHS opts "" (paCpt p)++")"++
+                 indent++"    (\\x->"++showHS opts (indent++"        ") (paCl p "x")++indent++"    )"++
+                 wrap (if null ms then "" else indent ++"    ") (indent ++"    ") showMotiv ms
+        Rmv{} -> "Rmv ("++showHS opts "" (paCpt p)++")"++
+                 indent++"    (\\x->"++showHS opts (indent++"        ") (paCl p "x")++indent++"    )"++
+                 wrap (if null ms then "" else indent ++"    ") (indent ++"    ") showMotiv ms
+        Nop{} -> "Nop "++wrap "" (indent ++"    ") showMotiv ms
+        Blk{} -> "Blk "++wrap "" (indent ++"    ") showMotiv ms
+        Let{} -> wrap "Let " (indent ++"    ") (showHS opts) (paCls p)++
+                 "TODO: paBody of Let clause"++
+                 wrap (if null ms then "" else indent ++"    ") (indent ++"    ") showMotiv ms
+        Ref{} -> "Ref "++paVar p
+     where ms = paMotiv p
+           showMotiv ind (conj,rs) = "( "++showHS opts (ind++"  ") conj++" -- conjunct:  "++showADL conj++ind++", "++showHSName rs++ind++")"
+
+instance ShowHSName SqlField where
+ showHSName sqFd = haskellIdentifier ("sqlFld_"++fldname sqFd)
+
+instance ShowHS SqlField where
+ showHS opts indent sqFd
+   = intercalate indentA
+       [  "Fld { fldname = " ++ show (fldname sqFd)
+       ,      ", fldexpr = " ++ showHS opts indentB (fldexpr sqFd)
+       ,      ", fldtype = " ++ showHS opts "" (fldtype sqFd)
+       ,      ", flduse  = " ++ showHS opts "" (flduse sqFd)
+       ,      ", fldnull = " ++ show (fldnull sqFd)
+       ,      ", flduniq = " ++ show (flduniq sqFd)
+       ,      "}"
+       ] where indentA = indent ++"    "         -- adding the width of "Fld "
+               indentB = indentA++"            " -- adding the width of ", fldexpr = "
+
+instance ShowHS SqlFieldUsage where
+ showHS _ _ (TableKey isPrimary aCpt) = "TableKey "  ++show isPrimary++" "++showHSName aCpt
+ showHS _ _ (ForeignKey aCpt)         = "ForeignKey "++showHSName aCpt
+ showHS _ _ PlainAttr                 = "PlainAttr "
+
+instance ShowHS SqlType where
+ showHS _ indent (SQLChar i)    = indent++"SQLChar   "++show i
+ showHS _ indent SQLBlob        = indent++"SQLBlob   "
+ showHS _ indent SQLPass        = indent++"SQLPass   "
+ showHS _ indent SQLSingle      = indent++"SQLSingle "
+ showHS _ indent SQLDouble      = indent++"SQLDouble "
+ showHS _ indent SQLText        = indent++"SQLText   "
+ showHS _ indent (SQLuInt i)    = indent++"SQLuInt   "++show i
+ showHS _ indent (SQLsInt i)    = indent++"SQLsInt   "++show i
+ showHS _ indent SQLId          = indent++"SQLId     "
+ showHS _ indent (SQLVarchar i) = indent++"SQLVarchar "++show i
+ showHS _ indent SQLBool        = indent++"SQLBool   "
+
+instance ShowHSName Quad where
+ showHSName q
+   = haskellIdentifier ("quad_"++(showHSName.qDcl) q++"_"++(name.qRule) q)
+
+instance ShowHS Quad where
+ showHS _ indent q
+   = intercalate indent
+            [ "Quad{ qDcl     = " ++ showHSName (qDcl q)
+            , "    , qRule    = " ++ showHSName (qRule q)
+            , wrap "    , qConjuncts = " newindent (\_->showHSName) (qConjuncts q)
+            , "    }"
+            ]
+    where
+      newindent = indent ++ "                 "
+
+instance ShowHS Fswitchboard where
+ showHS opts indent fsb
+   = intercalate indent
+       [ "Fswtch { fsbEvIn  = " ++ showHS opts newindent (fsbEvIn  fsb)
+       , "       , fsbEvOut = " ++ showHS opts newindent (fsbEvOut fsb)
+       ,wrap
+         "       , fsbConjs = " newindent' (\_->shConj) (fsbConjs  fsb)
+       ,wrap
+         "       , fsbECAs  = " newindent' (\_->showHSName) (fsbECAs  fsb)
+       , "       }"
+       ]
+    where
+      newindent   = indent ++ "                   "
+      newindent'  = newindent ++ " "
+      newindent'' = newindent' ++ "    "
+      shConj (r,conj) = "( "++showHSName r++newindent++"   , "++showHS opts newindent'' conj++newindent++"   )"
+
+instance ShowHS DnfClause where
+ showHS opts indent dnf
+   = intercalate indent
+       [ wrap "Dnf " (indent++"    ") (\_->showHS opts (indent++"      ")) (antcs dnf)
+       , wrap "    " (indent++"    ") (\_->showHS opts (indent++"      ")) (conss dnf)
+       ]
+
+instance ShowHSName Conjunct where
+ showHSName x = haskellIdentifier (rc_id x)
+
+instance ShowHS Conjunct where
+ showHS opts indent x
+   = intercalate (indent ++"    ")
+       [   "Cjct{ rc_id         = " ++ show (rc_id x)
+       ,       ", rc_orgRules   = " ++ "[ "++intercalate (", ") (map showHSName (rc_orgRules x))++"]"
+       ,       ", rc_conjunct   = " ++ showHS opts indentA (rc_conjunct x)
+       , wrap  ", rc_dnfClauses = " indentA (\_->showHS opts (indentA++"  ")) (rc_dnfClauses x)
+       ,       "}"
+       ]
+     where indentA = indent ++"                    "
+
+instance ShowHSName FSpec where
+ showHSName fSpec = haskellIdentifier ("fSpc_"++name fSpec)
+
+instance ShowHS FSpec where
+ showHS opts indent fSpec
+  = intercalate (indent ++"    ")
+        [ "FSpec{ fsName        = " ++ show (name fSpec)
+        ,wrap ", fspos         = " indentA (showHS opts) (fspos fSpec)
+        ,     ", fsLang        = " ++ show (fsLang fSpec) ++ "  -- the default language for this specification"
+        ,     ", themes        = " ++ show (themes fSpec) ++ "  -- the names of themes to be printed in the documentation, meant for partial documentation.  Print all if empty..."
+        ,wrap ", pattsInScope  = " indentA (\_->showHSName) (pattsInScope fSpec)
+        ,wrap ", rulesInScope  = " indentA (\_->showHSName) (rulesInScope fSpec)
+        ,wrap ", declsInScope  = " indentA (\_->showHSName) (declsInScope fSpec)
+        ,wrap ", cDefsInScope  = " indentA (\_->showHS opts (indentA++"  ")) (cDefsInScope fSpec)
+        ,wrap ", gensInScope   = " indentA (showHS opts)   (gensInScope fSpec)
+        ,wrap ", vplugInfos    = " indentA (\_->showHS opts (indentA++"  ")) (vplugInfos fSpec)
+        ,wrap ", plugInfos     = " indentA (\_->showHS opts (indentA++"  ")) (plugInfos  fSpec)
+        ,     ", interfaceS    = interfaceS'"
+        ,     ", interfaceG    = interfaceG'"
+        ,wrap ", fActivities   = " indentA (\_->showHS opts (indentA++"  ")) (fActivities fSpec)
+        ,     ", fRoleRels     = " ++
+              case fRoleRels fSpec of
+                []        -> "[]"
+                [(r,rel)] -> "[ ("++show r++", "++showHS opts "" rel++") ]"
+                _         -> "[ "++intercalate (indentA++", ") ["("++show r++","++showHS opts "" rel++")" | (r,rel)<-fRoleRels fSpec]++indentA++"]"
+        ,     ", fRoleRuls     = " ++showHS opts indentA (fRoleRuls fSpec)
+        ,wrap ", fRoles        = " indentA (showHS opts)    (fRoles fSpec)
+        ,wrap ", vrules        = " indentA (\_->showHSName) (vrules fSpec)
+        ,wrap ", grules        = " indentA (\_->showHSName) (grules fSpec)
+        ,wrap ", invariants    = " indentA (\_->showHSName) (invariants fSpec)
+        ,wrap ", fallRules     = " indentA (\_->showHSName) (fallRules fSpec)
+        ,wrap ", allUsedDecls  = " indentA (\_->showHSName) (allUsedDecls fSpec)
+        ,wrap ", allDecls      = " indentA (\_->showHSName) (allDecls fSpec)
+        ,wrap ", vrels         = " indentA (\_->showHSName) (vrels fSpec)
+        ,wrap ", allConcepts   = " indentA (\_->showHSName) (allConcepts fSpec)
+        ,wrap ", kernels       = " indentA (\_->showHSName) (kernels fSpec)
+        ,wrap ", vIndices      = " indentA (\_->showHSName) (vIndices fSpec)
+        ,wrap ", vviews        = " indentA (\_->showHSName) (vviews fSpec)
+        ,wrap ", vgens         = " indentA (showHS opts)    (vgens fSpec)
+        ,wrap ", fsisa         = " indentA (\_->showHSName) (fsisa fSpec)
+        ,wrap ", vconjs        = " indentA (\_->showHSName) (vconjs fSpec)
+        ,wrap ", vquads        = " indentA (\_->showHSName) (vquads fSpec)
+        ,wrap ", vEcas         = " indentA (\_->showHSName) (vEcas fSpec)
+        ,     ", fSwitchboard  = "++showHS opts indentA (fSwitchboard fSpec)
+        ,wrap ", vpatterns     = " indentA (\_->showHSName) (vpatterns fSpec)
+        ,wrap ", conceptDefs   = " indentA (showHS opts)    (conceptDefs fSpec)
+        ,wrap ", fSexpls       = " indentA (showHS opts)    (fSexpls fSpec)
+        ,     ", metas         = allMetas"
+        ,wrap ", initialPops   = " indentA (showHS opts)   (initialPops fSpec)
+        ,wrap ", allViolations = " indentA showViolatedRule (allViolations fSpec)
+        ,wrap ", allExprs      = " indentA (showHS opts)    (allExprs fSpec)
+        ,"}"
+        ] ++
+    indent++"where"++
+     "\n -- ***Interfaces Specified in Ampersand script***: "++
+    indent++" interfaceS' = "++(if null (interfaceS fSpec) then "[]" else
+                              "[ "++intercalate (indentB++"  , ") (map showHSName (interfaceS fSpec))++indentB++"  ]")++
+     "\n -- ***Activities Generated by the Ampersand compiler ***: " ++
+    indent++" interfaceG' = "++(if null (interfaceG fSpec) then "[]" else
+                              "[ "++intercalate (indentB++", ") (map showHSName (interfaceG fSpec))++indentB++"]")++
+    indent++" allMetas = "++(if null (metas fSpec) then "[]" else
+                              "[ "++intercalate (indentB++", ") (map (showHS opts (indent ++ "         ")) (metas fSpec))++indentB++"]") ++
+
+-- WHY?  staan hier verschillende lijstjes met interfaces?
+-- BECAUSE! Een Ampersand engineer besteedt veel tijd om vanuit een kennismodel (lees: een graaf met concepten en relaties)
+--          alle interfaces met de hand te verzinnen.
+--          Je kunt natuurlijk ook een interfaces-generator aan het werk zetten, die een aantal interfaces klaarzet bij wijze
+--          van steiger (scaffold). Dat bespaart een hoop werk. De functie interfaceG is zo'n generator.
+--          Door de gegenereerde interfaces af te drukken, kun je dus heel snel Ampersand sourcecode maken met correct-vertaalbare interfaces.
+--          Heb je eenmaal een goed werkend pakket interfaces, dan wil je wellicht alleen de door jezelf gespecificeerde interfaces
+--          gebruiken. Dat gebeurt in interfaceS.
+
+    (if null  (interfaceS fSpec) then ""  else
+     "\n -- *** User defined interfaces (total: "++(show.length.interfaceS) fSpec++" interfaces) ***: "++
+     concat [indent++" "++showHSName s++indent++"  = "++showHS opts (indent++"    ") s | s<-interfaceS fSpec]++"\n"
+    )++
+    (if null (interfaceG fSpec ) then "" else
+     "\n -- *** Generated interfaces (total: "++(show.length.interfaceG) fSpec++" interfaces) ***: "++
+     concat [indent++" "++showHSName x++indent++"  = "++showHS opts (indent++"    ") x |x<-interfaceG fSpec ]++"\n"
+    )++
+    (let ds fs = allDecls fs `uni` allUsedDecls fs `uni` vrels fSpec `uni` (nub . map qDcl . vquads) fs in
+     if null (ds fSpec)     then "" else
+     "\n -- *** Declared relations (in total: "++(show.length.ds) fSpec++" relations) ***: "++
+     concat [indent++" "++showHSName x++indent++"  = "++showHS opts (indent++"    ") x |x<-ds fSpec]++"\n"
+    ) ++
+    (if null (vIndices fSpec)     then "" else
+     "\n -- *** Indices (total: "++(show.length.vIndices) fSpec++" indices) ***: "++
+     concat [indent++" "++showHSName x++indent++"  = "++showHS opts (indent++"    ") x |x<-vIndices fSpec]++"\n"
+    ) ++
+    (if null (vviews fSpec)     then "" else
+     "\n -- *** Views (total: "++(show.length.vviews) fSpec++" views) ***: "++
+     concat [indent++" "++showHSName x++indent++"  = "++showHS opts (indent++"    ") x |x<-vviews fSpec]++"\n"
+    ) ++
+    (if null (vrules   fSpec ) then "" else
+     "\n -- *** User defined rules (total: "++(show.length.vrules) fSpec++" rules) ***: "++
+     concat [indent++" "++showHSName x++indent++"  = "++showHS opts (indent++"    ") x |x<-vrules     fSpec ]++"\n"
+    )++
+    (if null (grules   fSpec ) then "" else
+     "\n -- *** Generated rules (total: "++(show.length.grules) fSpec++" rules) ***: "++
+     concat [indent++" "++showHSName x++indent++"  = "++showHS opts (indent++"    ") x |x<-grules     fSpec ]++"\n"
+    )++
+    (if null (vconjs fSpec ) then "" else
+     "\n -- *** Conjuncts (total: "++(show.length.vconjs) fSpec++" conjuncts) ***: "++
+     concat [indent++" "++showHSName x++indent++"  = "++showHS opts (indent++"    ") x |x<-vconjs     fSpec ]++"\n"
+    )++
+    (if null (vquads fSpec ) then "" else
+     "\n -- *** Quads (total: "++(show.length.vquads) fSpec++" quads) ***: "++
+     concat [indent++" "++showHSName x++indent++"  = "++showHS opts (indent++"    ") x |x<-vquads     fSpec ]++"\n"
+    )++
+    (if null (vEcas fSpec ) then "" else
+     "\n -- *** ECA rules (total: "++(show.length.vEcas) fSpec++" ECA rules) ***: "++
+     concat [indent++" "++showHSName eca++indent++"  = "++showHS opts (indent++"    ") eca |eca<-vEcas fSpec ]++"\n"++
+     concat [indent++" "++showHSName rel++indent++"  = "++showHS opts (indent++"    ") rel |rel<-nub(map ecaDelta (vEcas fSpec)) ]++"\n"
+    )++
+    (if null (plugInfos fSpec ) then "" else
+     "\n -- *** PlugInfos (total: "++(show.length.plugInfos) fSpec++" plugInfos) ***: "++
+     concat [indent++" "++showHSName p++indent++"  = "++showHS opts (indent++"    ") p |InternalPlug p<-sortBy (compare `on` name) (plugInfos fSpec) ]++"\n"
+    )++
+    (if null (vpatterns fSpec) then "" else
+     "\n -- *** Patterns (total: "++(show.length.vpatterns) fSpec++" patterns) ***: "++
+     concat [indent++" "++showHSName x++indent++"  = "++showHS opts (indent++"    ") x |x<-vpatterns fSpec]++"\n"
+    )++
+--       (if null (conceptDefs fSpec) then "" else
+--        "\n -- *** ConceptDefs (total: "++(show.length.conceptDefs) fSpec++" conceptDefs) ***: "++
+--        concat [indent++" "++showHSName cd++indent++"  = "++showHS opts (indent++"    ") cd | c<-concs fSpec, cd<-concDefs fSpec c]++"\n"
+--       )++
+    (if null (allConcepts fSpec) then "" else
+     "\n -- *** Concepts (total: "++(show.length.allConcepts) fSpec++" concepts) ***: "++
+     concat [indent++" "++showHSName x++indent++"  = "++showHS opts (indent++"    ") x
+          ++ indent++"    "++showAtomsOfConcept x |x<-sortBy (comparing showHSName) (allConcepts fSpec)]++"\n"
+    )
+        where indentA = indent ++"                      "
+              indentB = indent ++"             "
+              showAtomsOfConcept c =
+                           "-- atoms: [ "++ intercalate indentC strs++"]"
+                  where
+                    strs = map show (sort (atomsOf (vgens fSpec)(initialPops fSpec) c))
+                    indentC = if sum (map length strs) > 300
+                              then indent ++ "    --        , "
+                              else ", "
+              showViolatedRule :: String -> (Rule,Pairs) -> String
+              showViolatedRule indent' (r,ps)
+                 = intercalate indent'
+                     [        " ( "++showHSName r++" -- This is "++(if isSignal r then "a process rule." else "an invariant")++
+                      indent'++" , "++ wrap "" (indent'++"   ") (let showPair _ p = show p --"( "++ (show.fst) p++", "++(show.snd) p++")"
+                                                                   in showPair) ps++
+                      indent'++" )"
+                     ]
+
+instance ShowHS Meta where
+ showHS f i (Meta pos obj nm val) = "Meta ("++showHS f i pos ++ ") "++ show obj ++ " " ++ show nm ++ " " ++ show val
+
+
+instance ShowHSName PlugInfo where
+ showHSName (InternalPlug p) = haskellIdentifier ("ipl_"++name p)-- TODO
+ showHSName (ExternalPlug _) = fatal 336 "a PlugInfo is anonymous with respect to showHS opts"
+
+instance ShowHS PlugInfo where
+ showHS _ _ (InternalPlug p)
+  = "InternalPlug "++showHSName p
+ showHS opts ind (ExternalPlug o)
+  = "ExternalPlug "++showHS opts (ind++"    ") o
+
+instance ShowHS A_RoleRelation where
+ showHS opts ind rr
+  = "RR "++show (rrRoles rr)++" "++showHS opts (ind++"    ") (rrRels rr)++" "++showHS opts (ind++"    ") (rrPos rr)
+instance ShowHS Role where
+ showHS _ ind (Role str) = ind++"Role "++show str
+instance ShowHS P_RoleRule where
+ showHS opts ind rs
+  = "Maintain "++show (mRoles rs)++" "++show (mRules rs)++" "++showHS opts (ind++"    ") (mPos rs)
+instance ShowHS (Role,Rule) where
+ showHS _ _ (rol,rul)
+  = "("++show rol++", "++showHSName rul++")"
+instance ShowHSName FSid where
+ showHSName (FS_id nm ) = haskellIdentifier nm
+
+instance ShowHS FSid where
+ showHS _ _ (FS_id nm)
+   = "(FS_id " ++ show nm ++ ")"
+
+instance ShowHSName Pattern where
+ showHSName pat = haskellIdentifier ("pat_"++name pat)
+
+instance ShowHS Pattern where
+ showHS opts indent pat
+  = intercalate indentA
+     [ "A_Pat { ptnm  = "++show (name pat)
+     , ", ptpos = "++showHS opts "" (ptpos pat)
+     , ", ptend = "++showHS opts "" (ptend pat)
+     , ", ptrls = [" ++intercalate ", " [showHSName r | r<-ptrls pat] ++ concat [" {- no rules -} "        | null (ptrls pat)] ++"]"
+     , wrap ", ptgns = " indentB (showHS opts) (ptgns pat)
+     , ", ptdcs = [ " ++intercalate (indentB++", ") [showHSName d | d<-ptdcs pat] ++ concat [" {- no relations -} " | null (ptdcs pat)] ++indentB++"]"
+     , wrap ", ptups = " indentB (showHS opts) (ptups pat)
+     , wrap ", ptids = " indentB (showHS opts) (ptids pat)
+     , wrap ", ptvds = " indentB (showHS opts) (ptvds pat)
+     , wrap ", ptxps = " indentB (showHS opts) (ptxps pat)
+     , "}"
+     ] where indentA = indent ++"      "     -- adding the width of "A_Pat "
+             indentB = indentA++"          " -- adding the width of ", ptrls = "
+
+instance ShowHS Activity where
+ showHS opts indent act =
+    intercalate indentA
+     [ "Act { actRule   = "++showHSName (actRule act)
+     , wrap ", actTrig   = " indentB (\_->showHSName) (actTrig   act)
+     , wrap ", actAffect = " indentB (\_->showHSName) (actAffect act)
+     , wrap ", actQuads  = " indentB (\_->showHSName) (actQuads  act)
+     , wrap ", actEcas   = " indentB (\_->showHSName) (actEcas   act)
+     , wrap ", actPurp   = " indentB (\_->(showHS opts indentB)) (actPurp act)
+     , "      }"
+     ]
+    where indentA = indent ++replicate (length ("Act "::String)) ' '
+          indentB = indentA++replicate (length (", actAffect = " :: String)) ' '
+
+instance ShowHS PPurpose where
+ showHS opts _ expl =
+    "PRef2 ("++showHS opts "" (pexPos     expl)++") "++
+          "("++showHS opts "" (pexObj     expl)++") "++
+          "("++showHS opts "" (pexMarkup  expl)++") "
+             ++show (intercalate ";" (pexRefIDs expl))++" "
+
+instance ShowHS PRef2Obj where
+ showHS _ _ peObj
+  = case peObj of
+         PRef2ConceptDef str                    -> "PRef2ConceptDef " ++show str
+         PRef2Declaration (PNamedRel _ nm mSgn) -> "PRef2Declaration "++show nm++maybe "" show mSgn
+         PRef2Rule str                          -> "PRef2Rule "       ++show str
+         PRef2IdentityDef str                   -> "PRef2IdentityDef "++show str
+         PRef2ViewDef str                       -> "PRef2ViewDef "    ++show str
+         PRef2Pattern str                       -> "PRef2Pattern "    ++show str
+         PRef2Interface str                     -> "PRef2Interface "  ++show str
+         PRef2Context str                       -> "PRef2Context "    ++show str
+         PRef2Fspc str                          -> "PRef2Fspc "       ++show str
+
+instance ShowHS Purpose where
+ showHS opts _ expla =
+    "Expl "++"("++showHS opts "" (explPos expla)++") "
+           ++"("++showHS opts "" (explObj expla)++") "
+                ++showHS opts "" (explMarkup  expla)++" "
+                ++show (explUserdefd expla)++" "
+                ++show (explRefIds expla)++" "
+
+instance ShowHS ExplObj where
+ showHS opts i peObj = case peObj of
+          ExplConceptDef cd  -> "ExplConceptDef " ++showHS opts i cd
+          ExplDeclaration d  -> "ExplDeclaration "++showHSName d
+          ExplRule str       -> "ExplRule "       ++show str
+          ExplIdentityDef str-> "ExplIdentityDef "++show str
+          ExplViewDef str    -> "ExplViewDef "    ++show str
+          ExplPattern str    -> "ExplPattern "    ++show str
+          ExplInterface str  -> "ExplInterface "  ++show str
+          ExplContext str    -> "ExplContext "    ++show str
+
+instance ShowHS P_Markup where
+ showHS _ indent m
+   = intercalate indent
+     ["P_Markup{ mLang   = "++ show (mLang m)
+     ,"        , mFormat = "++ show (mFormat m)
+     ,"        , mString = "++ show (mString m)
+     ,"        }"
+     ]
+
+instance ShowHS A_Markup where
+ showHS _ indent m
+   = intercalate indent
+     ["A_Markup{ amLang   = "++ show (amLang m)
+     ,"        , amFormat = "++ show (amFormat m)
+     ,"        , amPandoc = "++ show (amPandoc m)
+     ,"        }"
+     ]
+
+instance ShowHS (PairView Expression) where
+  showHS opts indent (PairView pvs) = "PairView "++showHS opts indent pvs
+
+instance ShowHS (PairViewSegment Expression) where
+  showHS _     _ (PairViewText _ txt) = "PairViewText "++show txt
+  showHS opts _ (PairViewExp _ srcOrTgt e) = "PairViewExp "++show srcOrTgt++" ("++showHS opts "" e++")"
+
+instance ShowHSName Rule where
+ showHSName r = haskellIdentifier ("rule_"++ rrnm r)
+
+instance ShowHS Rule where
+ showHS opts indent r@(Ru _ _ _ _ _ _ _ _ _ _ _)  -- This pattern matching occurs so Haskell will detect any change in the definition of Ru.
+   = intercalate indent
+     ["Ru{ rrnm   = " ++ show (rrnm   r)
+     ,"  , rrexp  = -- " ++ showADL (rrexp  r) ++ indent++"             " ++ showHS opts (indent++"             ") (rrexp  r)
+     ,"  , rrfps  = " ++ showHS opts "" (rrfps  r)
+     ,"  , rrmean = " ++ showHS opts (indent++"             ") (rrmean r)
+     ,"  , rrmsg  = " ++ showHS opts "" (rrmsg  r)
+     ,"  , rrviol = " ++ showHS opts "" (rrviol r)
+     ,"  , rrtyp  = " ++ showHS opts "" (rrtyp  r)
+     ,"  , rrdcl  = " ++ case rrdcl r of
+                           Just (p,d) -> "Just ("++showHSName p++", "++showHSName d++" )"
+                           Nothing    -> "Nothing"
+     ,"  , r_env  = " ++ show (r_env  r)
+     ,"  , r_usr  = " ++ show (r_usr  r)
+     ,"  , isSignal = " ++ show (isSignal  r)
+     ,"  }"
+     ]
+
+instance ShowHS AMeaning where
+  showHS opts indent (AMeaning x) = "AMeaning " ++ showHS opts (indent++"        ") x
+
+instance ShowHS RuleType where
+  showHS _ _ Truth          = "Truth"
+  showHS _ _ Equivalence    = "Equivalence"
+  showHS _ _ Implication    = "Implication"
+
+instance ShowHSName IdentityDef where
+ showHSName identity = haskellIdentifier ("identity_"++name identity)
+
+instance ShowHS IdentityDef where
+ showHS opts indent identity
+  = "Id ("++showHS opts "" (idPos identity)++") "++show (idLbl identity)++" ("++showHSName (idCpt identity)++")"
+    ++indent++"  [ "++intercalate (indent++"  , ") (map (showHS opts indent) $ identityAts identity)++indent++"  ]"
+
+instance ShowHS IdentitySegment where
+ showHS opts indent (IdentityExp objDef) = "IdentityExp ("++ showHS opts indent objDef ++ ")"
+
+instance ShowHSName ViewDef where
+ showHSName vd = haskellIdentifier ("vdef_"++name vd)
+
+instance ShowHS ViewDef where
+ showHS opts indent vd
+  = "Vd ("++showHS opts "" (vdpos vd)++") "++show (vdlbl vd)++" "++showHSName (vdcpt vd)
+    ++indent++"  [ "++intercalate (indent++"  , ") (map (showHS opts indent) $ vdats vd)++indent++"  ]"
+
+--instance ShowHSName ViewSegment where
+-- showHSName vd = haskellIdentifier ("vdef_"++name vd)
+
+instance ShowHS ViewSegment where
+ showHS _     _      (ViewText str)   = "ViewText "++show str
+ showHS _     _      (ViewHtml str)   = "ViewHtml "++show str
+ showHS opts indent (ViewExp objDef) = "ViewExp "++ showHS opts (indent++"            ") objDef
+
+instance ShowHS Population where
+ showHS _ indent pop
+  = case pop of
+      PRelPopu{} -> "PRelPopu { popdcl = "++showHSName (popdcl pop)
+          ++indent++"         , popps  = [ "++intercalate
+           (indent++"                    , ") (map show (popps pop))
+          ++indent++"                    ]"
+          ++indent++"         }"
+      PCptPopu{} -> "PCptPopu { popcpt = "++showHSName (popcpt pop)
+          ++indent++"         , popas  = [ "++intercalate
+           (indent++"                    , ") (map show (popas pop))
+          ++indent++"                    ]"
+          ++indent++"         }"
+
+instance ShowHSName ObjectDef where
+ showHSName obj = haskellIdentifier ("oDef_"++name obj)
+
+instance ShowHS ObjectDef where
+ showHS opts indent r
+  = intercalate indent
+        ["Obj{ objnm   = " ++ show(objnm r)
+        ,"   , objpos  = " ++ showHS opts "" (objpos r)
+        ,"   , objctx  = " ++ showHS opts (indent++"               ") (objctx r)
+        ,"   , objmsub = " ++ showHS opts (indent++"                    ") (objmsub r)
+        ,"   , objstrs = " ++ show(objstrs r)
+        ]++indent++"   }"
+
+instance ShowHSName Interface where
+ showHSName obj = haskellIdentifier ("ifc_"++name obj)
+
+instance ShowHS Interface where
+ showHS opts indent ifc
+  = intercalate indent
+        [ "Ifc { ifcClass = " ++ show (ifcClass ifc) 
+        , wrap "    , ifcParams = " (indent++"                  ") (showHS opts) (ifcParams ifc)
+        , "    , ifcArgs   = " ++ show(ifcArgs ifc)
+        , "    , ifcRoles  = " ++ show(ifcRoles ifc)
+        , "    , ifcObj"++indent++"       = " ++ showHS opts (indent++"         ") (ifcObj ifc)
+        , "    , ifcEcas   = " ++ showHS opts (indent++"                 ") (ifcEcas ifc)
+        , wrap "    , ifcControls = " (indent++"                  ") (\_->showHSName) (ifcControls ifc)
+        , "    , ifcPos    = " ++ showHS opts "" (ifcPos ifc)
+        , "    , ifcPrp    = " ++ show(ifcPrp ifc)
+        ]++indent++"    }"
+
+instance ShowHS SubInterface where
+ showHS _     _      (InterfaceRef n) = "InterfaceRef "++show n
+ showHS opts indent (Box x cl objs) = "Box ("++showHS opts indent x++") ("++showHS opts indent cl++")"++indent++"     ("++showHS opts (indent++"     ") objs++")"
+
+instance ShowHS Expression where
+ showHS opts indent (EEqu (l,r)) = "EEqu ("++showHS opts (indent++"      ") l++indent++"     ,"++showHS opts (indent++"      ") r++indent++"     )"
+ showHS opts indent (EImp (l,r)) = "EImp ("++showHS opts (indent++"      ") l++indent++"     ,"++showHS opts (indent++"      ") r++indent++"     )"
+ showHS opts indent (EIsc (l,r)) = "EIsc ("++showHS opts (indent++"      ") l++indent++"     ,"++showHS opts (indent++"      ") r++indent++"     )"
+ showHS opts indent (EUni (l,r)) = "EUni ("++showHS opts (indent++"      ") l++indent++"     ,"++showHS opts (indent++"      ") r++indent++"     )"
+ showHS opts indent (EDif (l,r)) = "EDif ("++showHS opts (indent++"      ") l++indent++"     ,"++showHS opts (indent++"      ") r++indent++"     )"
+ showHS opts indent (ELrs (l,r)) = "ELrs ("++showHS opts (indent++"      ") l++indent++"     ,"++showHS opts (indent++"      ") r++indent++"     )"
+ showHS opts indent (ERrs (l,r)) = "ERrs ("++showHS opts (indent++"      ") l++indent++"     ,"++showHS opts (indent++"      ") r++indent++"     )"
+ showHS opts indent (EDia (l,r)) = "EDia ("++showHS opts (indent++"      ") l++indent++"     ,"++showHS opts (indent++"      ") r++indent++"     )"
+ showHS opts indent (ECps (l,r)) = "ECps ("++showHS opts (indent++"      ") l++indent++"     ,"++showHS opts (indent++"      ") r++indent++"     )"
+ showHS opts indent (ERad (l,r)) = "ERad ("++showHS opts (indent++"      ") l++indent++"     ,"++showHS opts (indent++"      ") r++indent++"     )"
+ showHS opts indent (EPrd (l,r)) = "EPrd ("++showHS opts (indent++"      ") l++indent++"     ,"++showHS opts (indent++"      ") r++indent++"     )"
+ showHS opts indent (EKl0 e    ) = "EKl0 ("++showHS opts (indent++"      ") e++")"
+ showHS opts indent (EKl1 e    ) = "EKl1 ("++showHS opts (indent++"      ") e++")"
+ showHS opts indent (EFlp e    ) = "EFlp ("++showHS opts (indent++"      ") e++")"
+ showHS opts indent (ECpl e    ) = "ECpl ("++showHS opts (indent++"      ") e++")"
+ showHS opts indent (EBrk e    ) = "EBrk ("++showHS opts (indent++"      ") e++")"
+ showHS _    _      (EDcD dcl  ) = "EDcD "++showHSName dcl
+ showHS _    _      (EDcI c    ) = "EDcI "++showHSName c
+ showHS opts _      (EEps i sgn) = "EEps ("++showHS opts "" i++") ("++showHS opts "" sgn++")"
+ showHS opts _      (EDcV sgn  ) = "EDcV ("++showHS opts "" sgn++")"
+ showHS _    _      (EMp1 a c  ) = "EMp1 " ++show a++" "++showHSName c
+
+instance ShowHS Sign where
+ showHS _ _ sgn = "Sign "++showHSName (source sgn)++" "++showHSName (target sgn)
+
+instance ShowHS A_Gen where
+ showHS _ _ gen =
+   case gen of
+     Isa{} -> "Isa "++showHSName (genspc gen)++" "++showHSName (gengen gen)++" "
+     IsE{} -> "IsE "++showHSName (genspc gen)++" ["++intercalate ", " (map showHSName (genrhs gen))++"] "
+
+instance ShowHSName Declaration where
+ showHSName d@Isn{}       = haskellIdentifier ("rel_"++name d++"_"++name (source d)) -- identity relation
+ showHSName d@Vs{}        = haskellIdentifier ("rel_"++name d++"_"++name (source d)++"_"++name (target d)) -- full relation
+ showHSName d | decusr d  = haskellIdentifier ("rel_"++name d++"_"++name (source d)++"_"++name (target d)) -- user defined relations
+              | deciss d  = haskellIdentifier ("sgn_"++name d++"_"++name (source d)++"_"++name (target d)) -- relations generated for signalling
+              | otherwise = haskellIdentifier ("vio_"++name d++"_"++name (source d)++"_"++name (target d)) -- relations generated per rule
+
+instance ShowHS Declaration where
+ showHS opts indent d
+    = case d of
+       Sgn{}     -> intercalate indent
+                     ["Sgn{ decnm   = " ++ show (decnm d)
+                     ,"   , decsgn  = " ++ showHS opts "" (sign d)
+                     ,"   , decprps = " ++ showL(map (showHS opts "") (decprps d))
+                     ,"   , decprps_calc = " ++ case decprps_calc d of
+                                                 Nothing -> "Nothing"
+                                                 Just ps -> "Just "++showL(map (showHS opts "") ps)
+                     ,"   , decprL  = " ++ show (decprL d)
+                     ,"   , decprM  = " ++ show (decprM d)
+                     ,"   , decprR  = " ++ show (decprR d)
+                     ,"   , decMean = " ++ show (decMean d)
+                     ,"   , decfpos = " ++ showHS opts "" (decfpos d)
+                     ,"   , deciss  = " ++ show (deciss d)
+                     ,"   , decusr  = " ++ show (decusr d)
+                     ,"   , decpat  = " ++ show (decpat d)
+                     ,"   , decplug = " ++ show (decplug d)
+                     ]++"}"
+       Isn{}     -> "Isn{ detyp   = " ++ showHSName (detyp d)++"}"
+       Vs{}      -> "Vs { decsgn  = " ++ showHS opts "" (sign d)++"}"
+
+--   instance ShowHSName ConceptDef where
+--    showHSName cd = haskellIdentifier ("cDef_"++cdcpt cd)
+
+instance ShowHS ConceptDef where
+ showHS opts _ cd
+  = " Cd ("++showHS opts "" (cdpos cd)++") "++show (cdcpt cd)++" "++show (cdplug cd)++" "++show (cddef cd)++" "++show (cdtyp cd)++" "++show (cdref cd)++" "++show (cdfrom cd)
+instance ShowHSName Char where
+ showHSName c = show c
+instance ShowHS Char where
+ showHS _ _ c = show c
+instance ShowHSName A_Concept where
+ showHSName ONE = haskellIdentifier "cptOne"
+ showHSName c = haskellIdentifier ("cpt_"++name c)
+instance ShowHS A_Concept where
+ showHS _ _ c = case c of
+                    PlainConcept{} -> "PlainConcept "++show (name c)
+                    ONE -> "ONE"
+
+instance ShowHSName Prop where
+ showHSName Uni = "Uni"
+ showHSName Inj = "Inj"
+ showHSName Sur = "Sur"
+ showHSName Tot = "Tot"
+ showHSName Sym = "Sym"
+ showHSName Asy = "Asy"
+ showHSName Trn = "Trn"
+ showHSName Rfx = "Rfx"
+ showHSName Irf = "Irf"
+ showHSName Aut = "Aut"
+
+instance ShowHS Prop where
+ showHS _ _ = showHSName
+
+instance ShowHS FilePos where
+ showHS _ _ (FilePos (fn,Database.Design.Ampersand.Input.ADL1.UU_Scanner.Pos l c,sym))
+   = "FilePos ("++show fn++",Pos "++show l++" "++show c++","++show sym++")"
+
+instance ShowHSName Origin where
+ showHSName ori = "Orig"++show x++show (hash x)
+   where x = case ori of
+              FileLoc l -> "FileLoc (" ++ show l++")"
+              DBLoc l   -> "DBLoc " ++ show l
+              Origin s  -> "Origin " ++ show s
+              OriginUnknown -> "OriginUnknown"
+
+instance ShowHS Origin where
+ showHS opts indent (FileLoc l) = "FileLoc (" ++ showHS opts indent l++")"
+ showHS _     _      (DBLoc l)   = "DBLoc "  ++ show l
+ showHS _     _      (Origin s)  = "Origin " ++ show s
+ showHS _     _    OriginUnknown = "OriginUnknown"
+
+instance ShowHS Block where
+ showHS _ _   = show
+
+instance ShowHS Inline where
+ showHS _ _   = show
+                  
+{-
+instance ShowHS InfTree where
+ showHS opts indent itree =
+     case itree of
+       InfExprs irt (ratype,raobj) itrees ->
+           "InfExprs " ++ showHS opts indent irt ++
+           indent ++ "   (" ++ showRaType ratype ++ "," ++ "RelAlgObj{-"++show raobj++"-}" ++ ")" ++
+           indent ++ showHS opts (indent ++ "     ") itrees
+       InfRel drt ratype _ _ ->
+           "InfRel " ++ showHS opts indent drt ++ " " ++ showRaType ratype
+   where
+    showRaType rat = "RelAlgType{-"++show rat++"-}"
+
+instance ShowHS RelDecl where
+ showHS _ indent d = case d of
+                       RelDecl{}-> "RelDecl{ dname  = " ++ show (dname d) ++ indent
+                                ++ "        ,dtype  = " ++ showRaType dtype ++ indent
+                                ++ "        ,isendo = " ++ show (isendo d)
+                       IDecl    -> "IDecl"
+                       VDecl    -> "VDecl"
+   where
+    showRaType _ = "RelAlgType{- ++TODO++ -}"
+
+
+instance ShowHS DeclRuleType where
+ showHS _ _ drt = case drt of
+                                      D_rel     -> "D_rel"
+                                      D_rel_h   -> "D_rel_h"
+                                      D_rel_c   -> "D_rel_c"
+                                      D_rel_c_h -> "D_rel_c_h"
+                                      D_id      -> "D_id"
+                                      D_v       -> "D_v"
+                                      D_id_c    -> "D_id_c"
+                                      D_v_c     -> "D_v_c"
+
+instance ShowHS InfRuleType where
+ showHS _ _ irt = case irt of
+                                      ISect_cs  -> "ISect_cs"
+                                      ISect_ncs -> "ISect_ncs"
+                                      ISect_mix -> "ISect_mix"
+                                      Union_mix -> "Union_mix"
+                                      Comp_ncs  -> "Comp_ncs"
+                                      Comp_c1   -> "Comp_c1"
+                                      Comp_c2   -> "Comp_c2"
+                                      Comp_cs   -> "Comp_cs"
+                                      RAdd_ncs  -> "RAdd_ncs"
+                                      RAdd_c1   -> "RAdd_c1"
+                                      RAdd_c2   -> "RAdd_c2"
+                                      RAdd_cs   -> "RAdd_cs"
+                                      Conv_nc   -> "Conv_nc"
+                                      Conv_c    -> "Conv_c"
+-}
+
+-- \***********************************************************************
+-- \*** hulpfuncties                                                    ***
+-- \***********************************************************************
+
+haskellIdentifier :: String -> String
+haskellIdentifier cs = unCap (hsId cs)
+ where
+   hsId ('_': cs')             = '_': hsId cs'
+   hsId (c:cs') | isAlphaNum c = c: hsId cs'
+                | otherwise    = hsId cs'
+   hsId ""                     = ""
+
+showL :: [String] -> String
+showL xs = "["++intercalate "," xs++"]"

+ src/Database/Design/Ampersand/FSpec/ShowMeatGrinder.hs view
@@ -0,0 +1,520 @@+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE FlexibleInstances #-}
+module Database.Design.Ampersand.FSpec.ShowMeatGrinder
+  (makeMetaPopulationFile,MetaType(..))
+where
+
+import Data.List
+import Data.Char
+import Data.Ord
+import Data.Hashable (hash) -- a not good enouqh function, but used for the time being. 
+import Data.Typeable
+import Database.Design.Ampersand.FSpec.FSpec
+import Database.Design.Ampersand.FSpec.FSpecAux
+import Database.Design.Ampersand.FSpec.Motivations
+import Database.Design.Ampersand.FSpec.SQL
+import Database.Design.Ampersand.FSpec.ToFSpec.NormalForms (conjNF)
+import Database.Design.Ampersand.Basics
+import Database.Design.Ampersand.Misc
+import Database.Design.Ampersand.FSpec.ShowADL
+import Database.Design.Ampersand.Core.AbstractSyntaxTree
+import Database.Design.Ampersand.Classes.ConceptStructure
+
+--import Data.Hashable
+import Data.Maybe
+
+fatal :: Int -> String -> a
+fatal = fatalMsg "ShowMeatGrinder"
+
+data MetaType = Generics | AST deriving (Show)
+
+makeMetaPopulationFile :: MetaType -> FSpec -> (FilePath,String)
+makeMetaPopulationFile mType fSpec
+  = ("MetaPopulationFile"++show mType++".adl", content popKind mType fSpec)
+    where popKind = case mType of
+                      Generics -> generics fSpec
+                      AST      -> metaPops fSpec 
+
+content :: (FSpec -> [Pop]) -> MetaType -> FSpec -> String
+content popKind mType fSpec = unlines
+   ([ "{- Do not edit manually. This code has been generated!!!"
+    , "    Generated with "++ampersandVersionStr
+    , "    Generated at "++show (genTime (getOpts fSpec))
+    , " "
+    , "The populations defined in this file are the populations from the user's"
+    , "model named '"++name fSpec++"'."
+    , ""
+    , "The order in which these populations are defined correspond with the order "
+    , "in which Ampersand is defined in itself. Currently (Feb. 2015), this is hard-"
+    , "coded. This means, that whenever Formal Ampersand changes, it might have "
+    , "impact on the generator of this file. "
+    , ""
+    , "-}"
+    , ""
+    , "CONTEXT "++show mType++" IN ENGLISH -- (the language is chosen arbitrary, for it is mandatory but irrelevant."]
+    ++ (concat.intersperse  []) (map (lines . showADL ) (popKind fSpec))
+    ++
+    [ ""
+    , "ENDCONTEXT"
+    ])
+instance GenericPopulations FSpec where
+ generics _ fSpec =
+   filter (not.nullContent)
+    (
+    [ Pop "versionInfo" "Context"  "AmpersandVersion"
+           [(uri fSpec, ampersandVersionStr)]
+    , Pop "contextName" "Context" "ContextName"
+           [(uri fSpec, name fSpec)]
+    , Pop "dbName" "Context" "DatabaseName"
+           [(uri fSpec, dbName (getOpts fSpec))]
+    ]
+  ++[ Comment " ", Comment $ "[Relations]--: (count="++(show.length.allDecls) fSpec++")"]
+  ++   concatMap (generics fSpec) (allDecls fSpec)
+  ++[ Comment " ", Comment $ "[Concepts]--: (count="++(show.length) [c | c <- allConcepts fSpec, c /= ONE]++")"]
+  ++   concatMap (generics fSpec) [c | c <- allConcepts fSpec, c /= ONE]
+  ++[ Comment " ", Comment $ "[TableColumnInfo]--: (count="++(show.length) allSqlPlugs++")"]
+  ++   concatMap (generics fSpec) allSqlPlugs
+  ++[ Comment " ", Comment $ "[Rules]--: (count="++(show.length.fallRules) fSpec++")"]
+  ++   concatMap (generics fSpec) (fallRules fSpec)
+  ++[ Comment " ", Comment $ "[Conjuncts]--: (count="++(show.length.vconjs) fSpec++")"]
+  ++   concatMap (generics fSpec) (vconjs fSpec)
+  ++[ Comment " ", Comment $ "[Roles]--: (count="++(show.length.fRoles) fSpec++")"]
+  ++   concatMap (generics fSpec) (fRoles fSpec)
+    )
+  where
+    allSqlPlugs = [plug | InternalPlug plug <- plugInfos fSpec]
+
+instance MetaPopulations FSpec where
+ metaPops _ fSpec =
+   filter (not.nullContent)
+    (
+    [Comment  " ", Comment $ "PATTERN Context: ('"++name fSpec++"')"]
+  ++[ Pop "name"   "Context" "ContextName"
+           [(uri fSpec,name fSpec)]]
+  ++[ Comment " ", Comment $ "PATTERN Patterns: (count="++(show.length.vpatterns) fSpec++")"]
+  ++   concatMap (metaPops fSpec) ((sortBy (comparing name).vpatterns)    fSpec)
+  ++[ Comment " ", Comment $ "PATTERN Specialization: (count="++(show.length.vgens) fSpec++")"]
+  ++   concatMap (metaPops fSpec) (vgens          fSpec)
+  ++[ Comment " ", Comment $ "PATTERN Concept: (count="++(show.length.allConcepts) fSpec++")"]
+  ++   concatMap (metaPops fSpec) ((sortBy (comparing name).allConcepts)    fSpec)
+  ++[ Comment " ", Comment $ "PATTERN Atoms: (count="++(show.length) (allAtoms fSpec)++")"]
+  ++   concatMap (metaPops fSpec) (allAtoms fSpec)
+--  ++[ Comment " ", Comment $ "PATTERN Sign: (count="++(show.length.allSigns) fSpec++")"]
+--  ++   concatMap (metaPops fSpec) (allSigns fSpec)
+  ++[ Comment " ", Comment $ "PATTERN Declaration: (count="++(show.length.allDecls) fSpec++")"]
+  ++   concatMap (metaPops fSpec) (allDecls  fSpec)
+  ++[ Comment " ", Comment $ "PATTERN Expression: (count="++(show.length.allExprs) fSpec++")"]
+  ++   concatMap (metaPops fSpec) (allExprs  fSpec)
+  ++[ Comment " ", Comment $ "PATTERN Rules: (count="++(show.length.fallRules) fSpec++")"]
+  ++   concatMap (metaPops fSpec) ((sortBy (comparing name).fallRules)    fSpec)
+  ++[ Comment " ", Comment $ "PATTERN Plugs: (count="++(show.length.plugInfos) fSpec++")"]
+  ++   concatMap (metaPops fSpec) ((sortBy (comparing name).plugInfos)    fSpec)
+  ++[ Comment " ", Comment $ "[InitialPopulation]--: (count="++(show.length.initialPops) fSpec++")"]
+  ++   concatMap (metaPops fSpec) (allLinks fSpec)
+  )
+   where
+
+instance MetaPopulations Pattern where
+ metaPops fSpec pat =
+   [ Comment " "
+   , Comment $ " Pattern `"++name pat++"` "
+   , Pop "patterns" "Context" "Pattern"
+          [(uri fSpec,uri pat)]
+   , Pop "name"    "Pattern" "PatternName"
+          [(uri pat, name pat)]
+   , Pop "rules"   "Pattern" "Rule"
+          [(uri pat,uri x) | x <- ptrls pat]
+   , Pop "declarations"   "Pattern" "Declaration"
+          [(uri pat,uri x) | x <- ptdcs pat]
+   , Pop "purpose"   "Pattern" "Purpose"
+          [(uri pat,uri x) | x <- ptxps pat]
+   ]
+instance MetaPopulations A_Gen where
+ metaPops fSpec gen =
+  [ Pop "gens" "Context" "Gen"
+          [(uri fSpec,uri gen)]
+  , Pop "genspc"  "Gen" "PlainConcept"
+          [(uri gen,uri(genspc gen))]
+  , Pop "gengen"  "Gen" "PlainConcept"
+          [(uri gen,uri c) | c<- case gen of
+                                   Isa{} -> [gengen gen]
+                                   IsE{} -> genrhs gen
+          ]
+  ]
+
+instance GenericPopulations A_Concept where
+ generics fSpec cpt =
+   case cpt of
+     PlainConcept{} ->
+      [ Comment " "
+      , Comment $ " Concept `"++name cpt++"` "
+      , Pop "allConcepts" "Context" "Concept"
+             [(uri fSpec,uri cpt)]
+      , Pop "name" "Concept" "ConceptName"
+             [(uri cpt, name cpt)]
+      , Pop "affectedInvConjunctIds" "Concept" "ConjunctID"
+             [(uri cpt, uri conj) | conj <- filterFrontEndInvConjuncts affConjs]
+      , Pop "affectedSigConjunctIds" "Concept" "ConjunctID"
+             [(uri cpt, uri conj) | conj <- filterFrontEndSigConjuncts affConjs]
+      , Pop "conceptTableFields" "Concept" "TableColumn"
+             [(uri cpt, uri fld) | fld <- tablesAndFields]
+      ]
+     ONE -> [
+            ]
+  where
+   affConjs = fromMaybe [] (lookup cpt $ allConjsPerConcept fSpec)
+   tablesAndFields = nub . concatMap (lookupCpt fSpec) $ cpt : largerConcepts (vgens fSpec) cpt
+instance MetaPopulations A_Concept where
+ metaPops fSpec cpt =
+   case cpt of
+     PlainConcept{} ->
+      [ Comment " "
+      , Comment $ " Concept `"++name cpt++"` "
+      , Pop "concs" "Context" "PlainConcept"
+           [(uri fSpec,uri cpt)]
+      , Pop "name" "PlainConcept" "ConceptName"
+             [(uri cpt, name cpt)]
+      , Pop "cptdf" "PlainConcept" "ConceptDefinition"
+             [(uri cpt,showADL cdef) | cdef <- conceptDefs  fSpec, name cdef == name cpt]
+      , Pop "cptpurpose" "PlainConcept" "Purpose"
+             [(uri cpt,showADL x) | lang <- allLangs, x <- fromMaybe [] (purposeOf fSpec lang cpt) ]
+      ]
+     ONE -> [
+            ]
+instance GenericPopulations PlugSQL where
+  generics fSpec plug =
+      [ Comment " "
+      , Comment $ "Plug: '"++name plug++"'"
+      , Pop "tableInfo" "Context" "DBTable"
+               [(uri fSpec, uri plug)]
+      ] ++ concatMap (generics fSpec) [(plug,fld) | fld <- plugFields plug]
+
+instance GenericPopulations (PlugSQL,SqlField) where
+  generics _ (plug,fld) =
+      [ Pop "columninfo" "DBTable" "TableColumn"
+                 [(uri plug, uri (plug,fld)) ]
+      , Pop "concept" "TableColumn" "Concept"
+                 [(uri (plug,fld), uri.target.fldexpr $ fld)]
+      , Pop "unique" "TableColumn" "BOOLEAN"
+                 [(uri (plug,fld), uri.flduniq $ fld)]
+      , Pop "null" "TableColumn" "BOOLEAN"
+                 [(uri (plug,fld), uri.fldnull $ fld)]
+      ]
+     
+instance GenericPopulations Role where
+  generics fSpec rol =
+      [ Comment $ "Role: '"++name rol++"'"
+      , Pop "allRoles" "Context" "Role"
+                 [(uri fSpec, uri rol) ]
+      , Pop "name" "Role" "RoleName"
+                 [(uri rol, name rol) ]
+      , Pop "maintains" "Role" "Rule"
+                 [(uri rol, uri rul) | (rol',rul) <-  fRoleRuls fSpec, rol==rol' ]
+      ]
+
+instance MetaPopulations Atom where
+ metaPops _ atm =
+   [ Pop "key" "Atom" "AtomID" 
+          [(uri atm, uri atm)]
+   , Pop "atomvalue"  "Atom" "AtomValue"
+          [(uri atm,(show.atmVal) atm)]
+   ]
+--instance MetaPopulations Sign where
+-- metaPops _ sgn =
+--      [ Pop "src" "Sign" "Concept"
+--             [(uri sgn, uri (source sgn))]
+--      , Pop "trg" "Sign" "Concept"
+--             [(uri sgn, uri (target sgn))]
+--      ]
+
+instance GenericPopulations Declaration where
+ generics fSpec dcl =
+   case dcl of 
+     Sgn{} ->
+      [ Comment " "
+      , Comment $ " Relation '"++name dcl++showSign (sign dcl)++"'"
+      , Pop "allRelations" "Context" "Relation"
+             [(uri fSpec, uri dcl)]
+      , Pop "name" "Relation" "RelationName"
+             [(uri dcl,name dcl)]
+      , Pop "srcConcept" "Relation" "Concept"
+             [(uri dcl,uri (source dcl))]
+      , Pop "tgtConcept" "Relation" "Concept"
+             [(uri dcl,uri (target dcl))]
+      , Pop "table" "Relation" "DBTable"
+             [(uri dcl,uri table)]
+      , Pop "srcCol" "Relation" "DBTableColumn"
+             [(uri dcl,uri (table,srcCol))]
+      , Pop "tgtCol" "Relation" "DBTableColumn"
+             [(uri dcl,uri (table,tgtCol))]
+      , Pop "affectedInvConjunctIds" "Relation" "ConjunctID"
+             [(uri dcl,uri conj) | conj <- filterFrontEndInvConjuncts affConjs ]
+      , Pop "affectedSigConjunctIds" "Relation" "ConjunctID"
+             [(uri dcl,uri conj) | conj <- filterFrontEndSigConjuncts affConjs ]
+      ]
+     Isn{} -> fatal 157 "Isn is not implemented yet"
+     Vs{}  -> fatal 158 "Vs is not implemented yet"
+   where
+     (table,srcCol,tgtCol) = getDeclarationTableInfo fSpec dcl
+     affConjs = fromMaybe [] (lookup dcl $ allConjsPerDecl fSpec)
+instance MetaPopulations Declaration where
+ metaPops fSpec dcl =
+   case dcl of
+     Sgn{} ->
+      [ Comment " "
+      , Comment $ " Declaration `"++name dcl++" ["++(name.source.decsgn) dcl++" * "++(name.target.decsgn) dcl++"]"++"` "
+      , Pop "allDeclarations" "Context" "Declaration"
+             [(uri fSpec,uri dcl)] 
+      , Pop "name" "Declaration" "DeclarationName"
+             [(uri dcl, name dcl)]
+--      , Pop "sign" "Declaration" "Sign"
+--             [(uri dcl,uri (sign dcl))]
+      , Pop "source" "Relation" "Concept"
+             [(uri dcl,uri (source dcl))]
+      , Pop "target" "Relation" "Concept"
+             [(uri dcl,uri (target dcl))]
+      , Pop "decprL" "Declaration" "String"
+             [(uri dcl,decprL dcl)]
+      , Pop "decprM" "Declaration" "String"
+             [(uri dcl,decprM dcl)]
+      , Pop "decprR" "Declaration" "String"
+             [(uri dcl,decprR dcl)]
+      , Pop "decmean" "Declaration" "Meaning"
+             [(uri dcl, show(decMean dcl))]
+      , Pop "decpurpose" "Declaration" "Purpose"
+             [(uri dcl, showADL x) | x <- explanations dcl]
+      ]
+     Isn{} -> 
+      [ Comment " "
+      , Comment $ " Declaration `I["++name (source dcl)++"]`"
+--      , Pop "sign" "Declaration" "Sign"
+--             [(uri dcl,uri (sign dcl))]
+      , Pop "source" "Relation" "Concept"
+             [(uri dcl,uri (source dcl))]
+      , Pop "target" "Relation" "Concept"
+             [(uri dcl,uri (target dcl))]
+      ]
+     Vs{}  -> fatal 158 "Vs is not implemented yet"
+
+instance MetaPopulations A_Pair where
+ metaPops _ pair =
+      [ Pop "in" "Pair" "Relation"
+             [(uri pair, uri (lnkDcl pair))]
+      , Pop "l" "Pair" "Atom"
+             [(uri pair, uri(lnkLeft pair))]
+      , Pop "r" "Pair" "Atom"
+             [(uri pair, uri(lnkRight pair))]
+      ]
+
+instance MetaPopulations Expression where
+ metaPops _ e =
+      [ Pop "exprvalue" "ExpressionID" "Expression"
+             [(uri e, showADL e)]
+      ]
+
+instance GenericPopulations Rule where
+ generics fSpec rul =
+      [ Comment " "
+      , Comment $ " Rule `"++name rul++"` "
+      , Pop "allRules" "Context" "Rule"
+             [(uri fSpec, uri rul)]
+      , Pop "name"  "Rule" "RuleID"
+             [(uri rul,name rul)]
+      , Pop "ruleAdl"  "Rule" "Adl"
+             [(uri rul,(showADL.rrexp) rul)]
+      , Pop "origin"  "Rule" "Origin"
+             [(uri rul,(show.origin) rul)]
+      , Pop "meaning"  "Rule" "Meaning"
+             [(uri rul,aMarkup2String m) | m <- (maybeToList . meaning (fsLang fSpec)) rul ]
+      , Pop "message"  "Rule" "Message"
+             [(uri rul,aMarkup2String m) | m <- rrmsg rul, amLang m == fsLang fSpec ]
+      , Pop "srcConcept"  "Rule" "Concept"
+             [(uri rul,(uri.source.rrexp) rul)]
+      , Pop "tgtConcept"  "Rule" "Concept"
+             [(uri rul,(uri.target.rrexp) rul)]
+      , Pop "conjunctIds"  "Rule" "ConjunctID"
+             [(uri rul,uri conj) | (rule,conjs)<-allConjsPerRule fSpec, rule==rul,conj <- conjs]
+      ]++case rrviol rul of
+        Nothing -> []
+        Just pve ->
+         [ Pop "pairView"  "Rule" "PairView"
+              [(uri rul, uri pve)]
+         ]++generics fSpec pve
+      
+      
+instance GenericPopulations (PairView Expression) where
+ generics fSpec pve = 
+      [ Comment " "
+      ]++concatMap makeSegment (zip [0..] (ppv_segs pve))
+  where
+    makeSegment :: (Int,PairViewSegment Expression) -> [Pop]
+    makeSegment (i,pvs) =
+      [ Pop "segment" "PairView" "PairViewSegment"
+             [(uri pve,uri pvs)]
+      , Pop "sequenceNr" "PairViewSegment" "Int"
+             [(uri pvs,show i)]
+      , Pop "segmentType" "PairViewSegment" "PairViewSegmentType"
+             [(uri pvs, case pvs of 
+                         PairViewText{} -> "Text"
+                         PairViewExp{}  -> "Exp")
+            ]
+      ]++
+      case pvs of
+        PairViewText{} -> 
+          [Pop "text" "PairViewSegment" "String"
+               [(uri pvs, pvsStr pvs)] 
+          ]
+        PairViewExp{} -> 
+          [Pop "srcOrTgt" "PairViewSegment" "SourceOrTarget"
+               [(uri pvs, show (pvsSoT pvs))] 
+          ,Pop "expTgt" "PairViewSegment" "Concept"
+               [(uri pvs, uri (case pvsSoT pvs of
+                                Src -> source (pvsExp pvs)
+                                Tgt -> target (pvsExp pvs)
+                              ))] 
+          ,Pop "expSQL" "PairViewSegment" "MySQLQuery"
+               [(uri pvs, prettySQLQuery fSpec 0 (pvsExp pvs))] 
+          ]
+         
+      
+instance MetaPopulations Rule where
+ metaPops _ rul =
+      [ Comment " "
+      , Comment $ " Rule `"++name rul++"` "
+      , Pop "name"  "Rule" "RuleName"
+             [(uri rul,name rul)]
+      , Pop "rrexp"  "Rule" "ExpressionID"
+             [(uri rul,uri (rrexp rul))]
+      , Pop "rrmean"  "Rule" "Meaning"
+             [(uri rul,show(rrmean rul))]
+      , Pop "rrpurpose"  "Rule" "Purpose"
+             [(uri rul,showADL x) | x <- explanations rul]
+      , -- The next population is from the adl pattern 'Plugs':
+        Pop "sign" "Rule" "Sign"
+             [(uri rul,uri (sign rul))]
+      , Pop "declaredthrough" "PropertyRule" "Property"
+             [(uri rul,show prp) | Just(prp,_) <- [rrdcl rul]]
+      , Pop "decprps" "Declaration" "PropertyRule"
+             [(uri dcl, uri rul) | Just(_,dcl) <- [rrdcl rul]]
+      ]
+
+
+
+instance MetaPopulations PlugInfo where
+ metaPops _ plug = 
+      [ Comment $ " Plug `"++name plug++"` "
+      , Pop "maintains" "Plug" "Rule" [{-STILL TODO. -}] --HJO, 20150205: Waar halen we deze info vandaan??
+      , Pop "in" "PlainConcept" "Plug"                 
+             [(uri cpt,uri plug)| cpt <- concs plug]  
+      , Pop "in" "Declaration" "Plug"
+             [(uri dcl,uri plug)| dcl <- relsMentionedIn plug]
+      ]      
+
+instance MetaPopulations a => MetaPopulations [a] where
+ metaPops fSpec = concatMap $ metaPops fSpec
+ 
+instance GenericPopulations Conjunct where
+ generics fSpec conj =
+  [ Comment $ "Conjunct: '"++rc_id conj++"'."
+  , Pop "allConjuncts" "Context" "Conjunct" 
+         [(uri fSpec, uri conj)]
+  , Pop "signalRuleNames" "Conjunct" "Rule" 
+         [(uri conj,uri r) | r <- rc_orgRules conj, isFrontEndSignal r]
+  , Pop "invariantRuleNames" "Conjunct" "Rule" 
+         [(uri conj,uri r) | r <- rc_orgRules conj, isFrontEndInvariant  r]
+  , Pop "violationsSQL" "Conjunct" "MySQLQuery" 
+         [(uri conj , prettySQLQuery fSpec 0 (conjNF (getOpts fSpec) (notCpl (rc_conjunct conj)))
+          )]
+  ] 
+
+
+-----------------------------------------------------
+data Pop = Pop { popName ::String
+               , popSource :: String
+               , popTarget :: String
+               , popPairs :: [(String,String)]
+               }
+         | Comment { comment :: String  -- Not-so-nice way to get comments in a list of populations. Since it is local to this module, it is not so bad, I guess...
+                   }
+instance ShowADL Pop where
+ showADL pop =
+  case pop of
+      Pop{} -> "POPULATION "++ popName pop++
+                  " ["++popSource pop++" * "++popTarget pop++"] CONTAINS"
+              ++
+              if null (popPairs pop)
+              then "[]"
+              else "\n"++indentA++"[ "++intercalate ("\n"++indentA++"; ") showContent++indentA++"]"
+      Comment{} -> intercalate "\n" (map prepend (lines (comment pop)))
+    where indentA = "   "
+          showContent = map showPaire (popPairs pop)
+          showPaire (s,t) = "( "++show s++" , "++show t++" )"
+          prepend str = "-- " ++ str
+
+class Unique a => AdlId a where
+ uri :: a -> String
+ uri = camelCase . uniqueShow False
+-- All 'things' that are relevant in the meta-environment (RAP),
+-- must be an instance of AdlId:
+instance AdlId A_Concept
+instance AdlId A_Gen
+instance AdlId Atom
+instance AdlId ConceptDef
+instance AdlId Declaration
+instance AdlId Expression
+instance AdlId FSpec
+instance AdlId A_Pair
+instance AdlId Pattern
+instance AdlId PlugInfo
+instance AdlId PlugSQL
+instance AdlId (PlugSQL,SqlField)
+instance AdlId Purpose
+instance AdlId Rule
+instance AdlId Role
+instance AdlId Sign
+instance AdlId Conjunct
+instance AdlId (PairView Expression)
+  where uri x = show (typeOf x)++show (hash x)
+instance AdlId (PairViewSegment Expression)
+  where uri x = show (typeOf x)++show (hash (show (hash x) ++ show (origin x)))
+instance AdlId Bool where
+ uri = showUnique
+instance AdlId a => AdlId [a] where
+--instance AdlId (Declaration,Paire)
+
+
+
+-- | remove spaces and make camelCase
+camelCase :: String -> String
+camelCase str = concatMap capitalize (words str)
+  where
+    capitalize [] = []
+    capitalize (s:ss) = toUpper s : ss
+
+nullContent :: Pop -> Bool
+nullContent (Pop _ _ _ []) = True
+nullContent _ = False
+    
+class MetaPopulations a where
+ metaPops :: FSpec -> a -> [Pop]
+class GenericPopulations a where
+ generics :: FSpec -> a -> [Pop]   
+
+
+--------- Below here are some functions copied from Generate.hs TODO: Clean up.
+-- Because the signal/invariant condition appears both in generateConjuncts and generateInterface, we use
+-- two abstractions to guarantee the same implementation.
+isFrontEndInvariant :: Rule -> Bool
+isFrontEndInvariant r = not (isSignal r) && not (ruleIsInvariantUniOrInj r)
+
+isFrontEndSignal :: Rule -> Bool
+isFrontEndSignal r = isSignal r
+
+-- NOTE that results from filterFrontEndInvConjuncts and filterFrontEndSigConjuncts may overlap (conjunct appearing in both invariants and signals)
+-- and that because of extra condition in isFrontEndInvariant (not (ruleIsInvariantUniOrInj r)), some parameter conjuncts may not be returned
+-- as either inv or sig conjuncts (i.e. conjuncts that appear only in uni or inj rules) 
+filterFrontEndInvConjuncts :: [Conjunct] -> [Conjunct]
+filterFrontEndInvConjuncts conjs = filter (\c -> any isFrontEndInvariant $ rc_orgRules c) conjs
+
+filterFrontEndSigConjuncts :: [Conjunct] -> [Conjunct]
+filterFrontEndSigConjuncts conjs = filter (\c -> any isFrontEndSignal $ rc_orgRules c) conjs

+ src/Database/Design/Ampersand/FSpec/ShowXMLtiny.hs view
@@ -0,0 +1,312 @@+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}
+module Database.Design.Ampersand.FSpec.ShowXMLtiny (showXML) where
+
+-- TODO: Als het Ampersand bestand strings bevat met speciale characters als '&' en '"', dan wordt nu nog foute XML-code gegenereerd...
+
+import Database.Design.Ampersand.ADL1
+import Database.Design.Ampersand.Classes
+import Database.Design.Ampersand.FSpec.ShowADL
+import Database.Design.Ampersand.Basics
+import Database.Design.Ampersand.FSpec.FSpec
+import Data.Time.LocalTime
+import Database.Design.Ampersand.FSpec.Plug
+import Database.Design.Ampersand.Misc.TinyXML
+import Data.List
+
+fatal :: Int -> String -> a
+fatal = fatalMsg "FSpec.ShowXMLtiny"
+
+showXML :: FSpec -> LocalTime -> String
+showXML fSpec now
+         = validXML
+            ("<?xml version=\"1.0\" encoding=\"utf-8\"?>" ++
+             "<tns:ADL xmlns:tns=\"http://ampersand.sourceforge.net/ADL\" "++
+             "xmlns:xsi=\"http://www.w3.org/2001/XMLSchema-instance\" "++
+             "xsi:schemaLocation=\"http://ampersand.sourceforge.net/AdlDocs "++
+             "ADL.xsd \">"++
+             "<!-- Generated with "++ ampersandVersionStr ++", at "++ show now ++" -->" ++
+             "<!-- Warning: The format of this generated xml document is subject to changes, and it"++
+             " isn't very stable. Please notify the developers of Ampersand if you have specific needs. -->")
+           ++
+           showXTree ( mkXmlTree fSpec) ++
+           "</tns:ADL>"
+
+nameToAttr :: Named x => x -> XAtt
+nameToAttr x = mkAttr "name" (name x)
+
+----------------------------------------------------------------------
+
+class XML a where
+ mkTag :: a -> XTag
+ mkXmlTree :: a -> XTree
+
+still2bdone :: String -> XTree
+still2bdone worktxt = Node (Tag "NotImplementedYet" [mkAttr "work2do_in_ShowXML.hs"  worktxt])
+
+instance XML FSpec where
+  mkTag f = Tag "FSpec" [nameToAttr f]
+  mkXmlTree f@FSpec{}
+     = Elem (mkTag f) (
+          []
+--          ++ [ Elem (simpleTag "Plugs-In-Ampersand-Script")     (map mkXmlTree (vplugs f))]
+--          ++ [ Elem (simpleTag "Plugs-also-derived-ones") (map mkXmlTree (plugs f))]
+       ++ [ Elem (simpleTag "Patterns")     (map mkXmlTree (vpatterns f))]
+       ++ [ Elem (simpleTag "InterfaceS")   (map mkXmlTree (interfaceS f))]
+       ++ [ Elem (simpleTag "InterfaceG")   (map mkXmlTree (interfaceG f))]
+   --    ++ [ Elem (simpleTag "Activities")   (map mkXmlTree (interfaces f))]
+       ++ [ Elem (simpleTag "Rules")        (map mkXmlTree (vrules f))]
+       ++ [ Elem (simpleTag "GRules")       (map mkXmlTree (grules f))]
+       ++ [ Elem (simpleTag "Declarations") (map mkXmlTree (vrels f))]
+       ++ [ Elem (simpleTag "Violations")   (map violation2XmlTree (allViolations f))]
+       ++ [ still2bdone "Ontology" ] -- ++ [ Elem (simpleTag "Ontology") [mkXmlTree hhh]
+       ++ [ Elem (simpleTag "Explanations") (map mkXmlTree (fSexpls f))]
+              )
+          where violation2XmlTree :: (Rule,[Paire]) -> XTree
+                violation2XmlTree (r,ps) =
+                  Elem (Tag "Violation" [] )
+                   (
+                    Elem (simpleTag "ViolatedRule") [mkXmlTree r]
+                    :[Elem (simpleTag "Culprits")(map mkXmlTree ps)]
+                   )
+
+instance XML Activity where
+  mkTag _ = Tag "Activity" []
+  mkXmlTree act
+     = Elem (mkTag act) (
+          [ Elem (simpleTag "Rule")               [mkXmlTree (actRule act)]]
+       ++ [ Elem (simpleTag "Editable Relations") (map mkXmlTree (actTrig   act)) |not (null (actTrig   act))]
+       ++ [ Elem (simpleTag "Affected Relations") (map mkXmlTree (actAffect act)) |not (null (actAffect act))]
+       ++ [ Elem (simpleTag "Affected Quads")     []] -- TODO
+       ++ [ Elem (simpleTag "ECArules")           (map mkXmlTree (actEcas   act)) |not (null (actEcas   act))]
+       ++ [ Elem (simpleTag "Explanations")       (map mkXmlTree (actPurp   act)) |not (null (actPurp   act))]
+        )
+
+instance XML Pattern where
+  mkTag pat = Tag "Pattern" [ nameToAttr pat]
+  mkXmlTree pat
+     = Elem (mkTag pat) (
+          [ Elem (simpleTag "Rules")        (map mkXmlTree (ptrls pat)) |not (null (ptrls pat))]
+       ++ [ Elem (simpleTag "Gens")         (map mkXmlTree (ptgns pat)) |not (null (ptgns pat))]
+       ++ [ Elem (simpleTag "Declarations") (map mkXmlTree (ptdcs pat)) |not (null (ptdcs pat))]
+       ++ [ Elem (simpleTag "Keys")         (map mkXmlTree (ptids pat)) |not (null (ptids pat))]
+       ++ [ Elem (simpleTag "Explanations") (map mkXmlTree (ptxps pat)) |not (null (ptxps pat))]
+        )
+
+instance XML Rule where
+  mkTag r = Tag "Rule" [mkAttr "ruleId" (name r)]
+  mkXmlTree r
+   = Elem (mkTag r)
+          [Elem (simpleTag "Expression")   [PlainText (showADL (rrexp r))]]
+
+instance XML IdentityDef where
+  mkTag k = Tag "IdentityDef" [nameToAttr k]
+  mkXmlTree k = Elem (mkTag k)
+                     ( Elem (simpleTag "Identity on") [mkXmlTree (idCpt k)] :
+                       attributesTree [e | IdentityExp e <- identityAts k] -- TODO: currently ignores ViewText and ViewHtml segments
+                     )
+
+instance XML Interface where
+  mkTag x = Tag "Interface" [ nameToAttr x]
+  mkXmlTree x
+        = Elem (mkTag x) []
+                   --TODO: moet nog verder uitgewerkt.
+
+instance XML ObjectDef where
+  mkTag x = Tag "ObjectDef" [ nameToAttr x]
+  mkXmlTree x@Obj{}
+        = Elem (mkTag x)
+                   ( descriptionTree (objctx x)
+                  ++ attributesTree (attributes x)
+                  ++ [Elem (simpleTag "Directives")
+                           [PlainText (show (objstrs x))] |not (null (objstrs x))]
+                   )    --TODO: De directieven moeten waarschijnlijk nog verder uitgewerkt.
+
+instance XML Expression where
+  mkTag _  = fatal 184 "mkTag should not be used for expressions."
+  mkXmlTree expr
+      = case expr of
+            (EEqu (l,r)) -> Elem (simpleTag "EQUI") (map mkXmlTree [l,r])
+            (EImp (l,r)) -> Elem (simpleTag "IMPL") (map mkXmlTree [l,r])
+            (EIsc (l,r)) -> Elem (simpleTag "CONJ") (map mkXmlTree [l,r])
+            (EUni (l,r)) -> Elem (simpleTag "DISJ") (map mkXmlTree [l,r])
+            (EDif (l,r)) -> Elem (simpleTag "DIFF") (map mkXmlTree [l,r])
+            (ELrs (l,r)) -> Elem (simpleTag "LRES") (map mkXmlTree [l,r])
+            (ERrs (l,r)) -> Elem (simpleTag "RRES") (map mkXmlTree [l,r])
+            (EDia (l,r)) -> Elem (simpleTag "DIAM") (map mkXmlTree [l,r])
+            (ECps (l,r)) -> Elem (simpleTag "RMUL") (map mkXmlTree [l,r])
+            (ERad (l,r)) -> Elem (simpleTag "RADD") (map mkXmlTree [l,r])
+            (EPrd (l,r)) -> Elem (simpleTag "RPRD") (map mkXmlTree [l,r])
+            EKl0 e       -> Elem (simpleTag "CLS0") [mkXmlTree e]
+            EKl1 e       -> Elem (simpleTag "CLS1") [mkXmlTree e]
+            EFlp e       -> Elem (simpleTag "CONV") [mkXmlTree e]
+            ECpl e       -> Elem (simpleTag "CMPL") [mkXmlTree e]
+            EBrk e       -> mkXmlTree e
+            EDcD dcl     -> Elem (simpleTag "EDcD") [mkXmlTree dcl]
+            EDcI c       -> Elem (simpleTag "EDcI") [mkXmlTree c]
+            EEps i sgn   -> Elem (simpleTag "EEps") [mkXmlTree i,mkXmlTree sgn]
+            EDcV sgn     -> Elem (simpleTag "EDcV") [mkXmlTree sgn]
+            EMp1 atm c   -> Elem (simpleTag ("ATOM="++atm)) [mkXmlTree c]
+
+instance XML PPurpose where
+  mkTag expl =
+    Tag "PRef2" atts
+
+--        = case expl of
+--                PRef2ConceptDef{}  -> Tag "ExplConceptDef"  atts
+--                PRef2Declaration{} -> Tag "ExplDeclaration" atts
+--                PRef2Rule{}        -> Tag "ExplRule"        atts
+--                PRef2IdentityDef{} -> Tag "ExplIdentityDef" atts
+--                PRef2Pattern{}     -> Tag "ExplPattern"     atts
+--                PRef2Interface{}   -> Tag "ExplInterface"   atts
+--                PRef2Context{}     -> Tag "ExplContext"     atts
+--                PRef2Fspc{}        -> Tag "ExplContext"     atts
+        where
+         atts ::  [XAtt]
+         atts = [mkAttr "Explains" (name expl)
+                ,mkAttr "Markup" (show(pexMarkup expl))
+                ,mkAttr "Ref" (intercalate ";" (pexRefIDs expl))]
+  mkXmlTree expl
+      = Elem (mkTag expl) [PlainText (show (pexMarkup expl))]
+
+instance XML Purpose where
+  mkTag _ = Tag "Purp" [mkAttr "TODO" "Generate XML code for Purpose"]
+                        --  [mkAttr "Purpose" (show expl)
+                        --  ,mkAttr "Markup" (show (explMarkup expl))
+                        --  ,mkAttr "Ref" (intersperse ";" (explRefIds expl))]
+
+--        = case expl of
+--                ExplConceptDef  cdef  lang ref _ -> Tag "ExplConceptDef"  (atts cdef lang ref)
+--                ExplDeclaration d     lang ref _ -> Tag "ExplDeclaration" (atts (name d++name(source d)++name(target d)) lang ref)
+--                ExplRule        rname lang ref _ -> Tag "ExplRule"        (atts rname lang ref)
+--                ExplIdentityDef kname lang ref _ -> Tag "ExplIdentityDef" (atts kname lang ref)
+--                ExplViewDef     kname lang ref _ -> Tag "ExplViewDef"     (atts kname lang ref)
+--                ExplPattern     pname lang ref _ -> Tag "ExplPattern"     (atts pname lang ref)
+--                ExplInterface   cname lang ref _ -> Tag "ExplInterface"   (atts cname lang ref)
+--                ExplContext     cname lang ref _ -> Tag "ExplContext"     (atts cname lang ref)
+--           where
+--            atts :: String -> Lang -> String -> [XAtt]
+--            atts str lang ref = [mkAttr "Explains" str
+--                                ,mkAttr "Lang" (show lang)
+--                                ,mkAttr "Ref" ref]
+  mkXmlTree expl
+      = Elem (mkTag expl) [PlainText ((validXML.show.explMarkup) expl)]
+
+instance XML A_Gen where
+  mkTag g@Isa{} = Tag "Isa" (mkAttr "Specific" (show (genspc g))
+                             :[mkAttr "Generic" (show (gengen g))]
+                            )
+  mkTag g@IsE{} = Tag "IsE" (mkAttr "Specific" (show (genspc g))
+                             :[mkAttr "Generics" (show c) | c<-genrhs g]
+                            )
+  mkXmlTree g = Node (mkTag g)
+
+instance XML Sign where
+  mkTag sgn = Tag "Sign" (mkAttr "Source" (show (source sgn))
+                         :[mkAttr "Target" (show (target sgn))]
+                         )
+  mkXmlTree sgn = Node (mkTag sgn)
+
+instance XML Declaration where
+  mkTag d = Tag "Association" ([nameToAttr d]
+                             ++[ mkAttr "type" t]
+                             ++ extraAtts )
+         where t = case d of
+                     Sgn{} -> "Sgn"
+                     Isn{} -> "Isn"
+                     Vs{} -> "Vs"
+               extraAtts = case d of
+                             Sgn{} -> [mkAttr "IsSignal" (show (deciss d))]
+                             _     -> []
+
+  mkXmlTree d = Elem (mkTag d)
+     (case d of
+       Sgn{}
+             ->  [Node (Tag "Source" [mkAttr "concept" (name(source d))])]
+               ++[Node (Tag "Target" [mkAttr "concept" (name(target d))])]
+               ++[Elem (simpleTag "MultFrom") [PlainText (multiplicity (multiplicities d))]]
+               ++[Elem (simpleTag "MultTo") [PlainText (multiplicity (map flp (multiplicities d)))]]
+               ++[Elem (simpleTag "Pragma")
+                          [PlainText (show (prL++"%f"++prM++"%t"++prR))]
+                             | not (null (prL++prM++prR))]
+               ++[Elem (simpleTag "Meaning") [PlainText "Still 2 be done"]
+                 --         [PlainText (explainContent2String LaTeX True (decMean d))]
+                 ]
+--                  ++[Elem (simpleTag "Population")
+--                             (map mkXmlTree (decpopu d))
+--                                | not (null (decpopu d))]
+       Isn{}
+             ->  [Elem (simpleTag "Type") [mkXmlTree (source d)]]
+       Vs{}
+             ->  Elem (simpleTag "Generic") [mkXmlTree (source d)]
+                 :[Elem (simpleTag "Specific")[mkXmlTree (target d)]]
+        )
+    where
+      multiplicity ms | null ([Sur,Inj]>-ms) = "1"
+                      | null (    [Inj]>-ms) = "0..1"
+                      | null ([Sur]    >-ms) = "1..n"
+                      | otherwise            = "0..n"
+      prL = decprL d
+      prM = decprM d
+      prR = decprR d
+
+instance XML Paire where
+  mkTag p = Tag "link" atts
+             where
+                atts = mkAttr "from" (srcPaire p)
+                       :[mkAttr "to"   (trgPaire p)]
+  mkXmlTree p = Elem (mkTag p) []
+
+instance XML ConceptDef where
+  mkTag f = Tag "ConceptDef" ( mkAttr "name" (cdcpt f)
+                               : [mkAttr "Trace" (cdref f) |not (null (cdref f))])
+  mkXmlTree f = Elem (mkTag f) (explainTree (cddef f))
+
+instance XML A_Concept where
+  mkTag f = Tag "A_Concept" [nameToAttr f]
+  mkXmlTree f
+     = Node (mkTag f)
+
+instance XML (ECArule) where
+  mkTag _ = Tag "ECArule" []
+  mkXmlTree _ = still2bdone "ECArule"
+
+instance XML (Declaration->ECArule) where
+  mkTag _ = Tag "ECArule" []
+  mkXmlTree _ = still2bdone "Declaration->ECArule"
+
+instance XML PlugSQL where --TODO151210 -> tags for BinSQL and ScalarSQL
+  mkTag p = Tag "PlugSql" [ nameToAttr p]
+  mkXmlTree p
+   = Elem (mkTag p)
+          [ Elem (simpleTag "Fields") (map mkXmlTree (fields p))]
+instance XML SqlField where
+   mkTag x = Tag "Field" (   [mkAttr "name" (fldname x)]
+                           ++[mkAttr "type" (showSQL (fldtype x))]
+                           ++[mkAttr "null" (show (fldnull x))]
+                           ++[mkAttr "uniq" (show (flduniq x))]
+                           ++[mkAttr "auto" (show (fldauto x))]
+                           )
+   mkXmlTree sf = Elem (mkTag sf)
+                     [Elem (simpleTag "Expression") [mkXmlTree (fldexpr sf)]]
+
+attributesTree :: [ObjectDef] -> [XTree]
+attributesTree atts = [Elem (simpleTag "Attributes")
+                            (map mkXmlTree atts)    |not(null atts)]
+
+descriptionTree :: Expression -> [XTree]
+descriptionTree f = [Elem (simpleTag "Description")
+                        [mkXmlTree f] ]
+
+explainTree :: String -> [XTree]
+explainTree str = [Elem (simpleTag "Explanation")
+                        [PlainText (validXML str)] | not (null str)]
+
+-- | XML has a special set of characters that cannot be used in normal XML strings.
+validXML :: String -> String
+validXML []       = []
+validXML ('&':s)  = "&amp;"++validXML s
+validXML ('<':s)  = "&lt;"++validXML s
+validXML ('>':s)  = "&gt;"++validXML s
+validXML ('"':s)  = "&quot;"++validXML s
+validXML ('\'':s) = "&#39;"++validXML s
+validXML (c:s)    = c:validXML s     

+ src/Database/Design/Ampersand/FSpec/Switchboard.hs view
@@ -0,0 +1,240 @@+module Database.Design.Ampersand.FSpec.Switchboard
+         (SwitchBdDiagram(..),switchboardAct,sbDiagram,processModel) where
+
+import Data.GraphViz
+import Data.GraphViz.Attributes.Complete
+import Data.List
+import Database.Design.Ampersand.Basics        (fatalMsg,Named(..), flp)
+import Database.Design.Ampersand.ADL1
+import Database.Design.Ampersand.Classes
+import Database.Design.Ampersand.Core.AbstractSyntaxTree
+import Database.Design.Ampersand.FSpec.FSpec
+import Database.Design.Ampersand.FSpec.ShowADL (ShowADL(..), LanguageDependent(..))
+import Data.String
+
+--import Database.Design.Ampersand.FSpec.ShowECA (showECA) -- for testing purposes
+
+fatal :: Int -> String -> a
+fatal = fatalMsg "FSpec.Switchboard"
+
+data SwitchBdDiagram
+ = SBdgrm { sbName :: String
+          , sbdotGraph :: DotGraph String
+          }
+instance Named SwitchBdDiagram where
+   name = sbName
+
+processModel :: [Activity] -> DotGraph String
+processModel acts
+ = DotGraph { strictGraph = False
+            , directedGraph = True
+            , graphID = Just (Str (fromString "Process Model"))
+            , graphStatements
+               = DotStmts { attrStmts = [GraphAttrs [{-Splines SplineEdges,-} RankDir FromLeft]]
+                          , subGraphs = []
+                          , nodeStmts = activityNodes
+                          , edgeStmts = edges
+                          }
+            }
+   where
+      activityNodes = [ DotNode { nodeID         = "act_"++name a
+                                , nodeAttributes = [Style [SItem Filled []], FillColor [WC(X11Color Orange) Nothing], Label (StrLabel (fromString (name a)))]
+                                }
+                      | a<-acts]
+      edges         = nub
+                      [ DotEdge { fromNode = "act_"++name from
+                                , toNode   = "act_"++name to
+                                , edgeAttributes = [Len 2, Label (StrLabel (fromString (show e++" "++name d))), Dir Forward]
+                                }
+                      | (from,to,e,d) <- allEdges
+                      ]
+      allEdges  = nub[(from,to,e,d) | (e,d,from)<-eventsOut, (e',d',to)<-eventsIn, e==e', d==d']
+      eventsIn  = [(e,d,act) | act<-acts, eca<-actEcas act, let On e d = ecaTriggr eca]
+      eventsOut = [(e,d,act) | act<-acts, eca<-actEcas act, (e,d)<-(nub.evs.ecaAction) eca]
+                  where evs :: PAclause -> [(InsDel,Declaration)]
+                        evs clause
+                          = case clause of
+                             CHC{} -> (concat.map evs) (paCls clause)
+                             GCH{} -> concat [ evs p | (_,_,p)<-paGCls clause]
+                             ALL{} -> (concat.map evs) (paCls clause)
+                             Do{}  -> [(paSrt clause, paTo clause)]
+                             New{} -> evs (paCl clause "")
+                             Rmv{} -> evs (paCl clause "")
+                             Nop{} -> []
+                             Blk{} -> []
+                             Let{} -> fatal 305 "events for let undetermined"
+                             Ref{} -> fatal 306 "events for Ref undetermined"
+
+colorRule :: Rule -> X11Color
+colorRule r  | isSignal r = Orange
+             | otherwise  = Green
+
+sbDiagram :: FSpec -> SwitchBdDiagram
+sbDiagram fSpec
+ = SBdgrm
+     { sbName = name fSpec
+     , sbdotGraph
+        = DotGraph { strictGraph = False
+                   , directedGraph = True
+                   , graphID = Just (Str (fromString "Switchboard"))
+                   , graphStatements
+                      = DotStmts { attrStmts = [GraphAttrs [Splines SplineEdges, RankDir FromLeft]]
+                                 , subGraphs = []
+                                 , nodeStmts = inEvNodes++conjNodes++ecaNodes++outEvNods
+                                 , edgeStmts = edgesEvCj++edgesCjEc++edgesEcEv
+                                 }
+                   }
+     }
+   where
+     fsb = fSwitchboard fSpec
+     --DESCR -> The relations from which changes can come
+     inEvNodes = [ DotNode { nodeID         = nameINode eventsIn ev
+                           , nodeAttributes = [Label (StrLabel (fromString (show (eSrt ev)++" "++showADL (eDcl ev))))]
+                           }
+                 | ev<-eventsIn
+                 ]
+     --DESCR -> All conjuncts
+     conjNodes = [ DotNode { nodeID         = nameCNode (fsbConjs fsb) (rul,c)
+                           , nodeAttributes = [Style [SItem Filled []], FillColor [WC(X11Color (colorRule rul)) Nothing], (Label . StrLabel . fromString . name) rul]
+                           }
+                 | (rul,c)<-fsbConjs fsb]
+
+     --DESCR -> All ECA rules
+     ecaNodes  = [ DotNode { nodeID         = nameENode (fsbECAs fsb) eca
+                           , nodeAttributes = if isBlk (ecaAction eca)
+                                              then [Style [SItem Filled []], FillColor [WC(X11Color Red)Nothing], (Label . StrLabel . fromString) ("ERR #"++show (ecaNum eca))]
+                                              else [(Label . StrLabel . fromString. showADL) eca]
+                           }
+                 | eca<-fsbECAs fsb, not (isBlk (ecaAction eca))]
+
+     --DESCR -> The relations to which changes are made
+     outEvNods = [ DotNode { nodeID         = nameONode eventsOut ev
+                           , nodeAttributes = [Label (StrLabel (fromString (show (eSrt ev)++" "++showADL (eDcl ev))))]
+                           }
+                 | ev<-eventsOut
+                 ]
+     --DESCR -> Each edge represents an insert between a relation on the left and a term on the right to which the relation contributes to an insert.
+     edgesEvCj = [ DotEdge { fromNode = nameINode eventsIn ev
+                           , toNode   = nameCNode (fsbConjs fsb) (rul,c)
+                           , edgeAttributes = [Dir Forward]
+                           }
+                 | (rul,c)<-fsbConjs fsb, ev<-eventsIn, eDcl ev `elem` relsUsedIn c]
+     edgesCjEc = [ DotEdge { fromNode = nameCNode (fsbConjs fsb) (rul,c)
+                           , toNode   = nameENode (fsbECAs fsb) eca
+                           , edgeAttributes = [Dir Forward]
+                           }
+                 | (rul,c)<-fsbConjs fsb, eca<-fsbECAs fsb, not (isBlk (ecaAction eca)), rul `elem` concat [r | (_,r)<-paMotiv (ecaAction eca)] ]
+     edgesEcEv = nub
+                 [ DotEdge { fromNode = nameENode (fsbECAs fsb) eca
+                           , toNode   = nameONode eventsOut (On tOp rel)
+                           , edgeAttributes = [Dir Forward]
+                           }
+                 | eca<-fsbECAs fsb, not (isBlk (ecaAction eca))
+                 , On tOp rel<-eventsFrom (ecaAction eca)
+                 ]
+     nameINode = nmLkp fSpec "in_"
+     nameCNode = nmLkp fSpec "cj_"
+     nameENode = nmLkp fSpec "eca_"
+     nameONode = nmLkp fSpec "out_"
+     eventsIn  = nub [ecaTriggr eca | eca<-fsbECAs fsb, not (isBlk (ecaAction eca)) ]
+     eventsOut = nub [evt | eca<-fsbECAs fsb, let act=ecaAction eca, not (isBlk act), evt<-eventsFrom act]
+
+switchboardAct :: FSpec -> Activity -> SwitchBdDiagram
+switchboardAct fSpec act
+ = SBdgrm
+     { sbName = name act
+     , sbdotGraph
+        = DotGraph { strictGraph = False
+                   , directedGraph = True
+                   , graphID = Just (Str (fromString "Switchboard"))
+                   , graphStatements
+                      = DotStmts { attrStmts = [GraphAttrs [Splines SplineEdges, RankDir FromLeft]]
+                                 , subGraphs = []
+                                 , nodeStmts = inMorNodes++conjunctNodes++outMorNodes
+                                 , edgeStmts = edgesIn++edgesOut
+                                 }
+                   }
+     }
+   where
+     fromRels     = nub (actTrig act)
+     toRels :: [Declaration]
+     toRels       = nub (actAffect act)
+     conjuncts    = nub [ (qRule q,expr)
+                        | q<-actQuads act, expr<-(map rc_conjunct . qConjuncts) q]
+     --DESCR -> The relations from which changes can come
+     inMorNodes    = [ DotNode { nodeID         = nameINode fromRels r
+                               , nodeAttributes = [Label (StrLabel (fromString (showADL r)))]
+                               }
+                     | r<-fromRels
+                                               --TODOHAN        , (not.null) [e |e<-edgesIn, (nodeID  (fromNode e))==nameINode fromRels r]
+                     ]
+
+     --DESCR -> The relations to which changes are made
+     outMorNodes   = [ DotNode { nodeID         = nameONode toRels r
+                               , nodeAttributes = [Label (StrLabel (fromString (showADL r)))]
+                               }
+                     | r<-toRels
+               --TODOHAN     , (not.null) [e |e<-edgesOut, (nodeID . toNode) e==nameONode toRels r ]
+                     ]
+
+     --DESCR -> All conjuncts
+     conjunctNodes = [ DotNode { nodeID         = nameCNode conjuncts (rul,c)
+                               , nodeAttributes = [Style [SItem Filled []], FillColor [WC(X11Color (colorRule rul))Nothing], Label (StrLabel (fromString (name rul)))]
+                               }
+                     | (rul,c)<-conjuncts]
+
+     --DESCR -> Each edge represents an insert between a relation on the left and a term on the right to which the relation contributes to an insert.
+     edgesIn       = [ DotEdge { fromNode       = nameINode fromRels r
+                               , toNode         = nameCNode conjuncts (rul,c)
+                               , edgeAttributes = [Label (StrLabel (fromString
+                                                                   (if or (positiveIn c r) then "-" else
+                                                                    if or [not b |b<-positiveIn c r] then "+" else
+                                                                    "+-")))
+                                                  ,Dir Forward]
+                               }
+                     | (rul,c)<-conjuncts, r<-relsUsedIn c, r `elem` fromRels]
+     edgesOut      = [ DotEdge { fromNode       = nameCNode conjuncts (rul,c)
+                               , toNode         = nameONode toRels r
+                               , edgeAttributes = [Label (StrLabel (fromString
+                                                                   (if or (positiveIn c r) then "+" else
+                                                                    if or [not b |b<-positiveIn c r] then "-" else
+                                                                    "+-")))
+                                                  ,Dir Forward]
+                               }
+                     | (rul,c)<-conjuncts, r<-relsUsedIn c]
+     nameINode :: [Declaration] -> Declaration -> String
+     nameINode = nmLkp fSpec "in_"
+     nameCNode = nmLkp fSpec "cj_"
+     nameONode :: [Declaration] -> Declaration -> String
+     nameONode = nmLkp fSpec "out_"
+
+nmLkp :: (LanguageDependent a, Eq a, ShowADL a) => FSpec -> String -> [a] -> a -> String
+nmLkp _ prefix xs x
+ = head ([prefix++show (i::Int) | (i,e)<-zip [1..] xs, e==x]++
+         fatal 216 ("illegal lookup in nmLkp "++show prefix++": " ++showADL x++
+                    "\nin: ["++intercalate "\n    , " (map showADL xs)++"\n    ]")
+        )
+positiveIn :: Expression -> Declaration -> [Bool]
+positiveIn expr decl = f expr   -- all are True, so an insert in rel means an insert in expr
+ where
+  f (EEqu _)     = fatal 237 "Illegal call of positiveIn."
+  f (EImp (l,r)) = f (notCpl l .\/. r)
+  f (EIsc (l,r)) = f l ++ f r
+  f (EUni (l,r)) = f l ++ f r
+  f (EDif (l,r)) = f l ++ f (notCpl r)
+  f (ELrs (l,r)) = f l ++ f (notCpl r)
+  f (ERrs (l,r)) = f (notCpl l) ++ f r
+  f (EDia (l,r)) = f (flp l .\. r ./\. l ./. flp r)
+  f (ECps (l,r)) = f l ++ f r
+  f (ERad (l,r)) = f l ++ f r
+  f (EPrd (l,r)) = f l ++ f r
+  f (EKl0 e)     = f e
+  f (EKl1 e)     = f e
+  f (EFlp e)     = f e
+  f (ECpl e)     = [ not b | b<- f e]
+  f (EBrk e)     = f e
+  f (EDcD d)     = [ True | d==decl ]
+  f (EDcI c)     = [ True | detyp decl==c ]
+  f EEps{}       = []
+  f EDcV{}       = []
+  f EMp1{}       = []

+ src/Database/Design/Ampersand/FSpec/ToFSpec/ADL2FSpec.hs view
@@ -0,0 +1,510 @@+module Database.Design.Ampersand.FSpec.ToFSpec.ADL2FSpec
+         (makeFSpec) where
+
+import Prelude hiding (Ord(..))
+import Data.Char
+import Data.List
+import Data.Maybe
+import Text.Pandoc
+import Database.Design.Ampersand.ADL1
+import Database.Design.Ampersand.ADL1.Rule
+import Database.Design.Ampersand.Basics
+import Database.Design.Ampersand.Classes
+import Database.Design.Ampersand.Core.AbstractSyntaxTree
+import Database.Design.Ampersand.Core.Poset
+import Database.Design.Ampersand.FSpec.FSpec
+import Database.Design.Ampersand.Misc
+import Database.Design.Ampersand.FSpec.Crud
+import Database.Design.Ampersand.FSpec.ToFSpec.ADL2Plug
+import Database.Design.Ampersand.FSpec.ToFSpec.Calc
+import Database.Design.Ampersand.FSpec.ToFSpec.NormalForms 
+import Database.Design.Ampersand.FSpec.ShowADL
+
+fatal :: Int -> String -> a
+fatal = fatalMsg "FSpec.ToFSpec.ADL2FSpec"
+
+makeFSpec :: Options -> A_Context -> FSpec
+makeFSpec opts context
+ =      FSpec { fsName       = name context
+              , originalContext = context 
+              , getOpts      = opts
+              , fspos        = ctxpos context
+              , themes       = themesInScope
+              , pattsInScope = pattsInThemesInScope
+              , rulesInScope = rulesInThemesInScope
+              , declsInScope = declsInThemesInScope 
+              , concsInScope = concsInThemesInScope
+              , cDefsInScope = cDefsInThemesInScope
+              , gensInScope  = gensInThemesInScope
+              , fsLang       = printingLanguage
+              , vplugInfos   = definedplugs
+              , plugInfos    = allplugs
+              , interfaceS   = fSpecAllInterfaces -- interfaces specified in the Ampersand script
+              , interfaceG   = [ifc | ifc<-interfaceGen, let ctxrel = objctx (ifcObj ifc)
+                                    , isIdent ctxrel && source ctxrel==ONE
+                                      || ctxrel `notElem` map (objctx.ifcObj) fSpecAllInterfaces
+                                    , allInterfaces opts]  -- generated interfaces
+              , fSwitchboard
+                  = Fswtch
+                           { fsbEvIn  = nub (map ecaTriggr allVecas) -- eventsIn
+                           , fsbEvOut = nub [evt | eca<-allVecas, evt<-eventsFrom (ecaAction eca)] -- eventsOut
+                           , fsbConjs = nub [ (qRule q, rc_conjunct x) | q <- filter (not . isSignal . qRule) allQuads
+                                                                       , x <- qConjuncts q]
+                           , fsbECAs  = allVecas
+                           }
+
+              , fDeriveProofs = deriveProofs opts context 
+              , fActivities  = allActivities
+              , fRoleRels    = nub [(role,decl) -- fRoleRels says which roles may change the population of which relation.
+                                   | rr <- ctxRRels context
+                                   , decl <- rrRels rr
+                                   , role <- rrRoles rr
+                                   ] 
+              , fRoleRuls    = nub [(role,rule)   -- fRoleRuls says which roles maintain which rules.
+                                   | rule <- allrules
+                                   , role <- maintainersOf rule
+                                   ]
+              , fRoles       = nub (concatMap arRoles (ctxrrules context)++
+                                    concatMap rrRoles (ctxRRels context)++
+                                    concatMap ifcRoles (ctxifcs context)
+                                   ) 
+              , fallRules = allrules
+              , vrules       = filter      isUserDefined  allrules
+              , grules       = filter (not.isUserDefined) allrules
+              , invariants   = filter (not.isSignal)      allrules
+              , vconjs       = allConjs
+              , allConjsPerRule = fSpecAllConjsPerRule
+              , allConjsPerDecl = fSpecAllConjsPerDecl
+              , allConjsPerConcept = fSpecAllConjsPerConcept
+              , vquads       = allQuads
+              , vEcas        = allVecas
+              , vrels        = calculatedDecls
+              , allUsedDecls = relsUsedIn context
+              , allDecls     = fSpecAllDecls
+              , allConcepts  = fSpecAllConcepts
+              , kernels      = constructKernels
+              , fsisa        = concatMap genericAndSpecifics (gens context)
+              , vpatterns    = patterns context
+              , vgens        = gens context
+              , vIndices     = identities context
+              , vviews       = viewDefs context
+              , conceptDefs  = ctxcds context
+              , fSexpls      = ctxps context
+              , metas        = ctxmetas context
+              , crudInfo     = mkCrudInfo fSpecAllConcepts fSpecAllDecls fSpecAllInterfaces
+              , initialPops  = initialpops
+              , allAtoms     = allatoms
+              , allLinks     = alllinks
+              , allViolations  = [ (r,vs)
+                                 | r <- allrules, not (isSignal r)
+                                 , let vs = ruleviolations (gens context) initialpops r, not (null vs) ]
+              , allExprs     = expressionsIn context
+              , allSigns     = nub $ map sign fSpecAllDecls ++ map sign (expressionsIn context)
+              , initialConjunctSignals = [ (conj, viols) | conj <- allConjs 
+                                         , let viols = conjunctViolations (gens context) initialpops conj
+                                         , not $ null viols
+                                         ]
+              }
+   where           
+     allatoms :: [Atom]
+     allatoms = nub (concatMap atoms initialpops)
+       where
+         atoms :: Population -> [Atom]
+         atoms udp = case udp of
+           PRelPopu{} ->  map (mkAtom ((source.popdcl) udp).srcPaire) (popps udp)
+                       ++ map (mkAtom ((target.popdcl) udp).trgPaire) (popps udp)
+           PCptPopu{} ->  map (mkAtom (        popcpt  udp)         ) (popas udp)
+     mkAtom :: A_Concept -> String -> Atom
+     mkAtom cpt value = 
+        Atom { atmRoots = rootConcepts gs [cpt]
+               , atmIn   = largerConcepts gs cpt `uni` [cpt]
+               , atmVal  = value
+               }
+       where
+         gs = gens context
+     dclLinks :: Declaration -> [A_Pair]
+     dclLinks dcl
+       = [Pair   { lnkDcl   = dcl
+                 , lnkLeft  = mkAtom (source dcl) (srcPaire p) 
+                 , lnkRight = mkAtom (target dcl) (trgPaire p)
+                 }
+         | p <- pairsOf dcl]
+     alllinks ::  [A_Pair]
+     alllinks = concatMap dclLinks fSpecAllDecls
+     pairsOf :: Declaration -> Pairs
+     pairsOf d = case filter theDecl initialpops of
+                    []    -> []
+                    [pop] -> popps pop
+                    _     -> fatal 273 "Multiple entries found in populationTable"
+        where
+          theDecl :: Population -> Bool
+          theDecl p = case p of
+                        PRelPopu{} -> popdcl p == d
+                        PCptPopu{} -> False
+
+
+     fSpecAllConcepts = concs context -- `uni` [ONE]
+     fSpecAllDecls = relsDefdIn context
+     fSpecAllInterfaces = map enrichIfc (ctxifcs context) 
+     
+     themesInScope = if null (ctxthms context)   -- The names of patterns/processes to be printed in the functional specification. (for making partial documentation)
+                     then map name (patterns context)
+                     else ctxthms context
+     pattsInThemesInScope = filter (\p -> name p `elem` themesInScope) (patterns context)
+     cDefsInThemesInScope = filter (\cd -> cdfrom cd `elem` themesInScope) (ctxcds context)
+     rulesInThemesInScope = ctxrs context `uni` concatMap ptrls pattsInThemesInScope
+     declsInThemesInScope = ctxds context `uni` concatMap ptdcs pattsInThemesInScope
+     concsInThemesInScope = concs (ctxrs context) `uni`  concs pattsInThemesInScope
+     gensInThemesInScope  = ctxgs context ++ concatMap ptgns pattsInThemesInScope
+
+     enrichIfc :: Interface -> Interface
+     enrichIfc ifc
+      = ifc{ ifcEcas = fst . assembleECAs opts context $ ifcParams ifc
+           , ifcControls = makeIfcControls (ifcParams ifc) allConjs
+           }
+     initialpops = [ PRelPopu{ popdcl = popdcl (head eqclass)
+                             , popps  = (nub.concat) [ popps pop | pop<-eqclass ]
+                             }
+                   | eqclass<-eqCl popdcl [ pop | pop@PRelPopu{}<-populations ] ] ++
+                   [ PCptPopu{ popcpt = popcpt (head eqclass)
+                             , popas  = (nub.concat) [ popas pop | pop<-eqclass ]
+                             }
+                   | eqclass<-eqCl popcpt [ pop | pop@PCptPopu{}<-populations ] ]
+       where populations = ctxpopus context++concatMap ptups (patterns context)       
+
+     allConjs = makeAllConjs opts allrules
+     fSpecAllConjsPerRule :: [(Rule,[Conjunct])]
+     fSpecAllConjsPerRule = converse [ (conj, rc_orgRules conj) | conj <- allConjs ]
+     fSpecAllConjsPerDecl = converse [ (conj, relsUsedIn $ rc_conjunct conj) | conj <- allConjs ] 
+     fSpecAllConjsPerConcept = converse [ (conj, [source r, target r]) | conj <- allConjs, r <- relsMentionedIn $ rc_conjunct conj ] 
+     allQuads = quadsOfRules opts allrules 
+     
+     allrules = map setIsSignal (allRules context)
+        where setIsSignal r = r{isSignal = (not.null) (maintainersOf r)}
+     maintainersOf :: Rule -> [Role]
+     maintainersOf r 
+       = [role 
+         | role <- concatMap arRoles . filter (\x -> name r `elem` arRules x) . ctxrrules $ context
+         ]
+     isUserDefined rul =
+       case r_usr rul of
+         UserDefined  -> True
+         Multiplicity -> False
+         Identity     -> False
+     allActivities :: [Activity]
+     allActivities = map makeActivity (filter isSignal allrules)
+     allVecas = {-preEmpt opts . -} fst (assembleECAs opts context fSpecAllDecls)   -- TODO: preEmpt gives problems. Readdress the preEmption problem and redo, but properly.
+     -- | allDecs contains all user defined plus all generated relations plus all defined and computed totals.
+     calcProps :: Declaration -> Declaration
+     calcProps d = d{decprps_calc = Just calculated}
+         where calculated = decprps d `uni` [Tot | d `elem` totals]
+                                      `uni` [Sur | d `elem` surjectives]
+     calculatedDecls = map calcProps fSpecAllDecls
+     constructKernels = foldl f (group (delete ONE fSpecAllConcepts)) (gens context)
+         where f disjuncLists g = concat haves : nohaves
+                 where
+                   (haves,nohaves) = partition (not.null.intersect (concs g)) disjuncLists
+  -- 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
+      = nub [rel | q<-filter (not . isSignal . qRule) allQuads -- all quads for invariant rules
+                 , isIdent (qDcl q)
+                 , x<-qConjuncts q, dnf<-rc_dnfClauses x
+                 , let antc = conjNF opts (foldr (./\.) (EDcV (sign (head (antcs dnf++conss dnf)))) (antcs dnf))
+                 , isRfx antc -- We now know that I is a subset of the antecedent of this dnf clause.
+                 , cons<-map exprCps2list (conss dnf)
+            -- let I |- r;s;t be an invariant rule, then r and s and t~ and s~ are all total.
+                 , rel<-init cons++[flp r | r<-tail cons]
+                 ]
+
+     --------------
+     --making plugs
+     --------------
+     vsqlplugs = [ (makeUserDefinedSqlPlug context p) | p<-ctxsql context] --REMARK -> no optimization like try2specific, because these plugs are user defined
+     definedplugs = map InternalPlug vsqlplugs
+                 ++ map ExternalPlug (ctxphp context)
+     allplugs = definedplugs ++      -- all plugs defined by the user
+                genPlugs             -- all generated plugs
+     genPlugs = [InternalPlug (rename p (qlfname (name p)))
+                | p <- uniqueNames (map name definedplugs) -- the names of definedplugs will not be changed, assuming they are all unique
+                                   (makeGeneratedSqlPlugs opts context totsurs entityRels)
+                ]
+     -- relations to be saved in generated plugs: if decplug=True, the declaration has the BYPLUG and therefore may not be saved in a database
+     -- WHAT -> is a BYPLUG?
+     entityRels = [ d | d<-calculatedDecls, not (decplug d)] -- The persistent relations.
+
+     qlfname x = if null (namespace opts) then x else "ns"++namespace opts++x
+
+     --TODO151210 -> Plug A is overbodig, want A zit al in plug r
+--CONTEXT Temp
+--PATTERN Temp
+--r::A*B[TOT].
+--t::E*ECps[UNI].
+--ENDPATTERN
+--ENDCONTEXT
+{-
+    **************************************
+    * Plug E                               *
+    * I  [INJ,SUR,UNI,TOT,SYM,ASY,TRN,RFX] *
+    * t  [UNI]                             *
+    **************************************
+    * Plug ECps                            *
+    * I  [INJ,SUR,UNI,TOT,SYM,ASY,TRN,RFX] *
+    **************************************
+    * Plug B                               *
+    * I  [INJ,SUR,UNI,TOT,SYM,ASY,TRN,RFX] *
+    **************************************
+    * Plug A                               *
+    * I  [INJ,SUR,UNI,TOT,SYM,ASY,TRN,RFX] *
+    **************************************
+    * Plug r                               *
+    * I  [INJ,SUR,UNI,TOT,SYM,ASY,TRN,RFX] *
+    * r  [TOT]                             *
+    **************************************
+-}
+     -------------------
+     --END: making plugs
+     -------------------
+     -------------------
+     --making interfaces
+     -------------------
+     -- interfaces (type ObjectDef) can be generated from a basic ontology. That is: they can be derived from a set
+     -- of relations together with multiplicity constraints. That is what interfaceG does.
+     -- This is meant to help a developer to build his own list of interfaces, by providing a set of interfaces that works.
+     -- The developer may relabel attributes by names of his own choice.
+     -- This is easier than to invent a set of interfaces from scratch.
+
+     -- Rule: a interface must be large enough to allow the required transactions to take place within that interface.
+     -- Attributes of an ObjectDef have unique names within that ObjectDef.
+
+--- generation of interfaces:
+--  Ampersand generates interfaces for the purpose of quick prototyping.
+--  A script without any mention of interfaces is supplemented
+--  by a number of interface definitions that gives a user full access to all data.
+--  Step 1: select and arrange all relations to obtain a set cRels of total relations
+--          to ensure insertability of entities (signal declarations are excluded)
+     cRels = [     EDcD d  | d@Sgn{}<-fSpecAllDecls, not(deciss d), isTot d, not$decplug d]++
+             [flp (EDcD d) | d@Sgn{}<-fSpecAllDecls, not(deciss d), not (isTot d) && isSur d, not$decplug d]
+--  Step 2: select and arrange all relations to obtain a set dRels of injective relations
+--          to ensure deletability of entities (signal declarations are excluded)
+     dRels = [     EDcD d  | d@Sgn{}<-fSpecAllDecls, not(deciss d), isInj d, not$decplug d]++
+             [flp (EDcD d) | d@Sgn{}<-fSpecAllDecls, not(deciss d), not (isInj d) && isUni d, not$decplug d]
+--  Step 3: compute longest sequences of total expressions and longest sequences of injective expressions.
+     maxTotPaths = clos1 cRels   -- maxTotPaths = cRels+, i.e. the transitive closure of cRels
+     maxInjPaths = clos1 dRels   -- maxInjPaths = dRels+, i.e. the transitive closure of dRels
+     --    Warshall's transitive closure algorithm, adapted for this purpose:
+     clos1 :: [Expression] -> [[Expression]]
+     clos1 xs
+      = foldl f [ [ x ] | x<-xs] (nub (map source xs) `isc` nub (map target xs))
+        where
+          f :: [[Expression]] -> A_Concept -> [[Expression]]
+          f q x = q ++ [l ++ r | l <- q, x == target (last l),
+                                 r <- q, x == source (head r), null (l `isc` r)]
+
+--  Step 4: i) generate interfaces starting with INTERFACE concept: I[Concept]
+--          ii) generate interfaces starting with INTERFACE concepts: V[ONE*Concept]
+--          note: based on a theme one can pick a certain set of generated interfaces (there is not one correct set)
+--                default theme => generate interfaces from the clos total expressions and clos injective expressions (see step1-3).
+--                student theme => generate interface for each concept with relations where concept is source or target (note: step1-3 are skipped)
+     interfaceGen = step4a ++ step4b
+     step4a
+      | theme opts == StudentTheme
+      = [Ifc { ifcClass = Nothing
+             , ifcParams = params
+             , ifcArgs   = []
+             , ifcObj    = Obj { objnm   = name cpt ++ " (instantie)"
+                               , objpos  = Origin "generated object for interface for each concept in TblSQL or ScalarSQL"
+                               , objctx  = EDcI cpt
+                               , objmView = Nothing
+                               , objmsub = Just . Box cpt Nothing $
+                                            Obj { objnm   = "I["++name cpt++"]"
+                                                , objpos  = Origin "generated object: step 4a - default theme"
+                                                , objctx  = EDcI cpt
+                                                , objmView = Nothing
+                                                , objmsub = Nothing
+                                                , objstrs = [] }
+                                           :[Obj { objnm   = name dcl ++ "::"++name (source dcl)++"*"++name (target dcl)
+                                                 , objpos  = Origin "generated object: step 4a - default theme"
+                                                 , objctx  = if source dcl==cpt then EDcD dcl else flp (EDcD dcl)
+                                                 , objmView = Nothing
+                                                 , objmsub = Nothing
+                                                 , objstrs = [] }
+                                            | dcl <- params]
+                               , objstrs = []
+                               }
+             , ifcEcas   = fst (assembleECAs opts context params)
+             , ifcControls = makeIfcControls params allConjs
+             , ifcPos    = Origin "generated interface for each concept in TblSQL or ScalarSQL"
+             , ifcPrp    = "Interface " ++name cpt++" has been generated by Ampersand."
+             , ifcRoles  = []
+             }
+        | cpt<-fSpecAllConcepts
+        , let params = [ d | d<-fSpecAllDecls, cpt `elem` concs d]
+        ]
+      --end student theme
+      --otherwise: default theme
+      | otherwise --note: the uni of maxInj and maxTot may take significant time (e.g. -p while generating index.htm)
+                  --note: associations without any multiplicity are not in any Interface
+                  --note: scalars with only associations without any multiplicity are not in any Interface
+      = let recur es
+             = [ Obj { objnm   = showADL t
+                     , objpos  = Origin "generated recur object: step 4a - default theme"
+                     , objctx  = t
+                     , objmView = Nothing
+                     , objmsub = Just . Box (target t) Nothing $ recur [ pth | (_:pth)<-cl, not (null pth) ]
+                     , objstrs = [] }
+               | cl<-eqCl head es, (t:_)<-take 1 cl] --
+            -- es is a list of expression lists, each with at least one expression in it. They all have the same source concept (i.e. source.head)
+            -- Each expression list represents a path from the origin of a box to the attribute.
+            -- 16 Aug 2011: (recur es) is applied once where es originates from (maxTotPaths `uni` maxInjPaths) both based on clos
+            -- Interfaces for I[Concept] are generated only for concepts that have been analysed to be an entity.
+            -- These concepts are collected in gPlugConcepts
+            gPlugConcepts = [ c | InternalPlug plug@TblSQL{}<-genPlugs , (c,_)<-take 1 (cLkpTbl plug) ]
+            -- Each interface gets all attributes that are required to create and delete the object.
+            -- All total attributes must be included, because the interface must allow an object to be deleted.
+        in
+        [Ifc { ifcClass    = Nothing
+             , ifcParams   = params
+             , ifcArgs     = []
+             , ifcObj      = Obj { objnm   = name c
+                                 , objpos  = Origin "generated object: step 4a - default theme"
+                                 , objctx  = EDcI c
+                                 , objmView = Nothing
+                                 , objmsub = Just . Box c Nothing $ objattributes
+                                 , objstrs = [] }
+             , ifcEcas     = fst (assembleECAs opts context params)
+             , ifcControls = makeIfcControls params allConjs
+             , ifcPos      = Origin "generated interface: step 4a - default theme"
+             , ifcPrp      = "Interface " ++name c++" has been generated by Ampersand."
+             , ifcRoles    = []
+             }
+        | cl <- eqCl (source.head) [ pth | pth<-maxTotPaths `uni` maxInjPaths, (source.head) pth `elem` gPlugConcepts ]
+        , let objattributes = recur cl
+        , not (null objattributes) --de meeste plugs hebben in ieder geval I als attribuut
+        , --exclude concept A without cRels or dRels (i.e. A in Scalar without total associations to other plugs)
+          not (length objattributes==1 && isIdent(objctx(head objattributes)))
+        , let e0=head cl, if null e0 then fatal 284 "null e0" else True
+        , let c=source (head e0)
+        , let params = [ d | EDcD d <- concatMap primsMentionedIn (expressionsIn objattributes)]++
+                       [ Isn cpt |  EDcI cpt <- concatMap primsMentionedIn (expressionsIn objattributes)]
+        ]
+     --end otherwise: default theme
+     --end stap4a
+     step4b --generate lists of concept instances for those concepts that have a generated INTERFACE in step4a
+      = [Ifc { ifcClass    = ifcClass ifcc
+             , ifcParams   = ifcParams ifcc
+             , ifcArgs     = ifcArgs   ifcc
+             , ifcObj      = Obj { objnm   = nm
+                                 , objpos  = Origin "generated object: step 4b"
+                                 , objctx  = EDcI ONE
+                                 , objmView = Nothing
+                                 , objmsub = Just . Box ONE Nothing $ [att]
+                                 , objstrs = [] }
+             , ifcEcas     = ifcEcas     ifcc
+             , ifcControls = ifcControls ifcc
+             , ifcPos      = ifcPos      ifcc
+             , ifcPrp      = ifcPrp      ifcc
+             , ifcRoles    = []
+             }
+        | ifcc<-step4a
+        , let c   = source(objctx (ifcObj ifcc))
+              nm'::Int->String
+              nm' 0  = plural printingLanguage (name c)
+              nm' i  = plural printingLanguage (name c) ++ show i
+              nms = [nm' i |i<-[0..], nm' i `notElem` map name (ctxifcs context)]
+              nm
+                | theme opts == StudentTheme = name c
+                | null nms = fatal 355 "impossible"
+                | otherwise = head nms
+              att = Obj (name c) (Origin "generated attribute object: step 4b") (EDcV (Sign ONE c)) Nothing Nothing []
+        ]
+     ----------------------
+     --END: making interfaces
+     ----------------------
+     printingLanguage = fromMaybe (ctxlang context) (language opts)  -- The language for printing this specification is taken from the command line options (language opts). If none is specified, the specification is printed in the language in which the context was defined (ctxlang context).
+
+        {- makeActivity turns a process rule into an activity definition.
+        Each activity can be mapped to a single interface.
+        A call to such an interface takes the population of the current context to another population,
+        while maintaining all invariants.
+        -}
+     makeActivity :: Rule -> Activity
+     makeActivity rul
+         = let s = Act{ actRule   = rul
+                      , actTrig   = decls
+                      , actAffect = nub [ d' | (d,_,d')<-clos2 affectPairs, d `elem` decls]
+                      , actQuads  = invQs
+                      , actEcas   = [eca | eca<-allVecas, eDcl (ecaTriggr eca) `elem` decls]
+                      , actPurp   = [Expl { explPos = OriginUnknown
+                                          , explObj = ExplRule (name rul)
+                                          , explMarkup = A_Markup { amLang   = Dutch
+                                                                  , amFormat = ReST
+                                                                  , amPandoc = [Plain [Str "Waartoe activiteit ", Quoted SingleQuote [Str (name rul)], Str" bestaat is niet gedocumenteerd." ]]
+                                                                  }
+                                          , explUserdefd = False
+                                          , explRefIds = ["Regel "++name rul]
+                                          }
+                                    ,Expl { explPos = OriginUnknown
+                                          , explObj = ExplRule (name rul)
+                                          , explMarkup = A_Markup { amLang   = English
+                                                                  , amFormat = ReST
+                                                                  , amPandoc = [Plain [Str "For what purpose activity ", Quoted SingleQuote [Str (name rul)], Str" exists remains undocumented." ]]
+                                                                  }
+                                          , explUserdefd = False
+                                          , explRefIds = ["Regel "++name rul]
+                                          }
+                                    ]
+                      } in s
+         where
+        -- relations that may be affected by an edit action within the transaction
+             decls        = relsUsedIn rul
+        -- the quads that induce automated action on an editable relation.
+        -- (A quad contains the conjunct(s) to be maintained.)
+        -- Those are the quads that originate from invariants.
+             invQs       = [q | q<-allQuads, (not.isSignal.qRule) q
+                              , (not.null) ((relsUsedIn.qRule) q `isc` decls)] -- SJ 20111201 TODO: make this selection more precise (by adding inputs and outputs to a quad).
+        -- a relation affects another if there is a quad (i.e. an automated action) that links them
+             affectPairs = [(qDcl q,[q], d) | q<-invQs, d<-(relsUsedIn.qRule) q]
+        -- the relations affected by automated action
+        --      triples     = [ (r,qs,r') | (r,qs,r')<-clos affectPairs, r `elem` rels]
+        ----------------------------------------------------
+        --  Warshall's transitive closure algorithm in Haskell, adapted to carry along the intermediate steps:
+        ----------------------------------------------------
+             clos2 :: (Eq a,Eq b) => [(a,[b],a)] -> [(a,[b],a)]     -- e.g. a list of pairs, with intermediates in between
+             clos2 xs
+               = foldl f xs (nub (map fst3 xs) `isc` nub (map thd3 xs))
+                 where
+                  f q x = q `un`
+                             [(a, qs `uni` qs', b') | (a, qs, b) <- q, b == x,
+                              (a', qs', b') <- q, a' == x]
+                  ts `un` [] = ts
+                  ts `un` ((a',qs',b'):ts')
+                   = ([(a,qs `uni` qs',b) | (a,qs,b)<-ts, a==a' && b==b']++
+                      [(a,qs,b)           | (a,qs,b)<-ts, a/=a' || b/=b']++
+                      [(a',qs',b')        | (a',b') `notElem` [(a,b) |(a,_,b)<-ts]]) `un` ts'
+        
+makeIfcControls :: [Declaration] -> [Conjunct] -> [Conjunct]
+makeIfcControls params allConjs = [ conj 
+                                | conj<-allConjs
+                                , (not.null) (map EDcD params `isc` primsMentionedIn (rc_conjunct conj))
+                                -- Filtering for uni/inj invariants is pointless here, as we can only filter out those conjuncts for which all
+                                -- originating rules are uni/inj invariants. Conjuncts that also have other originating rules need to be included
+                                -- and the uni/inj invariant rules need to be filtered out at a later stage (in Generate.hs).
+                                ]
+  
+
+class Named a => Rename a where
+ rename :: a->String->a
+ -- | the function uniqueNames ensures case-insensitive unique names like sql plug names
+ uniqueNames :: [String]->[a]->[a]
+ uniqueNames taken xs
+  = [p | cl<-eqCl (map toLower.name) xs  -- each equivalence class cl contains (identified a) with the same map toLower (name p)
+       , p <-if name (head cl) `elem` taken || length cl>1
+             then [rename p (name p++show i) | (p,i)<-zip cl [(1::Int)..]]
+             else cl
+    ]
+
+instance Rename PlugSQL where
+ rename p x = p{sqlname=x}

+ src/Database/Design/Ampersand/FSpec/ToFSpec/ADL2Plug.hs view
@@ -0,0 +1,472 @@+module Database.Design.Ampersand.FSpec.ToFSpec.ADL2Plug
+  (showPlug
+  ,makeGeneratedSqlPlugs
+  ,makeUserDefinedSqlPlug
+  )
+where
+import Database.Design.Ampersand.Core.AbstractSyntaxTree hiding (sortWith)
+import Database.Design.Ampersand.Core.Poset as Poset hiding (sortWith)
+import Prelude hiding (Ord(..))
+import Database.Design.Ampersand.Basics
+import Database.Design.Ampersand.Classes
+import Database.Design.Ampersand.ADL1
+import Database.Design.Ampersand.FSpec.ShowADL
+import Database.Design.Ampersand.FSpec.FSpec
+import Database.Design.Ampersand.Misc
+import Database.Design.Ampersand.FSpec.ShowHS --for debugging
+import Data.Maybe
+import Data.Char
+import Data.List (nub,intercalate,intersect,partition,group,delete)
+import GHC.Exts (sortWith)
+--import Debug.Trace
+
+fatal :: Int -> String -> a
+fatal = fatalMsg "FSpec.ToFSpec.ADL2Plug"
+
+-- Not the most ideal place for showPlug, but putting it in Database.Design.Ampersand.FSpec.FSpec creates an import cycle, which will require quite some effort to resolve.
+showPlug :: PlugSQL -> [String]
+showPlug plug =
+  [ "Table: " ++ (show $ sqlname plug) ++ " (" ++ plugType ++ ")" ] ++
+  indent 4
+    (blockParenthesize "[" "]" "," $ map showField $ plugFields plug)
+  where plugType = case plug of
+          TblSQL{}    -> "wide"
+          BinSQL{}    -> "binary"
+          ScalarSQL{} -> "scalar"
+  
+        showField :: SqlField -> [String]
+        showField fld = ["{" ++ (if fldnull fld then "+" else "-") ++ "NUL," ++ (if flduniq fld then "+" else "-") ++ "UNQ" ++
+                         (if fld `elem` kernelFields then ", K} " else "}    ") ++
+                         (show $ fldname fld) ++ ": "++showADL (target $ fldexpr fld)]
+
+        kernelFields = case plug of 
+                         TblSQL{} -> map snd $ cLkpTbl plug
+                         _        -> [] -- binaries and scalars do not have kernel fields
+
+makeGeneratedSqlPlugs :: Options
+              -> A_Context
+              -> [Expression]
+              -> [Declaration]    -- ^ relations to be saved in generated database plugs.
+              -> [PlugSQL]
+makeGeneratedSqlPlugs opts context totsurs entityDcls = gTables
+  where
+        vsqlplugs = [ (makeUserDefinedSqlPlug context p) | p<-ctxsql context] --REMARK -> no optimization like try2specific, because these plugs are user defined
+        gTables = gPlugs ++ gLinkTables
+        gPlugs :: [PlugSQL]
+        gPlugs   = makeEntityTables opts context entityDcls (gens context) (ctxgenconcs context) (relsUsedIn vsqlplugs)
+        -- all plugs for relations not touched by definedplugs and gPlugs
+        gLinkTables :: [PlugSQL]
+        gLinkTables = [ makeLinkTable context dcl totsurs
+                      | dcl<-entityDcls
+                      , Inj `notElem` multiplicities dcl
+                      , Uni `notElem` multiplicities dcl]
+
+-----------------------------------------
+--makeLinkTable
+-----------------------------------------
+-- makeLinkTable creates associations (BinSQL) between plugs that represent wide tables.
+-- Typical for BinSQL is that it has exactly two columns that are not unique and may not contain NULL values
+--
+-- this concerns relations that are not univalent nor injective, i.e. flduniq=False for both columns
+-- Univalent relations and injective relations cannot be associations, because they are used as attributes in wide tables.
+-- REMARK -> imagine a context with only one univalent relation r::A*B.
+--           Then r can be found in a wide table plug (TblSQL) with a list of two columns [I[A],r],
+--           and not in a BinSQL with a pair of columns (I/\r;r~, r)
+--
+-- a relation r (or r~) is stored in the trgFld of this plug
+
+-- | Make a binary sqlplug for a relation that is neither inj nor uni
+makeLinkTable :: A_Context -> Declaration -> [Expression] -> PlugSQL
+makeLinkTable context dcl totsurs =
+  case dcl of
+    Sgn{}
+     | isInj dcl || isUni dcl
+        -> fatal 55 $ "unexpected call of makeLinkTable("++show dcl++"), because it is injective or univalent."
+     | otherwise
+        -> BinSQL
+             { sqlname = unquote . name $ dcl
+             , columns = ( -- The source field:
+                           Fld { fldname = concat["Src" | isEndo dcl]++(unquote . name . source) trgExpr
+                               , fldexpr = srcExpr
+                               , fldtype = sqlTypeOf context (target srcExpr)
+                               , flduse  = if suitableAsKey (sqlTypeOf context (target srcExpr))
+                                           then ForeignKey (target srcExpr)
+                                           else PlainAttr
+                               , fldnull = isTot trgExpr
+                               , flduniq = isUni trgExpr
+                               }
+                         , -- The target field:
+                           Fld { fldname = concat["Tgt" | isEndo dcl]++(unquote . name . target) trgExpr
+                               , fldexpr = trgExpr
+                               , fldtype = sqlTypeOf context (target trgExpr)
+                               , flduse  = if suitableAsKey (sqlTypeOf context (target trgExpr))
+                                           then ForeignKey (target trgExpr)
+                                           else PlainAttr
+                               , fldnull = isSur trgExpr
+                               , flduniq = isInj trgExpr
+                               }
+                          )
+             , cLkpTbl = [] --in case of TOT or SUR you might use a binary plug to lookup a concept (don't forget to nub)
+             , mLkp    = trgExpr
+          --   , sqlfpa  = NO
+             }
+    _  -> fatal 90 "Do not call makeLinkTable on relations other than Sgn{}"
+   where
+    r_is_Tot = isTot dcl || dcl `elem` [ d |       EDcD d  <- totsurs]
+    r_is_Sur = isSur dcl || dcl `elem` [ d | EFlp (EDcD d) <- totsurs]
+    --the expr for the source of r
+    srcExpr
+     | r_is_Tot = EDcI (source dcl)
+     | r_is_Sur = EDcI (target dcl)
+     | otherwise = let er=EDcD dcl in EDcI (source dcl) ./\. (er .:. flp er)
+    --the expr for the target of r
+    trgExpr
+     | not r_is_Tot && r_is_Sur = flp (EDcD dcl)
+     | otherwise                = EDcD dcl
+unquote :: String -> String
+unquote str 
+  | length str < 2 = str
+  | head str == '"' && last str == '"' = reverse . tail . reverse .tail $ str 
+  | otherwise = str
+      
+suitableAsKey :: SqlType -> Bool
+suitableAsKey st =
+  case st of
+    SQLChar{}    -> True
+    SQLBlob      -> False
+    SQLPass      -> False
+    SQLSingle    -> True
+    SQLDouble    -> True
+    SQLText      -> False
+    SQLuInt{}    -> True
+    SQLsInt{}    -> True
+    SQLId{}      -> True
+    SQLVarchar{} -> True
+    SQLBool{}    -> True
+
+-----------------------------------------
+--rel2fld
+-----------------------------------------
+-- Each relation yields one field f1 in the plug...
+-- r is the relation from some kernel field k1 to f1
+-- (fldexpr k1) is the relation from the plug's imaginary ID to k1
+-- (fldexpr k1);r is the relation from ID to f1
+-- the rule (fldexpr k1)~;(fldexpr k1);r = r holds because (fldexpr k1) is uni and sur, which means that (fldexpr k1)~;(fldexpr k1) = I
+-- REMARK -> r may be tot or sur, but not inj. (fldexpr k1) may be tot.
+--
+-- fldnull and fldunique are based on the multiplicity of the relation (kernelpath);r from ID to (target r)
+-- it is given that ID is unique and not null
+-- fldnull=not(isTot (kernelpath);r)
+-- flduniq=isInj (kernelpath);r
+--
+-- (kernel++plugAtts) defines the name space, making sure that all fields within a plug have unique names.
+
+-- | Create field for TblSQL or ScalarSQL plugs
+rel2fld :: A_Context
+        -> [Expression] -- ^ all relations (in the form either EDcD r, EDcI or EFlp (EDcD r)) that may be represented as attributes of this entity.
+        -> [Expression] -- ^ all relations (in the form either EDcD r or EFlp (EDcD r)) that are defined as attributes by the user.
+        -> Expression   -- ^ either EDcD r, EDcI c or EFlp (EDcD r), representing the relation from some kernel field k1 to f1
+        -> SqlField
+rel2fld context
+        kernel
+        plugAtts
+        e
+ = Fld { fldname = fldName
+       , fldexpr = e
+       , fldtype = sqlTypeOf context (target e)
+       , flduse  =
+          let f expr =
+                 case expr of
+                    EDcI c   -> if suitableAsKey (sqlTypeOf context c)
+                                then TableKey ((not.maybenull) e) c
+                                else PlainAttr
+                    EDcD _   -> PlainAttr
+                    EFlp e'  -> f e'
+                    _        -> fatal 144 ("No flduse defined for "++show expr)
+          in f e
+       , fldnull = maybenull e
+       , flduniq = isInj e      -- all kernel fldexprs are inj
+                                -- Therefore, a composition of kernel expr (I;kernelpath;e) will also be inj.
+                                -- It is enough to check isInj e
+       }
+   where
+   fldName = case [nm | (r',nm)<-table, e==r'] of
+               []   -> fatal 117 $ "null names in table for e: " ++ show (e,table)
+               n:_  -> n
+     where
+       table :: [(Expression, String)]
+       table   = [ entry
+                 | cl<-eqCl (map toLower.mkColumnName) (kernel++plugAtts)
+                 , entry<-if length cl==1 then [(rel,mkColumnName rel) |rel<-cl] else tbl cl]
+       tbl rs  = [ entry
+                 | cl<-eqCl (map toLower.name.source) rs
+                 , entry<-if length cl==1
+                          then [(rel,mkColumnName rel++"_"++(unquote . name . source) rel) |rel<-cl]
+                          else [(rel,mkColumnName rel++"_"++show i)|(rel,i)<-zip cl [(0::Int)..]]]
+       
+       mkColumnName expr = mkColumnName' False expr
+         where  mkColumnName' isFlipped (EFlp x) = mkColumnName' (not isFlipped) x
+                mkColumnName' isFlipped (EDcD d) = (if isFlipped then "src" else "tgt")++"_"++(unquote . name) d
+                mkColumnName' _         (EDcI c) = (unquote . name) c
+                mkColumnName' _ rel = fatal 162 ( "Unexpected relation found:\n"++
+                                                  intercalate "\n  "
+                                                    [ "***rel:"
+                                                    , show rel
+                                                    , "***kernel:"
+                                                    , show kernel
+                                                    , "***plugAtts:"
+                                                    , show plugAtts
+                                                    ]
+                                                )
+   --in a wide table, m can be total, but the field for its target may contain NULL values,
+   --because (why? ...)
+   --A kernel field may contain NULL values if
+   --  + its field expr is not total OR
+   --  + its field expr is not the identity relation AND the (kernel) field for its source may contain NULL values
+   --(if the fldexpr of a kernel field is the identity,
+   -- then the fldexpr defines the relation between this kernel field and this kernel field (fldnull=not(isTot I) and flduniq=isInj I)
+   -- otherwise it is the relation between this kernel field and some other kernel field)
+   maybenull expr
+    | length(map target kernel) > length(nub(map target kernel))
+       = fatal 146 $"more than one kernel field for the same concept:\n    expr = " ++(show expr)++
+           intercalate "\n  *** " ( "" : (map (name.target) kernel))
+    | otherwise = case expr of
+                   EDcD dcl
+                        | (not.isTot) dcl -> True
+                        | otherwise -> (not.null) [()|k<-kernelpaths, target k==source dcl && isTot k || target k==target dcl && isSur k ]
+                   EFlp (EDcD dcl)
+                        | (not.isSur) dcl -> True
+                        | otherwise -> (not.null) [()|k<-kernelpaths, target k==source dcl && isSur k || target k==target dcl && isTot k]
+                   EDcI _ -> False
+                   _ -> fatal 152 ("Illegal Plug Expression: "++show expr ++"\n"++
+                                   " ***kernel:*** \n   "++
+                                   intercalate "\n   " (map show kernel)++"\n"++
+                                   " ***Attributes:*** \n   "++
+                                   intercalate "\n   " (map show plugAtts)++"\n"++
+                                   " ***e:*** \n   "++
+                                   ( show e)
+                                  )
+
+   kernelpaths = clos kernel
+    where
+     -- Warshall's transitive closure algorithm, adapted for this purpose:
+     clos :: [Expression] -> [Expression]
+     clos xs
+      = [ foldr1 (.:.) expr | expr<-exprList ]
+        where
+         exprList :: [[Expression]]
+      -- SJ 20131117. The following code (exprList and f) assumes no ISA's in the A-structure. Therefore, this works due to the introduction of EEps.
+         exprList = foldl f [[x] | x<-nub xs]
+                          (nub [c | c<-nub (map source xs), c'<-nub (map target xs), c==c'])
+         f :: [[Expression]] -> A_Concept -> [[Expression]]
+         f q x = q ++ [ls ++ rs | ls <- q, x == target (last ls)
+                                , rs <- q, x == source (head rs), null (ls `isc` rs)]
+
+-- ^ Explanation:  rel is a relation from some kernel field k to f
+-- ^ (fldexpr k) is the relation from the plug's ID to k
+-- ^ (fldexpr k);rel is the relation from ID to f
+
+-----------------------------------------
+--makeEntityTables  (formerly called: makeTblPlugs)
+-----------------------------------------
+{- makeEntityTables computes a set of plugs to obtain tables in a transactional database with minimal redundancy.
+   We call them "wide tables".
+   makeEntityTables computes entities with their attributes.
+   It is based on the principle that each concept is represented in at most one plug,
+   and each relation in at most one plug.
+   First, we determine the kernels for all plugs.
+   A kernel contains the concept table(s) for all concepts that are administered in the same entity.
+   For that, we collect all relations that are univalent, injective, and surjective (the kernel relations).
+      By the way, that includes all isa-relations, since they are univalent, injective, and surjective by definition.
+      Since isa-relations are not declared explicitly, they are generated separately.
+   If two concepts a and b are in the same entity, there is a concept g such that a isa g and b isa g.
+   Of all concepts in an entity, one most generic concept is designated as root, and is positioned in the first column of the table.
+   Secondly, we take all univalent relations that are not in the kernel, but depart from this kernel.
+   These relations serve as attributes. Code:  [a| a<-attRels, source a `elem` concs kernel]
+   Then, all these relations are made into fields. Code: plugFields = [rel2fld plugMors a| a<-plugMors]
+   We also define two lookup tables, one for the concepts that are stored in the kernel, and one for the attributes of these concepts.
+   For the fun of it, we sort the plugs on length, the longest first. Code:   sortWith ((0-).length.fields)
+   By the way, parameter allRels contains all relations that are declared in context, enriched with extra multiplicities.
+   This parameter allRels was added to makePlugs to avoid recomputation of the extra multiplicities.
+   The parameter exclusions was added in order to exclude certain concepts and relations from the process.
+-}
+-- | Generate non-binary sqlplugs for relations that are at least inj or uni, but not already in some user defined sqlplug
+makeEntityTables :: Options
+                -> A_Context
+                -> [Declaration] -- ^ all relations in scope
+                -> [A_Gen]
+                -> [[A_Concept]] -- ^ concepts `belonging' together.
+                                 --   for each class<-conceptss: c,c'<-class:   c `join` c' exists (although there is not necessarily a concept d=c `join` c'    ...)
+                -> [Declaration] -- ^ relations that should be excluded, because they wil not be implemented using generated sql plugs.
+                -> [PlugSQL]
+makeEntityTables opts context allDcls isas conceptss exclusions
+ = sortWith ((0-).length.plugFields)
+    (map kernel2Plug kernelsWithAttributes)
+   where
+    diagnostics
+      = "\nallDcls:" ++     concat ["\n  "++showHSName r           | r<-allDcls]++
+        "\nallDcls:" ++     concat ["\n  "++showHS opts "\n  " r  | r<-allDcls]++
+        "\nconceptss:" ++   concat ["\n  "++showHS opts "    " cs | cs<-conceptss]++
+        "\nexclusions:" ++  concat ["\n  "++showHSName r           | r<-exclusions]++
+        "\nattRels:" ++     concat ["\n  "++showHS opts "    " e  | e<-attRels]++
+        "\n"
+    -- | kernels are computed, starting with the set of concepts, on the basis of generalization tuples.
+    kernPartition :: [A_Gen] -> [[A_Concept]] -- ^ This function contains the recipe to derive a set of kernels from a set of isa-pairs.
+    kernPartition specialzs
+     = foldl f (group (delete ONE (concs context))) specialzs
+       where f disjuncLists g = concat haves : nohaves
+               where
+                 (haves,nohaves) = partition (not.null.intersect (concs g)) disjuncLists
+    preKernels = kernPartition (gens context) -- Step 1: compute the kernels from the isa-pairs from the context
+    extraIsas  -- Step 2: Maybe extra isa-pairs are needed to ensure that each kernel has precisely one largest concept
+       = concat
+         [ case [c | c<-kernel, null (largerConcepts isas c)] of -- determine how many concepts in one kernel are largest
+             [_] -> []
+             rs  -> [ Isa{gengen=rootConcept, genspc=c} | c<-rs ]
+         | (rootConcept,kernel) <- zip [rc | i<-[0::Int ..]
+                                           , let rc=PlainConcept { cptnm = "rootConcept"++show i
+                                                                 }
+                                           , rc `notElem` concs context ]
+                                       preKernels
+         ]
+    kernls     -- Step 3: compute the kernels
+     = [ largerCs++[ c | c<-kernel, c `notElem` largerCs ]              -- put the largest element up front
+       | kernel <- kernPartition (extraIsas++gens context)                -- recompute the kernels with the extra isa-pairs.
+       , let largerCs = [c | c<-kernel, null (largerConcepts isas c)]   -- get the set of largest concepts (each kernel has precisely one)
+       ]
+    kernelsWithAttributes = dist attRels kernls []
+      where
+        dist :: (Association attrib, Show attrib) => [attrib] -> [[A_Concept]] -> [([A_Concept], [attrib])] -> [([A_Concept], [attrib])]
+        dist []   []     result = result
+        dist atts []     _      = fatal 246 ("No kernel found for atts: "++show atts++"\n"++diagnostics)
+        dist atts (kernel:ks) result = dist otherAtts ks ([(kernel,attsOfK)] ++ result)
+           where (attsOfK,otherAtts) = partition belongsInK atts
+                 belongsInK att = source att `elem` kernel
+    -- | converts a kernel into a plug
+    kernel2Plug :: ([A_Concept],[Expression]) -> PlugSQL
+    kernel2Plug (kernel, attsAndIsaRels)
+     =  TblSQL
+             { sqlname = unquote . name . head $ kernel -- ++ " !!Let op: De ISA relaties zie ik hier nergens terug!! (TODO. HJO 20131201"
+             , fields  = map fld plugMors      -- Each field comes from a relation.
+             , cLkpTbl = conceptLookuptable
+             , mLkpTbl = attributeLookuptable ++ isaLookuptable
+             }
+        where
+          (isaAtts,atts) = partition isISA attsAndIsaRels
+            where isISA (EDcI _) = True
+                  isISA _        = False
+          mainkernel = map EDcI kernel
+          plugMors :: [Expression]
+          plugMors = mainkernel++atts
+          conceptLookuptable :: [(A_Concept,SqlField)]
+          conceptLookuptable    = [(target r,fld r) | r <-mainkernel]
+          attributeLookuptable :: [(Expression,SqlField,SqlField)]
+          attributeLookuptable  = -- kernel attributes are always surjective from left to right. So do not flip the lookup table!
+                                  [(e,lookupC (source e),fld e) | e <-plugMors]
+          lookupC cpt           = head [f |(c',f)<-conceptLookuptable, cpt==c']
+          fld a                 = rel2fld context mainkernel atts a
+          isaLookuptable = [(e,lookupC (source e),lookupC (target e)) | e <- isaAtts ]
+    -- attRels contains all relations that will be attribute of a kernel.
+    -- The type is the largest possible type, which is the declared type, because that contains all atoms (also the atoms of subtypes) needed in the operation.
+    attRels :: [Expression]
+    attRels = mapMaybe attExprOf (allDcls>- exclusions)
+     where
+       attExprOf :: Declaration -> Maybe Expression
+       attExprOf d =
+        case d of  --make explicit what happens with each possible decl...
+          Isn{} -> Nothing -- These relations are already in the kernel
+          Vs{}  -> Nothing -- Vs are not implemented at all
+          Sgn{} ->
+               case (isInj d, isUni d, isTot d, isSur d) of
+                    (False  , False  , _      , _      ) --Will become a link-table
+                        -> Nothing
+                    (True   , False  , _      , _      )
+                        -> Just $ flp (EDcD d)
+                    (True   , True   , True   , False  ) --Equivalent to CLASSIFY s ISA t, however, it is named, so it must be stored in a plug!
+                        -> Just $ flp (EDcD d)
+                    _   -> Just $      EDcD d
+
+-----------------------------------------
+--makeUserDefinedSqlPlug
+-----------------------------------------
+--makeUserDefinedSqlPlug is used to make user defined plugs. One advantage is that the field names and types can be controlled by the user.
+--
+--TODO151210 -> (see also Instance Object PlugSQL)
+--              cLkpTbl TblSQL{} can have more than one concept i.e. one for each kernel field
+--              a kernel may have more than one concept that is uni,tot,inj,sur with some imaginary ID of the plug (i.e. fldnull=False)
+--              When is an ObjectDef a ScalarPlug or BinPlug?
+--              When do you want to define your own Scalar or BinPlug
+--rel2fld  (identities context) kernel plugAtts r
+
+-- | Make a sqlplug from an ObjectDef (user-defined sql plug)
+makeUserDefinedSqlPlug :: A_Context -> ObjectDef -> PlugSQL
+makeUserDefinedSqlPlug context obj
+ | null(attributes obj) && isIdent(objctx obj)
+    = ScalarSQL { sqlname   = unquote . name $ obj
+                , sqlColumn = rel2fld context [EDcI c] [] (EDcI c)
+                , cLkp      = c
+                }
+ | null(attributes obj) --TODO151210 -> assuming objctx obj is Rel{} if it is not I{}
+   = fatal 2372 "TODO151210 -> implement defining binary plugs in ASCII"
+ | isIdent(objctx obj) --TODO151210 -> a kernel may have more than one concept that is uni,tot,inj,sur with some imaginary ID of the plug
+   = {- The following may be useful for debugging:
+     error
+      ("\nc: "++show c++
+       "\nrels:"++concat ["\n  "++show r | r<-rels]++
+       "\nkernel:"++concat ["\n  "++show r | r<-kernel]++
+       "\nattRels:"++concat ["\n  "++show e | e<-attRels]++
+       "\nplugfields:"++concat ["\n  "++show plugField | plugField<-plugfields]
+      ) -}
+     TblSQL { sqlname = unquote . name $ obj
+            , fields  = plugfields
+            , cLkpTbl = conceptLookuptable
+            , mLkpTbl = attributeLookuptable
+            }
+ | otherwise = fatal 279 "Implementation expects one concept for plug object (SQLPLUG tblX: I[Concept])."
+  where
+   c   -- one concept from the kernel is designated to "lead" this plug, this is user-defined.
+     = source(objctx obj)
+   rels --fields are user-defined as one deep objats with objctx=r. note: type incorrect or non-relation objats are ignored
+     = [(objctx att,sqltp att) | att<-attributes obj, source (objctx att)==c]
+   kernel --I[c] and every non-endo r or r~ which is at least uni,inj,sur are kernel fields
+          --REMARK -> endo r or r~ which are at least uni,inj,sur are inefficient in a way
+          --          if also TOT than r=I => duplicates,
+          --          otherwise if r would be implemented as GEN (target r) ISA C then (target r) could become a kernel field
+     = [(EDcI c,sqltp obj)]
+       ++ [(r,tp) |(r,tp)<-rels,not (isEndo r),isUni r, isInj r, isSur r]
+       ++ [(r,tp) |(r,tp)<-rels,not (isEndo r),isUni r, isInj r, isTot r, not (isSur r)]
+   attRels --all user-defined non-kernel fields are attributes of (rel2fld context (objctx c))
+     = (rels >- kernel) >- [(flp r,tp) |(r,tp)<-kernel] --note: r<-rels where r=objctx obj are ignored (objctx obj=I)
+   plugMors              = kernel++attRels
+   plugfields            = [fld r tp | (r,tp)<-plugMors]
+   fld r tp              = (rel2fld context (map fst kernel) (map fst attRels) r){fldtype=tp}  --redefine sqltype
+   conceptLookuptable    = [(target e,fld e tp) |(e,tp)<-kernel]
+   attributeLookuptable  = [(er,lookupC (source er),fld er tp) | (er,tp)<-plugMors]
+   lookupC cpt           = head [f |(c',f)<-conceptLookuptable, cpt==c']
+   sqltp :: ObjectDef -> SqlType
+   sqltp att = head $ [sqlTypeOf' sqltp' | strs<-objstrs att,('S':'Q':'L':'T':'Y':'P':'E':'=':sqltp')<-strs]
+                      ++[SQLVarchar 255]
+
+sqlTypeOf :: A_Context -> A_Concept -> SqlType
+sqlTypeOf _ ONE = SQLBool -- TODO (SJ):  Martijn, why should ONE have a representation? Or should this rather be a fatal?
+sqlTypeOf context c
+    = case nub [ cdtyp cdef | cdef<-ctxcds context, name c==name cdef ] of
+       [str] -> sqlTypeOf' str
+       []    -> sqlTypeOf' ""
+       _     -> fatal 396 ("Multiple SQL types defined for concept "++name c)
+
+sqlTypeOf' :: String -> SqlType
+sqlTypeOf' str = case str of
+       ('V':'a':'r':'c':'h':'a':'r':_) -> SQLVarchar 255 --TODO number
+       "Pass" -> SQLPass
+       ('C':'h':'a':'r':_) -> SQLChar 255 --TODO number
+       "Blob" -> SQLBlob
+       "Text" -> SQLText
+       "Single" -> SQLSingle
+       "Double" -> SQLDouble
+       ('u':'I':'n':'t':_) -> SQLuInt 4 --TODO number
+       ('s':'I':'n':'t':_) -> SQLsInt 4 --TODO number
+       "Id" -> SQLId
+       ('B':'o':'o':'l':_) -> SQLBool
+       "" -> SQLVarchar 255
+       _ -> fatal 335 ("Unknown type: "++str)

+ src/Database/Design/Ampersand/FSpec/ToFSpec/Calc.hs view
@@ -0,0 +1,834 @@+{-# LANGUAGE ScopedTypeVariables, OverloadedStrings #-}
+module Database.Design.Ampersand.FSpec.ToFSpec.Calc
+            ( deriveProofs
+            , showProof, showPrf, assembleECAs, conjuncts, genPAclause
+            , commaEngPandoc, commaNLPandoc, commaEngPandoc', commaNLPandoc'
+            , quadsOfRules
+          --  , testInterface
+            ) where
+
+import Database.Design.Ampersand.Basics
+import Data.List hiding (head)
+import Data.Monoid
+import GHC.Exts (sortWith)
+--import Data.ByteString.Char8
+--import Data.ByteString.Lazy.Char8
+import Database.Design.Ampersand.Core.AbstractSyntaxTree hiding (sortWith)
+import Database.Design.Ampersand.ADL1
+import Database.Design.Ampersand.ADL1.Expression
+import Database.Design.Ampersand.Classes
+import Database.Design.Ampersand.FSpec.FSpec
+import Database.Design.Ampersand.FSpec.ShowADL (ShowADL(..), showREL)
+import Database.Design.Ampersand.FSpec.ShowECA (showECA)
+import Database.Design.Ampersand.FSpec.ToFSpec.NormalForms
+import Database.Design.Ampersand.Misc (Lang(..),Options(..),PandocFormat(ReST),string2Blocks)
+import Text.Pandoc.Builder
+import Prelude hiding (head)
+
+fatal :: Int -> String -> a
+fatal = fatalMsg "FSpec.ToFSpec.Calc"
+
+head :: [a] -> a
+head [] = fatal 30 "head must not be used on an empty list!"
+head (a:_) = a
+
+-- testInterface :: FSpec -> Interface -> String
+-- Deze functie is bedoeld om te bedenken hoe interfaces moeten worden afgeleid uit een vers vertaalde ObjectDef.
+-- Nadat deze goed werkt kunnen de bewijsgenerator en de codegenerator worden gemaakt.
+--   testInterface :: FSpec -> Interface -> String
+--   testInterface fSpec ifc
+--    = "\nInterface "++ name ifc++"("++intercalate ", " [showADL r++":"++name (target r) | r<-rels]++")\n"++
+--      " - The parameters correspond to editable fields in a user interface.\n   "++
+--      showADL ifc++"\n"++
+--      " - Invariants:\n   "++intercalate "\n   " [showADL rule    | rule<-invs]++"\n"++
+--      " - Derivation of clauses for ECA-rules:"   ++
+--      concat [showClause fSpec (makeCjcts (getOpts fSpec) rule) | rule<-invs]++"\n"++
+--{-
+--      " - ECA rules:"++concat  [ "\n\n     "++showECA "\n     "  (eca{ecaAction=normPA (getOpts fSpec) (ecaAction eca)})
+--                                 ++"\n------ Derivation ----->"++showProof (codeBlock . ("\n     "++) . showECA "\n     ") (proofPA (getOpts fSpec) (ecaAction eca))++"\n<------End Derivation --"
+--                               | eca<-ecaRs]++"\n\n"++
+---}
+--      " - Visible relations:\n   "++intercalate "\n   " (spread 80 ", " [showADL r  | r<-vis])++"\n"
+--    where
+----        showQ i (rel, shs,conj,r)
+----         = "\nQuad "++show i++":\nrelation: "++showADL rel++":\nshifts: "++concat ["\n"++showADLe s |s<-shs]++"\nconjunct: "++showADL conj++"\nrule: "++showADL r++""
+----TODO: Deze code komt ook voor in ADL2FSpec.hs. Dat lijkt dubbelop, en derhalve niet goed.
+--        rels = nub (recur (ifcObj ifc))
+--         where recur obj = [editMph (objctx o) | o<-attributes obj, editable (objctx o)]++[r | o<-attributes obj, r<-recur o]
+--        vis        = nub (rels++map (I . target) rels)
+--   --     visible r  = r `elem` vis
+--        invs       = [rule | rule<-invariants fSpec, (not.null) (map makeDeclaration (relsUsedIn rule) `isc` vis)]
+--   --     qs         = vquads fSpec
+--   --     (ecaRs, _) = assembleECAs fSpec (allDecls fSpec)
+----        editable (ERel Rel{} _)  = True    --WHY?? Stef, welke functie is de juiste?? TODO deze functie staat ook in ADL2FSpec.hs, maar is daar ANDERS(!)...
+----        editable _               = False
+----        editMph (ERel r@Rel{} _) = r       --WHY?? Stef, welke functie is de juiste?? TODO deze functie staat ook in ADL2FSpec.hs, maar is daar ANDERS(!)...
+----        editMph e                = fatal 64 $ "cannot determine an editable declaration in a composite expression: "++show e
+--        -- De functie spread verspreidt strings over kolommen met een breedte van n.
+--        -- Deze functie garandeert dat alle strings worden afgedrukt in de aangegeven volgorde.
+--        -- Hij probeert daarbij zo weinig mogelijk regels te gebruiken,
+--        -- en alleen de grens van n te overschrijden als een string zelf langer is dan n.
+--        spread :: Int -> String -> [String] -> [String]
+--        spread n str = f ""
+--         where f stored []       = [stored | not (null stored)]
+--               f [] (cs:css)     = f cs css
+--               f stored (cs:css) | length stored > n = stored: f cs css
+--                                 | length new   <= n = f new css
+--                                 | otherwise         = stored: f cs css
+--                                   where new = stored++str++cs
+testConfluence :: A_Context -> Blocks
+testConfluence context
+ = let tcss = [(expr,tcs) | expr<-expressionsIn context, let tcs=dfProofs expr, length tcs>1]
+       sumt = sum (map (length.snd) tcss)
+   in
+   para ("Confluence analysis statistics from "<>(str.show.length.expressionsIn) context<>" expressions."<>linebreak)<>
+   para ("This script contains "<>linebreak<>(str.show.length) tcss<> " non-confluent expressions "<>linebreak)<>
+   para (linebreak<>"Total number of derived expressions: "<>(str.show) sumt<>linebreak)<>
+   para ("Confluence analysis for "<>(str.name) context)<>
+   mconcat
+     [ para (linebreak<>"expression:   "<>(str . showADL) expr<>linebreak)<>
+       bulletList [ showProof (para.str.showADL) prf | (_,prf)<-tcs ]
+     | (expr,tcs)<-tcss]
+
+deriveProofs :: Options -> A_Context -> Blocks
+deriveProofs opts context
+ = testConfluence context<>
+   para (linebreak<>"--------------"<>linebreak)<>
+   para ("Rules and their conjuncts for "<>(str.name) context)<>
+   bulletList [ para ("rule r:   "<>str (showADL r)<>linebreak<>
+                      "rrexp r:  "<>str (showADL (rrexp r))<>linebreak<>
+                      "conjNF:   "<>str (showADL (conjNF opts (rrexp r)))<>linebreak<>
+                      interText linebreak [ "     conj: "<>str (showADL conj) | conj<-conjuncts opts r ]
+                     )
+              | r<-allRules context]<>
+   para ("Transformation of user specified rules into ECA rules for "<>(str.name) context)<>
+   para (linebreak<>"--------------"<>linebreak<>"First step: determine the "<>(str.show.length) quads<>" quads:")<>
+   bulletList [ para ( "-- quad ------------"<>linebreak<>"When relation "<>(str . showADL . qDcl) q<>" is changed,"
+                       <>linebreak<>(str . showADL . qRule) q
+                       <>(if (length . qConjuncts) q<=1 then space else " ("<>(str . show . length . qConjuncts) q<>" conjuncts)")
+                       <>" must be restored."<>linebreak<>"This quad has conjunct: "<>(str . showADL . rc_conjunct) x
+                       <>" and "<>(str.show.length.rc_dnfClauses) x<>" dnf clauses."
+                     ) <>
+                bulletList [ para (linebreak<>"Dnf clause "<>str (showADL dc)) | dc<-rc_dnfClauses x]
+              | q<-quads, x<-qConjuncts q ] <>
+   para (linebreak<>linebreak<>"Second step: assemble dnf clauses.") <>
+   bulletList [ para ( "Dnf clause "<>str (showADL dc)
+                       <>linebreak<>"is derived from rule "<>str (showADL r)
+                       <>linebreak
+                       <>case ms of
+                            []    -> "No relations affect this clause."
+                            [rel] -> "It can be called when relation " <>str (showADL rel)<>" is affected."
+                            _     -> "It can be called when relations "<>str (commaEng "or" [showADL rel | rel<-ms])<>" are affected."
+                     )
+              | (ms,dc,r)<-
+                    [ (nub [ dcl |(dcl,_,_)<-cl],dc,r)
+                    | cl<-eqCl (\(_,_,dc)->dc) [(qDcl q,dc,qRule q) |q<-quads, x<-qConjuncts q, dc<-rc_dnfClauses x]
+                    , let (_,dc,r) = head cl
+                    ]
+              ]<>
+   para (linebreak<>"Third step: determine "<>(str.show.length.udefrules) context<>" ECA rules"<>
+         if verboseP opts
+          then " (Turn --verbose off if you want to see ECA rules only)"
+          else " (Turn on --verbose if you want to see more detail)"
+        )<>
+   ( if verboseP opts then para ( "--------------"<>linebreak)<>bulletList derivations else fromList [] )<>
+   bulletList [ para ( "-- ECA Rule "<>(str.show.ecaNum) ecarule<>" ---------")<>
+                codeBlock ("\n  "++showECA "\n  " ecarule{ecaAction=normPA opts (ecaAction ecarule)})<>
+                bulletList [ para (linebreak<>"delta expression"<>linebreak<>space<>str (showADL d)
+                                   <>linebreak<>"derivation:"
+                                  )<>
+                             (showProof (para.str.showADL).dfProof opts) d<>  -- Produces its result in disjunctive normal form
+                             para ("disjunctly normalized delta expression"<>linebreak<>(str.showADL.disjNF opts) d)
+                           | verboseP opts, e@Do{}<-[ecaAction ecarule], let d = paDelta e ]
+              | ecarule <- ecaRs]
+{-
+      ++
+      [ linebreak<>"--------------", linebreak, linebreak<>"Fourth step: cascade blocking rules"
+      , linebreak
+      ]++
+      interText []
+        [ [linebreak<>"-- Raw ECA rule "<>(str.show.ecaNum) er<>"------------"<>linebreak<>str (showECA "\n  " er)]
+        | er<- ecaRs]
+      ++
+      [ linebreak<>"--------------", linebreak, linebreak<>"Fifth step: preEmpt the rules (= optimize)"
+      , linebreak
+      ]++
+{- TODO: readdress preEmpt. It is wrong
+      interText []
+        [ [linebreak<>"-- Preempted ECA rule "<>(str.show.ecaNum) er<>"------------"<>linebreak<>str (showECA "\n  " er)]
+        | er<- preEmpt opts ecaRs]
+      ++ -}
+{-
+      [ linebreak<>"--------------", linebreak]
+      ++ -- TODO: make an ontological analysis, which explains the delete behaviour.
+      [ Str "Ontological analysis: ", linebreak<>"  "]
+      ++
+      interText [linebreak, linebreak<>"  "]
+          [ [Str (name ifc)<>"("]
+            ++ interText ", "
+                 [str (name a)<>"["<>(str.name.target.ctx) a<>"]"
+                 |a<-attributes (ifcObj ifc)]
+            ++ [Str "):", linebreak<>"  "]
+          | ifc<-interfaceS fSpec]
+      ++
+      [ linebreak<>"--------------", linebreak
+      <>"Analyzing interfaces:", linebreak<>"     "]
+      ++
+      interText [linebreak<>"     "]
+         [[Str (testInterface fSpec ifc)]
+         | ifc<-take 1 (interfaceG fSpec)]
+      ++
+      [ linebreak<>"--------------", linebreak]
+      -}
+-}
+   where
+--    visible _  = True -- We take all quads into account.
+    quads  = quadsOfRules opts (allRules context) -- the quads that are derived for this fSpec specify dnf clauses, meant to maintain rule r, to be called when relation rel is affected (rel is in r).
+--    interText :: (Data.String.IsString a, Data.Monoid.Monoid a) => a -> [a] -> a
+    interText _ [] = ""
+    interText inbetween (xs:xss) = xs<>inbetween<>interText inbetween xss
+    derivations :: [Blocks]
+    ecaRs :: [ECArule]
+    (ecaRs, derivations) = assembleECAs opts context (relsDefdIn context)
+{-
+           [ str ("Available code fragments on rule "<>name rule<>":", linebreak ]<>
+           interText [linebreak] [showADL rule<> " yields\n"<>interText "\n\n"
+                                   [ ["event = ", str (show ev), space, str (showADL rel), linebreak ] <>
+                                     [str (showADL r<>"["<>showADL rel<>":="<>showADL (actSem opts ev (EDcD rel) (delta (sign rel)))<>"] = r'"), linebreak ] <>
+                                     ["r'    = "] <> conjProof r' <> [linebreak ] <>
+                                     ["viols = r'-"] <> disjProof (ECpl r') <> [ linebreak ] <>
+                                     "violations, considering that the valuation of "<>showADL rel<>" has just been changed to "<>showADL (actSem opts ev (EDcD rel) (delta (sign rel)))<>
+                                     "            "<>conjProof (ECpl r) <>"\n"<>
+                                     "reaction? evaluate r |- r' ("<>(str.showADL.conjNF opts) (notCpl r .\/. r')<>")"<>
+                                        conjProof (notCpl r .\/. r')<>"\n"<>
+                                     "delta: r-/\\r' = "<>conjProof (EIsc[notCpl r,r'])<>
+                                     "\nNow compute a reaction\n(isTrue.conjNF opts) (notCpl r .\/. r') = "<>show ((isTrue.conjNF opts) (notCpl r .\/. r'))<>"\n"<>
+                                     (if null (lambda ev (ERel rel ) r)
+                                      then "lambda "<>showADL rel<>" ("<>showADL r<>") = empty\n"
+                                      else -- for debug purposes:
+                                           -- "lambda "<>show ev<>" "<>showADL rel<>" ("<>showADL r<>") = \n"<>(interText "\n\n".map showPr.lambda ev (ERel rel)) r<>"\n"<>
+                                           -- "derivMono ("<>showADL r<>") "<>show ev<>" "<>showADL rel<>"\n = "<>({-interText "\n". map -}showPr.derivMono r ev) rel<>"\n"<>
+                                           -- "\nNow compute checkMono opts r ev rel = \n"<>show (checkMono opts r ev rel)<>"\n"<>
+                                           if (isTrue.conjNF opts) (notCpl r .\/. r')
+                                           then "A reaction is not required, because  r |- r'. Proof:"<>conjProof (notCpl r .\/. r')<>"\n"
+                                           else if checkMono opts r ev rel
+                                           then "A reaction is not required, because  r |- r'. Proof:"{-<>(str.showPr.derivMono r ev) rel-}<>"NIET TYPECORRECT: (showPr.derivMono r ev) rel"<>"\n"  --WHY? Stef, gaarne herstellen...Deze fout vond ik nadat ik het type van showProof had opgegeven.
+                                           else let ERel _ _ = delta (sign rel) in
+                                                "An appropriate reaction on this event is required."
+                                           --     showECA "\n  " (ECA (On ev rel) delt (genPAclause visible Ins r viols conj [rule]) 0)
+                                     )
+                                   | rel<-relsUsedIn r   -- nub [x |x<-relsUsedIn r, not (isIdent x)] -- TODO: include proofs that allow: isIdent rel'
+                                   , ev<-[Ins,Del]
+                                   , r'<-[subst (rel, actSem opts ev (EDcD rel) (delta (sign rel))) r]
+                        --        , viols<-[conjNF opts (ECpl r')]
+                                   , True ]  -- (isTrue.conjNF opts) (notCpl r .\/. r')
+                                  | r<-[dc | cs<-[makeCjcts opts rule], (_,dnfClauses)<-cs, dc<-dnfClauses]
+                                  ]
+           where e = rrexp rule
+                 prf = cfProof (getOpts fSpec) e
+                 (exx',_,_) = last prf
+            --     conjProof = showProof (para.str.showADL) . cfProof (getOpts fSpec)
+                 disjProof = showProof (para.str.showADL) . dfProof (getOpts fSpec)
+--                 showPr    = showProof (para.str.showADL)  -- hoort bij de uitgecommentaarde code hierboven...
+       --TODO: See ticket #105
+-}
+
+-- Stel we voeren een actie a uit, die een(1) van de volgende twee is:
+--        {r} INS rel INTO expr {r'}       ofwel
+--        {r} DEL rel FROM expr {r'}
+-- Dan toetst checkMono of r|-r' waar is op grond van de afleiding uit derivMono.
+-- Als dat waar is, betekent dat dat invariant r waar blijft wanneer actie a wordt uitgevoerd.
+checkMono :: Options
+          -> Expression
+          -> InsDel
+          -> Declaration
+          -> Bool
+checkMono opts expr ev dcl
+  = case ruleType conclusion of
+     Truth -> fatal 247 "derivMono came up with a Truth!"
+     _     -> simplify expr == simplify (antecedent conclusion) &&
+              simplify (subst (dcl, actSem opts ev (EDcD dcl) (delta (sign dcl))) expr) ==
+              simplify (consequent conclusion)
+  where (conclusion,_,_) = last (derivMono expr ev dcl)
+
+type Proof expr = [(expr,[String],String)]
+reversePrf :: Proof e -> Proof e
+reversePrf [] = []
+reversePrf [s] = [s]
+reversePrf ((r,cs,e'):prf@((r',_ ,_):_)) = init rp++[(r',cs,rev e'),(r,[],"")]
+  where rp = reversePrf prf
+        rev "==>" = "<=="
+        rev "<==" = "==>"
+        rev "-->" = "<--"
+        rev "<--" = "-->"
+        rev x = x
+
+showProof :: (expr->Blocks) -> Proof expr -> Blocks
+showProof shw [(expr,ss,_)]       = shw expr<> para ( str(" { "++intercalate " and " ss++" }"))
+showProof shw ((expr,ss,equ):prf) = shw expr<>
+                                    para (if null ss  then str equ else
+                                          if null equ then str (unwords ss) else
+                                          str equ<>str (" { "++intercalate " and " ss++" }"))<>
+                                    showProof shw prf
+                                    --where e'= if null prf then "" else let (expr,_,_):_ = prf in showHS options "" expr
+showProof _  []                   = fromList []
+
+showPrf :: (expr->String) -> Proof expr -> [String]
+showPrf shw [(expr,_ ,_)]       = [ "    "++shw expr]
+showPrf shw ((expr,ss,equ):prf) = [ "    "++shw expr] ++
+                                  (if null ss  then [ equ ] else
+                                   if null equ then [ unwords ss ] else
+                                   [ equ++" { "++intercalate " and " ss++" }" ])++
+                                  showPrf shw prf
+showPrf _  []                   = []
+
+-- derivMono provides a derivation to prove that (precondition) r is a subset of (postcondition) r'.
+-- This is useful in proving that an action {expr} a {expr'} maintains its invariant, i.e. that  expr|-expr'  holds (proven by monotony properties)
+-- Derivmono gives a derivation only.
+derivMono :: Expression -> InsDel -> Declaration -> [(Rule, [String], String)]
+derivMono expr -- preconditie van actie a
+          tOp  -- de actie (Ins of Del)
+          dcl' -- re relatie, zodat de actie bestaat uit INSERT rel' INTO expr of DELETE rel' FROM expr
+ = f (head (lambda tOp (EDcD dcl') expr++[[]])) (start tOp)
+ where
+  f :: [(Expression, [String], whatever)]
+     -> (Expression, Expression)
+     -> [(Rule, [String], String)]
+  f [] (_,_) = []
+  f [(e',_,_)] (neg',pos')
+   = [(rule (subst (dcl',neg') e') (subst (dcl',pos') e'),[],"")]
+  f ((e',["invert"],_): prf@((_,_,_):_)) (neg',pos')
+   = (rule (subst (dcl',neg') e') (subst (dcl',pos') e'),["r |- s  <=>  s- |- r-"],"<=>"):
+      f prf (pos',neg')
+  f ((e1,_,_): prf@((e2,_,_):_)) (neg',pos')
+   = (rule (subst (dcl',neg') e1) (subst (dcl',pos') e1),["Monotony of "++showOp e2],"==>"):
+      f prf (neg',pos')
+
+  start Ins  = (EDcD dcl',EDcD dcl' .\/. delta (sign dcl'))
+  start Del  = (EDcD dcl' ./\. notCpl (delta (sign dcl')),EDcD dcl')
+
+  rule :: Expression -> Expression -> Rule
+  rule neg' pos' | isTrue neg' = Ru { rrnm  = ""
+                                    , rrfps = Origin "rule generated for isTrue neg' by Calc"
+                                    , rrexp = pos'
+                                    , rrmean = AMeaning
+                                               [A_Markup Dutch   ReST (string2Blocks ReST "Waarom wordt deze regel hier aangemaakt? (In Calc.hs, regel 402)")
+                                               ,A_Markup English ReST (string2Blocks ReST "Why is this rule created? (In Calc.hs, line 403)")]  --TODO Stef, gaarne de explanations aanvullen/verwijderen. Dank! Han.
+                                    , rrmsg = []
+                                    , rrviol = Nothing
+                                    , rrtyp = sign neg' {- (neg `meet` pos) -}
+                                    , rrdcl = Nothing
+                                    , r_env = ""
+                                    , r_usr = Multiplicity
+                                    , isSignal = fatal 336 $ "erroneous reference to isSignal in rule ("++showADL neg'++") |- ("++showADL pos'++")"
+                                    }
+                 | otherwise   = Ru { rrnm  = ""
+                                    , rrfps = Origin "rule generated for not(isTrue neg') by Calc"
+                                    , rrexp = neg' .|-. pos'
+                                    , rrmean = AMeaning
+                                               [A_Markup Dutch   ReST (string2Blocks ReST "Waarom wordt deze regel hier aangemaakt? (In Calc.hs, regel 332)")
+                                               ,A_Markup English ReST (string2Blocks ReST "Why is this rule created? (In Calc.hs, line 333)")]  --TODO Stef, gaarne de explanations aanvullen/verwijderen. Dank! Han.
+                                    , rrmsg = []
+                                    , rrviol = Nothing
+                                    , rrtyp = sign neg' {- (neg `meet` pos) -}
+                                    , rrdcl = Nothing
+                                    , r_env = ""
+                                    , r_usr = Multiplicity
+                                    , isSignal = fatal 352 $ "illegal reference to isSignal in rule ("++showADL neg'++") |- ("++showADL pos'++")"
+                                    }
+  showOp expr' = case expr' of
+                  EEqu{} -> "="
+                  EImp{} -> "|-"
+                  EIsc{} -> "/\\"
+                  EUni{} -> "\\/"
+                  EDif{} -> "-"
+                  ELrs{} -> "/"
+                  ERrs{} -> "\\"
+                  EDia{} -> "<>"
+                  ECps{} -> ";"
+                  ERad{} -> "!"
+                  EPrd{} -> "*"
+                  EKl0{} -> "*"
+                  EKl1{} -> "+"
+                  EFlp{} -> "~"
+                  ECpl{} -> "-"
+                  _      -> ""
+
+{- The purpose of function lambda is to generate a derivation.
+Rewrite rules:
+-r;-s -> -(r!s)
+-}
+lambda :: InsDel -> Expression
+                 -> Expression
+                 -> [Proof Expression]
+lambda tOp' e' expr' = [reversePrf[(e'',txt,op)
+                       | (e'',_,txt,op)<-prf]
+                       | prf<-lam tOp' e' expr' ]
+ where
+  lam :: InsDel -> Expression -> Expression ->
+         [[(Expression,Expression -> Expression,[String],String)]]
+  lam tOp e3 expr =
+       case expr of
+          EIsc{}  | e3==expr             -> [[(e3,id,[],"")]]
+                  | length (const' expr)>0 -> [(expr,\_->expr,      [derivtext tOp "mono" (inter' expr) expr],"<--") :prf
+                                              | prf<-lam tOp e3 (inter' expr)
+                                              ]
+                  | and [isNeg f |f<-exprIsc2list expr]
+                                         -> let deMrg = deMorganEIsc expr in
+                                            [(expr, deMorganEIsc, [derivtext tOp "equal" deMrg expr],"==") :prf | prf<-lam tOp e3 deMrg]
+                  | or[null p |p<-fPrfs] -> []
+                  | otherwise            -> [(expr,\_->expr,    [derivtext tOp "mono" (first lc) expr],"<--") : lc]
+          EUni{}  | e3==expr             -> [[(e3,id,[],"")]]
+                  | length (const' expr)>0 -> [(expr,\_->expr, [derivtext tOp "mono" (inter' expr) expr],"<--") :prf
+                                                   | prf<-lam tOp e3 (inter' expr)
+                                                   ]
+                  | and [isNeg f |f<-exprUni2list expr]
+                                         -> let deMrg = deMorganEUni expr in
+                                            [(expr, deMorganEUni, [derivtext tOp "equal" deMrg expr],"==") :prf | prf<-lam tOp e3 deMrg]
+                  | or[null p |p<-fPrfs] -> []
+                  | otherwise            -> [(expr,\_->expr,    [derivtext tOp "mono" (first lc) expr],"<--") : lc]
+          ECps{}  | e3==expr             -> [[(e3,id,[],"")]]
+                  | and [isNeg f |f<-exprCps2list expr]
+                                         -> let deMrg = deMorganECps expr in
+                                            [(expr, deMorganECps, [derivtext tOp "equal" deMrg expr],"==")
+                                            :prf
+                                            | prf<-lam tOp e3 deMrg
+                                            ] -- isNeg is nog niet helemaal correct.
+                  | or[null p|p<-fPrfs]  -> []
+                  | otherwise            -> [(expr,\_->expr,    [derivtext tOp "mono" (first lc) expr],"<--"): lc]
+          ERad{}  | e3==expr             -> [[(e3,id,[],"")]]
+                  | and [isNeg f |f<-exprRad2list expr]
+                                         -> let deMrg = deMorganERad expr in
+                                            [(expr, deMorganERad, [derivtext tOp "equal" deMrg expr],"==") :prf | prf<-lam tOp e3 deMrg] -- isNeg is nog niet helemaal correct.
+                  | or[null p |p<-fPrfs] -> []
+                  | otherwise            -> [(expr,\_->expr,    [derivtext tOp "mono" (first lc) expr],"<--"): lc]
+          EKl0 x                         -> [(expr,\e->EKl0 e,[derivtext tOp "mono" x expr],"<--") :prf   | prf<-lam tOp e3 x]
+          EKl1 x                         -> [(expr,\e->EKl1 e,[derivtext tOp "mono" x expr],"<--") :prf   | prf<-lam tOp e3 x]
+          ECpl x                         -> [(expr,\e->ECpl e,["invert"],"<--") :prf | prf<-lam (inv tOp) e3 x]
+          EBrk x                         -> lam tOp e3 x
+          _                              -> [[(e3,id,[],"")]]
+        where
+            sgn   = sign expr
+            fPrfs = case expr of
+                     EUni{} -> [lam tOp e3 f |f<-exprUni2list expr, isVar f e3]
+                     EIsc{} -> [lam tOp e3 f |f<-exprIsc2list expr, isVar f e3]
+                     ECps{} -> [lam tOp e3 f |f<-exprCps2list expr, isVar f e3]
+                     ERad{} -> [lam tOp e3 f |f<-exprRad2list expr, isVar f e3]
+                     _      -> fatal 428 ("fPrfs  is not defined.Consult your dealer!")
+            lc = longstcomn vars++concat (drop (length rc-1) (sortWith length rc))
+            rc = remainders vars vars
+            vars = map head fPrfs
+            const' e@EUni{} = [f |f<-exprUni2list e, isConst f e3]
+            const' e@EIsc{} = [f |f<-exprIsc2list e, isConst f e3]
+            const' expr'' = fatal 440 $ "'const'("++ show expr''++")' is not defined.Consult your dealer!"
+            inter' e@EUni{} = foldr (.\/.) (notCpl (EDcV sgn)) [f |f<-exprUni2list e, isVar f e3]
+            inter' e@EIsc{} = if and [sgn==sign f | f<-exprIsc2list e, isVar f e3]
+                              then foldr (./\.) (EDcV sgn) [f | f<-exprIsc2list e, isVar f e3]
+                              else fatal 532 ("signature error in inter'  "++show [(showADL f,showSign (sign f)) | f<-exprIsc2list e, isVar f e3])
+            inter' expr'' = fatal 443 $ "'inter'("++ show expr''++")' is not defined.Consult your dealer!"
+--      lam tOp e f       = []
+
+-- longstcomn determines the longest prefix common to all xs in xss.
+  longstcomn :: (Eq a) => [[(a, b, c, d)]] -> [(a, b, c, d)]
+  longstcomn xss | or [null xs | xs<-xss]      = []
+                 | length (eqCl first xss)==1 = head [head prf | prf<-xss]: longstcomn [tail prf | prf<-xss]
+                 | otherwise                  = []
+ -- remainders determines the remainders.
+  remainders :: (Eq a) => [[(a, b, c, d)]] -> [[(a, b, c, d)]] -> [[(a, b, c, d)]]
+  remainders _ xss | or [null xs | xs<-xss]      = xss
+                   | length (eqCl first xss)==1 = remainders xss [tail prf | prf<-xss]
+                   | otherwise                  = xss
+  isConst :: (ConceptStructure a, ConceptStructure b) => a->b->Bool
+  isConst e f = null (relsUsedIn e `isc` relsUsedIn f)
+  isVar :: (ConceptStructure a, ConceptStructure b) => a->b->Bool
+  isVar e f   = not (isConst e f)
+  derivtext :: InsDel -> String -> Expression -> Expression -> String
+  derivtext tOp "invert" e'' expr = sh tOp++showADL e''++" means "++sh (inv tOp)++showADL expr++"."
+  derivtext tOp "mono"    e'' expr = "("++showADL e''++"->"++showADL expr++") is monotonous, so "++sh tOp++showADL e''++" means "++sh tOp++showADL expr++"."
+  derivtext _ txt _ _ = txt
+  sh :: InsDel -> String
+  sh Ins  = "insert into "
+  sh Del  = "delete from "
+  inv :: InsDel -> InsDel
+  inv Ins = Del
+  inv Del = Ins
+  first :: [(a,b,c,d)] -> a
+  first ((e'',_,_,_):_) = e''
+  first _ = fatal 472 "wrong pattern in first"
+
+ruleType :: Rule -> RuleType
+ruleType r = case rrexp r of
+              EEqu{} -> Equivalence
+              EImp{} -> Implication
+              _      -> Truth
+
+-- | Action semantics for inserting a delta into a relation dcl.
+actSem :: Options -> InsDel -> Expression -> Expression -> Expression
+actSem opts Ins dcl delt | sign dcl/=sign delt = fatal 598 "Type error in actSem Ins"
+                         | dcl==delt           = dcl
+                         | otherwise           = disjNF opts (dcl .\/. delt)
+actSem opts Del dcl delt | sign dcl/=sign delt = fatal 598 "Type error in actSem Del"
+                         | dcl==delt           = notCpl (EDcV (sign dcl))
+                         | otherwise           = conjNF opts (dcl ./\. notCpl delt)
+
+-- | assembleECAs  assembles larger chunks of code, because it combines acts that are triggered by the same event.
+assembleECAs :: Options -> A_Context -> [Declaration] -> ([ECArule],[Blocks])
+assembleECAs options context editables
+ = unzip [eca i | (eca,i) <- zip ecas [(1::Int)..]]
+   where
+    ecas :: [Int->(ECArule,Blocks)]
+    ecas
+      = [ (\ruleNr->( ECA ecaEvt delt normEcaAct ruleNr
+                    , para ("Let us analyse what happens "<>str (show (On ev rel))<>".")<>
+                      bulletList [ txt | (_,_,_,txt)<-acts]<>
+                      ( if length ecaProof>1
+                        then para ("The resulting action is:\n     ")<>
+                             showProof (codeBlock . ("\n     "++) . showECA "\n     ") ecaProof
+                        else fromList []
+                      )<>
+                      para ("These results lead to the following ECA-rule:\n     ")<>
+                      (codeBlock . ("\n     "++) . showECA "\n     ".ecaRule) ruleNr
+                    )
+          )
+        | rel <- editables -- allDecls fSpec ++ [ Isn c | c<-allConcepts fSpec, c/=ONE] -- This is the relation in which a delta is being inserted or deleted.
+ --       , let relEq = [ q | q<-vquads fSpec, qDcl q==rel] -- Gather the quads with the same declaration (qDcl). A quad has a declaration (qDcl), a rule (qRule) and clauses qConjuncts
+        , let EDcD delt = delta (sign rel)                -- delt is a placeholder for the pairs that have been inserted or deleted in rel.
+        , ev<-[Ins,Del]
+        , let acts = [ -- go through all the events that affect that clause:
+                       ( normPA options act   -- a normalized action for this event-conjunct combination
+                       , conjunct             -- the conjunct
+                       , map snd conjEqClass  -- the rule-expression of which conjunct is a part
+                       , para ("Let us analyse clause "<>str (showADL expr)<>" from rule "<>commaEngPandoc' "and" (map (singleQuoted.str.name.snd) conjEqClass)<>".")<>
+                         para ("event = "<>str (show ev)<>space<>str (showREL rel)<>" means doing the following substitution")<>
+                         para (str (showADL clause<>"["<>showREL rel<>":="<>showADL (actSem options ev (EDcD rel) (delta (sign rel)))<>"] = clause'"))<>
+                         para ("clause' = "<>str (showADL ex')<>
+                               if clause'==ex'
+                               then ", which is already in conjunctive normal form."<>linebreak
+                               else ", which has conjunctive normal form: "<>linebreak<>str (showADL clause')
+                              )<>
+                         para ("Let us compute the violations to see whether invariance is maintained."<>linebreak<>
+                               "This means to negate the result (notClau = notCpl clause'): ")<>
+                         (showProof (para.str.showADL). cfProof options) notClau<>
+                         para ("So, notClau has CNF: "<>str (showADL viols )<>linebreak<>
+                               ( if viols==viols'
+                                 then "This expression is in disjunctive normal form as well."
+                                 else str ("In DNF, notClau is:  "<>showADL viols'<>".")))<>
+                         ( if isTrue clause'
+                           then para ("This result proves the absence of violations, so a reaction of doing nothing is appropriate."<>linebreak
+                                      <>"Just for fun, let us try to derive whether clause |- clause' is true... ")<>
+                                (showProof (para.str.showADL). cfProof options) (expr .|-. clause')
+                           else para ("This result does not prove the absence of violations, so we cannot conclude that invariance is maintained."<>linebreak<>
+                                      "We must compute a reaction to compensate for violations..."<>linebreak<>
+                                      "That would be to reinsert violations that originate from "<>
+                                      ( if ev==Ins
+                                        then str (showADL (conjNF options negs))<>" into "<> str (showADL (disjNF options poss))<>"."
+                                        else str (showADL (disjNF options poss))<>" into "<> str (showADL (conjNF options negs))<>"."
+                                      )<>linebreak<>"deltFr: ")<>
+                                (showProof (para.str.showADL). dfProof options) deltFr<>
+                                ( let pr=proofPA options act in
+                                  if length pr>1
+                                  then para "Now let us remove redundancy from the ECA action:\n     "<>
+                                       showProof (codeBlock . ("\n     "++) . showECA "\n     ") (proofPA options act)
+                                  else fromList []
+                                )
+                         {-     <> "To finish the analysis of case "<>str (show ev)<>space<>str (showADL rel)
+                                   <>", let us compute the contents of "<>str (showADL toExpr)<>" after insertion of viols."<>linebreak
+                                   <>
+                                ( if length (nub [sign viols, sign viols', sign toExpr])>1
+                                  then fatal 248 ("viols"<>showSign (sign viols) <>"   "<>showADL viols <>"\n"<>
+                                                  "viols'"<>showSign (sign viols')<>"  "<>showADL viols'<>"\n"<>
+                                                  "toExpr"<>showSign (sign toExpr)<>"  "<>showADL toExpr)
+                                  else if ev==Ins
+                                  then (showProof (para.str.showADL). cfProof options) (viols'.\/.toExpr)<>linebreak
+                                  else (showProof (para.str.showADL). dfProof options) (notCpl viols./\.toExpr)<>linebreak
+                                ) -}
+                         )
+                       )
+                     | conjEqClass <- [] -- TODO: implement this once we can test it (note: computing eq. class is no longer necessary)
+                    -- conjEqClass <- eqCl fst [ (qConjuncts q, qRule q) | q<-relEq ]
+                     , conjunct <- (fst.head) conjEqClass                  -- get conjuncts from the clauses
+                     , clause <- rc_dnfClauses conjunct  -- the DNF form of each clause
+                     , let expr    = dnf2expr clause                       -- Note that this differs from:  rc_conjunct conjunct, because the type may be different.
+                     , let vee     = EDcV (sign expr)
+                     , let ex'     = subst (rel, actSem options ev (EDcD rel) (delta (sign rel))) expr -- the clause after the edit action
+                     , let clause' = conjNF options ex'                                                -- its CNF
+                     , not (isTrue clause')
+                     , let notClau = notCpl clause'                                            -- the violations after the edit action
+                     , let viols   = conjNF options notClau                                            -- the violations after the edit action
+                     , let viols'  = disjNF options notClau                                            -- the violations after the edit action
+                     , let negs    = if (length.nub.map sign) (vee:antcs clause)>1
+                                     then fatal 265 ("type inconsistencies in antcs: "++show (map showADL (vee:antcs clause)))
+                                     else foldr (./\.) vee (antcs clause)
+                     , let poss    = if (length.nub.map sign) (vee:conss clause)>1
+                                     then fatal 265 ("type inconsistencies in conss: "++show (map showADL (vee:conss clause)))
+                                     else foldr (.\/.) (notCpl vee) (conss clause)
+                     , let frExpr  = case ev of
+                                      Ins -> disjNF options (notCpl negs)
+                                      Del -> disjNF options poss
+                     , let deltFr  = if sign poss/=sign negs
+                                     then fatal 274 ("type inconsistencies in deltFr: "++showADL clause)
+                                     else if ev==Ins
+                                     then (subst (rel, actSem options ev (EDcD rel) (delta (sign rel)))) negs ./\. notCpl poss
+                                     else (notCpl . subst (rel, actSem options ev (EDcD rel) (delta (sign rel)))) poss ./\. negs
+                     , let deltFr' = disjNF options deltFr
+                     , rel `elem` relsMentionedIn frExpr
+                     , let toExpr  = if ev==Ins
+                                     then disjNF options poss
+                                     else disjNF options (notCpl negs)
+                     , let visible r = r `elem` editables
+                     , if length (nub (map sign [toExpr, deltFr', expr]))>1
+                       then fatal 285 "type problem"
+                       else True
+                     , let act = genPAclause visible Ins toExpr deltFr' [(expr, map snd conjEqClass)]
+                     ]
+        , let ecaAct = ALL (map fst4 acts
+        -- The following acts add the implicit rules, which allows the user to add and delete atoms from concepts in a safe way.
+                            ++ [act' | (ev',rel',act')<-rulesDecls++rulesGens rel, ev==ev', rel==rel' ]
+                           )
+                           [ (rc_conjunct conj,ruls) | (_,conj,ruls,_)<-acts] --motivation is of type [(Expression,[Rule])]
+        , let normEcaAct = normPA options ecaAct
+        , let ecaProof = proofPA options ecaAct
+        , let ecaEvt = On ev rel
+        , let ecaRule = ECA ecaEvt delt normEcaAct
+        ]
+--   the following eca-rules are derived from the typing rules, rather than explicit rules specified by users.
+--   This concerns the following rules:
+--   Each declaration "RELATION r[A*B]" represents the rule "RULE r[A*B] |- V[A*B]"
+--   Besides, for every A, B:   "RULE  I[A]*I[B] = V[A*B]"
+--   For every "CLASSIFY A ISA B" we get  "RULE  I[A] |- I[B]"
+--   For every "CLASSIFY A IS B /\ C" we get "RULE  I[A] |- I[B]" and "RULE  I[A] |- I[C]"
+--   The results of both classify statements are available through vgens.
+--   Finally, for every Atom c a there is a rule  "RULE  'a' |- I[c]"
+--   The eca-rules that can be derived from these rules are produced by  ecasFromTypes
+   {- V[A*B] is implicit, so we don't generate ECA (On Ins rel) delt (Do Ins (Vs (Sign a b)) delt motive).
+                        Neither do we generate ECA (On Del (Vs (Sign a b))) delt (Do Del rel delt motive).
+      However, we do generate:                 ECA (On Ins rel) delt (Do Ins (Isn a) ((dlt.<>.flp dlt).-.EDcI a) motive)
+                                         and:  ECA (On Ins rel) delt (Do Ins (Isn b) ((flp dlt.<>.dlt).-.EDcI b) motive),
+      because the delta to be inserted might contain new atoms.
+      Similarly, upon deletion of an atom from a concept we must delete the appropriate links from relations that share this concept.
+      So, we generate                          ECA (On Del (Isn a)) delt (Do Del rel (delt.:.V[A*B]) motive)
+                                         and:  ECA (On Del (Isn b)) delt (Do Del rel (V[A*B].:.delt) motive)
+      ECA-rules that are derivable from relation declarations are generated by rulesDecls
+   -}
+    rulesDecls :: [(InsDel, Declaration, PAclause)]
+    rulesDecls
+      = concat
+        [ [ (Ins, rel, Do Ins (Isn a) ((dlt.:.flp dlt ./\. EDcI a).-.EDcI a) [])
+          , (Ins, rel, Do Ins (Isn b) ((flp dlt.:.dlt ./\. EDcI b).-.EDcI b) [])
+          , (Del, Isn a, Do Del rel (delta (Sign a a).:.vee) [])
+          , (Del, Isn b, Do Del rel (vee.:.delta (Sign b b)) [])
+          ]
+        | rel <- relsDefdIn context
+        , let dlt = delta (sign rel)
+        , let a=source rel, let b=target rel
+        , let vee = (EDcV . sign) rel
+        ]
+{- We generate:
+     for every "RULE  I[A] |- I[B]":        ECA (On Ins (Isn a)) delt (Do Ins (Isn b) (EDcD delt) motive)
+                                and:        ECA (On Del (Isn b)) delt (Do Del (Isn a) (EDcD delt) motive)
+     for every "RULE   'a' |- I[c]":        ECA (On Del (Isn c)) ('a','a') (Blk motive)
+-}
+    rulesGens :: Declaration -> [(InsDel, Declaration, PAclause)]
+    rulesGens rel
+      = concat
+        [ [ (Ins, Isn s, Do Ins (Isn g) dlt [])
+          , (Del, Isn g, Do Del (Isn s) dlt [])
+          ]
+        | let dlt = delta (sign rel), (s,g) <- concatMap genericAndSpecifics (gens context)
+        ]
+    fst4 (x,_,_,_) = x
+
+-- | de functie genPAclause beschrijft de voornaamste mogelijkheden om een expressie delta' te verwerken in expr (met tOp'==Ins of tOp==Del)
+-- TODO: Vind een wetenschappelijk artikel waar de hier beschreven transformatie uitputtend wordt behandeld.
+-- TODO: Deze code is onvolledig en misschien zelfs fout....
+genPAclause :: (Declaration->Bool)        -- ^True if a relation may be changed (i.e. is editable)
+               -> InsDel                  -- ^the type of action: Insert or Delete
+               -> Expression              -- ^the expression in which a delete or insert takes place
+               -> Expression              -- ^the delta to be inserted or deleted
+               -> [(Expression,[Rule])]   -- ^the motivation, consisting of the conjuncts (traced back to their rules) that are being restored by this code fragment.
+               -> PAclause
+genPAclause editAble tOp' expr1 delta1 motive = genPAcl delta1 tOp' expr1
+ where
+   testPA i l r ex
+    = if (source l,target r)/=(source ex,target ex)
+      then fatal i ("test with sign deltaX = ["++show (source l)++"*"++show (target r)++"],  and sign expr = "++show (sign ex)++":\ndeltaX = "++showADL (l.:.r)++"\nexpr = "++show ex)
+      else if source r/=target l
+      then fatal i ("test with source r = "++show (source r)++",  and target l = "++show (target l)++":\nl"++showSign (sign l)++" = "++showADL l++"\nr"++showSign (sign r)++" = "++showADL r++"\nexpr = "++show ex)
+      else id
+
+   genPAcl deltaX tOp expr =
+     case (tOp, expr) of
+       (_  , EEqu{})     -> Blk [(expr, nub [r |(_,rs)<-motive, r<-rs])]
+       (_  , EImp{})     -> Blk [(expr, nub [r |(_,rs)<-motive, r<-rs])]
+       (_ ,  EFlp x)     -> genPAcl (flp deltaX) tOp x
+       (_ ,  EBrk x)     -> genPAcl deltaX tOp x
+       (Ins, ECpl x)     -> genPAcl deltaX Del x
+       (Del, ECpl x)     -> genPAcl deltaX Ins x
+       (Ins, EUni{})     -> CHC [ genPAcl deltaX Ins f | f<-exprUni2list expr{-, not (f==expr1 && Ins/=tOp') -}] motive -- the filter prevents self compensating PA-clauses.
+       (Ins, EIsc{})     -> ALL [ genPAcl deltaX Ins f | f<-exprIsc2list expr ] motive
+       (Del, EUni{})     -> ALL [ genPAcl deltaX Del f | f<-exprUni2list expr {-, not (f==expr1 && Del/=tOp') -}] motive -- the filter prevents self compensating PA-clauses.
+       (Del, EIsc{})     -> CHC [ genPAcl deltaX Del f | f<-exprIsc2list expr ] motive
+       (Ins, EDif (l,r)) -> CHC [ genPAcl deltaX Ins l, genPAcl deltaX Del r ] motive
+       (Del, EDif (l,r)) -> CHC [ genPAcl deltaX Del l, genPAcl deltaX Ins r ] motive
+       (Ins, EDia (l,r)) -> CHC [ ALL [ genPAcl (testPA 986 (deltaX) (flp r)          l $ deltaX.:.flp r         ) Ins l
+                                      , genPAcl (testPA 987 (flp l) (deltaX)          r $ flp l.:.deltaX         ) Ins r] motive
+                                , ALL [ genPAcl (testPA 988 (deltaX) (notCpl (flp r)) l $ deltaX.:.notCpl (flp r)) Del l
+                                      , genPAcl (testPA 989 (deltaX) (flp r)          l $ deltaX.:.flp r         ) Ins l] motive
+                                , ALL [ genPAcl (testPA 990 (notCpl (flp l)) (deltaX) r $ notCpl (flp l).:.deltaX) Del r
+                                      , genPAcl (testPA 991 (flp l) (deltaX)          r $ flp l.:.deltaX         ) Ins r] motive
+                                , ALL [ genPAcl (testPA 992 (deltaX) (notCpl (flp r)) l $ deltaX.:.notCpl (flp r)) Del l
+                                      , genPAcl (testPA 993 (notCpl (flp l)) (deltaX) r $ notCpl (flp l).:.deltaX) Del r] motive
+                                ] motive
+       (Del, EDia (l,r)) -> GCH [ (Del, (testPA 995 (deltaX) (flp r)          l $ deltaX.:.flp r),          genPAcl (EMp1 "a" (source l).*.EMp1 "b" (target l)) tOp l)
+                                , (Ins, (testPA 996 (deltaX) (flp (notCpl r)) l $ deltaX.:.flp (notCpl r)), genPAcl (EMp1 "a" (source l).*.EMp1 "b" (target l)) tOp l)
+                                , (Del, (testPA 997 (flp l) (deltaX)          r $ flp l.:.deltaX),          genPAcl (EMp1 "a" (source r).*.EMp1 "b" (target r)) tOp r)
+                                , (Ins, (testPA 998 (notCpl (flp l)) (deltaX) r $ notCpl (flp l).:.deltaX), genPAcl (EMp1 "a" (source r).*.EMp1 "b" (target r)) tOp r)
+                                ] motive
+       (Ins, ERrs (l,r)) -> CHC [ genPAcl (testPA 1000 (notCpl r) (flp deltaX) l $ notCpl r.:.flp deltaX) Del l
+                                , genPAcl (testPA 1001 (l) (deltaX)            r $ l.:.deltaX)            Ins r
+                                ] motive
+       (Del, ERrs (l,r)) -> GCH [ (Ins, (testPA 1003 (notCpl r) (flp deltaX) l $ notCpl r.:.flp deltaX), genPAcl (EMp1 "a" (source l).*.EMp1 "b" (target l)) tOp l)
+                                , (Del, (testPA 1004 (l) (deltaX)            r $ l.:.deltaX),            genPAcl (EMp1 "a" (source r).*.EMp1 "b" (target r)) tOp r)
+                                ] motive
+       (Ins, ELrs (l,r)) -> CHC [ genPAcl (testPA 1006 (flp deltaX) (notCpl l) r $ flp deltaX.:.notCpl l) Del r
+                                , genPAcl (testPA 1007 (deltaX) (r)            l $ deltaX.:.r           ) Ins l
+                                ] motive
+       (Del, ELrs (l,r)) -> GCH [ (Ins, (testPA 1009 (flp deltaX) (notCpl l) r $ flp deltaX.:.notCpl l), genPAcl (EMp1 "a" (source r).*.EMp1 "b" (target r)) tOp r)
+                                , (Del, (testPA 1010 (deltaX) (r)            l $ deltaX.:.r),            genPAcl (EMp1 "a" (source l).*.EMp1 "b" (target l)) tOp l)
+                                ] motive
+       (Ins, ECps (l,r)) -> CHC [ GCH [ (Ins, (testPA 1012 (deltaX) (flp r) l $ deltaX.:.flp r), genPAcl (EMp1 "a" (source l).*.EMp1 "b" (target l)) tOp l)
+                                      , (Ins, (testPA 1013 (flp l) (deltaX) r $ flp l.:.deltaX), genPAcl (EMp1 "a" (source r).*.EMp1 "b" (target r)) tOp r)
+                                      ] motive
+                                , New (source r) (\x->ALL [ genPAcl (deltaX.*.EMp1 x (target l)) Ins l
+                                                          , genPAcl (EMp1 x (source r).*.deltaX) Ins r] motive) motive
+                                ] motive
+       (Del, ECps (l,r)) -> CHC [ genPAcl (testPA 1018 (deltaX) (flp r) l $ deltaX.:.flp r) Del l
+                                , genPAcl (testPA 1019 (flp l) (deltaX) r $ flp l.:.deltaX) Del r
+                                ] motive
+       (Ins, ERad (l,r)) -> CHC [ genPAcl (testPA 1021 (deltaX) (notCpl (flp r)) l $ deltaX.:.notCpl (flp r)) Ins l
+                                , genPAcl (testPA 1022 (notCpl (flp l)) (deltaX) r $ notCpl (flp l).:.deltaX) Ins r
+                                ] motive
+       (Del, ERad (l,r)) -> CHC [ GCH [ (Del, (testPA 1024 (deltaX) (flp r) l $ deltaX.:.flp r), genPAcl (EMp1 "a" (source l).*.EMp1 "b" (target l)) tOp l)
+                                      , (Del, (testPA 1025 (flp l) (deltaX) r $ flp l.:.deltaX), genPAcl (EMp1 "a" (source r).*.EMp1 "b" (target r)) tOp r)
+                                      ] motive
+                                , New (source r) (\_->Nop motive) motive
+                                ] motive
+       (Ins, EPrd (l,r)) -> ALL [ genPAcl (EDcV (Sign ONE (source deltaX)).:.deltaX) Ins (EDcV (Sign ONE (source r)).:.r)
+                                , genPAcl (deltaX.:.EDcV (Sign (target deltaX) ONE)) Ins (l.:.EDcV (Sign (target l) ONE))
+                                ] motive
+       (Del, EPrd (l,r)) -> ALL [ genPAcl (EDcV (Sign ONE (source deltaX)).:.deltaX) Del (EDcV (Sign ONE (source r)).:.r)
+                                , genPAcl (deltaX.:.EDcV (Sign (target deltaX) ONE)) Del (l.:.EDcV (Sign (target l) ONE))
+                                ] motive
+       (_  , EKl0 x )    -> genPAcl (deltaK0 deltaX tOp x) tOp x
+       (_  , EKl1 x )    -> genPAcl (deltaK1 deltaX tOp x) tOp x
+       (_  , EDcD d)     -> if editAble d then Do tOp d deltaX motive else Blk [(expr, nub [r |(_,rs)<-motive, r<-rs])]
+       (_  , EDcI c)     -> if editAble (Isn c) then Do tOp (Isn c) deltaX motive else Blk [(expr, nub [r |(_,rs)<-motive, r<-rs])]
+       (_  , EDcV{})     -> Blk [(expr, nub [r |(_,rs)<-motive, r<-rs])]
+       (_  , EMp1{})     -> Blk [(expr, nub [r |(_,rs)<-motive, r<-rs])]
+       (_  , EEps{})     -> Nop [(expr, nub [r |(_,rs)<-motive, r<-rs])]
+
+{-        (_ , _)           -> fatal 767 ( "(Stef?) Non-exhaustive patterns in the recursive call\n"
+                                    ++"doCod ("++showADL deltaX++") -- deltaX\n      "++show tOp++"  -- tOp\n      ("++showADL expr++") -- expr\n"++
+                                      "within function\ndoCode "++show tOp'++"  -- tOp'\n       ("++showADL expr1++") -- expr1\n       ("++showADL delta1++") -- delta1\n"++
+                                      concat
+                                      [ "while trying to maintain conjunct "++showADL conjunct++
+                                        "\nfrom rule "++intercalate "\n          " [show r | r<-rs]
+                                      | (conjunct,rs)<-motive ] ++
+                                      if null motive then "null motive" else ""
+                                      )
+-}
+
+   deltaK0 :: t -> InsDel -> t1 -> t
+   deltaK0 delta' Ins _ = delta'  -- error! (tijdelijk... moet berekenen welke paren in x gezet moeten worden zodat delta |- x*)
+   deltaK0 delta' Del _ = delta'  -- error! (tijdelijk... moet berekenen welke paren uit x verwijderd moeten worden zodat delta/\x* leeg is)
+   deltaK1 :: t -> InsDel -> t1 -> t
+   deltaK1 delta' Ins _ = delta'  -- error! (tijdelijk... moet berekenen welke paren in x gezet moeten worden zodat delta |- x+)
+   deltaK1 delta' Del _ = delta'  -- error! (tijdelijk... moet berekenen welke paren uit x verwijderd moeten worden zodat delta/\x+ leeg is)
+
+commaEngPandoc' :: Inlines -> [Inlines] -> Inlines
+commaEngPandoc' s [a,b,c] = a <> ", " <> b <> ", " <> s <> space <> c
+commaEngPandoc' s [a,b]   = a <> space <> s <> space <> b
+commaEngPandoc' _   [a]   = a
+commaEngPandoc' s (a:as)  = a <> ", " <> commaEngPandoc' s as
+commaEngPandoc' _   []    = mempty
+
+commaEngPandoc :: Inline -> [Inline] -> [Inline]
+commaEngPandoc s [a,b,c] = [a,Str ", ",b,Str ", ",s, Str " ", c]
+commaEngPandoc s [a,b]   = [a,Str " ",s, Str " ", b]
+commaEngPandoc _   [a]   = [a]
+commaEngPandoc s (a:as)  = [a, Str ", "]++commaEngPandoc s as
+commaEngPandoc _   []    = []
+
+commaNLPandoc' :: Inlines -> [Inlines] -> Inlines
+commaNLPandoc' s [a,b]  = a <> space <> s <> space <> b
+commaNLPandoc'  _  [a]  = a
+commaNLPandoc' s (a:as) = a <> ", " <> commaNLPandoc' s as
+commaNLPandoc'  _  []   = mempty
+commaNLPandoc :: Inline -> [Inline] -> [Inline]
+commaNLPandoc s [a,b]  = [a,Str " ",s, Str " ", b]
+commaNLPandoc  _  [a]  = [a]
+commaNLPandoc s (a:as) = [a, Str ", "]++commaNLPandoc s as
+commaNLPandoc  _  []   = []
+   
+   
+quadsOfRules :: Options -> [Rule] -> [Quad]
+quadsOfRules opts rules 
+  = makeAllQuads (converse [ (conj, rc_orgRules conj) | conj <- makeAllConjs opts rules ])
+
+        -- Quads embody the "switchboard" of rules. A quad represents a "proto-rule" with the following meaning:
+        -- whenever relation r is affected (i.e. tuples in r are inserted or deleted),
+        -- the rule may have to be restored using functionality from one of the clauses.
+makeAllQuads :: [(Rule, [Conjunct])] -> [Quad]
+makeAllQuads conjsPerRule =
+  [ Quad { qDcl     = d
+         , qRule    = rule
+         , qConjuncts = conjs
+         }
+  | (rule,conjs) <- conjsPerRule, d <-relsUsedIn rule
+  ]
+  
+{-
+-- If one rule r blocks upon an event, e.g. e@(ON Ins rel), while another ECA rule r'
+-- maintains something else with that same event e, we can save r' the trouble.
+-- After all, event e will block anyway.
+-- preEmpt tries to simplify ECArules by predicting whether a rule will block.
+preEmpt :: Options -> [ECArule] -> [ECArule]
+preEmpt opts ers = pr [length ers] (10::Int)
+ where
+  pr :: [Int] -> Int -> [ECArule]
+  pr ls n
+    | n == 0              = fatal 633 $ "too many cascading levels in preEmpt "++show ls
+    | (not.null) cascaded = pr (length cascaded:ls)
+                            -- ([er{ecaAction=normPA opts (ecaAction er)} | er<-cascaded] ++uncasced)
+                               (n-1)
+    | otherwise           = [er{ecaAction=normPA opts (ecaAction er)} | er<-uncasced]
+   where
+-- preEmpt divides all ECA rules in uncascaded rules and cascaded rules.
+-- cascaded rules are those rules that have a Do component with event e, where e is known to block (for some other reason)
+    new  = [er{ecaAction=normPA opts (ecaAction er)} | er<-ers]
+    cascaded = [er{ecaAction=action'} | er<-new, let (c,action') = cascade (eDcl (ecaTriggr er)) (ecaAction er), c]
+    uncasced = [er |                    er<-new, let (c,_)       = cascade (eDcl (ecaTriggr er)) (ecaAction er), not c]
+-- cascade inserts a block on the place where a Do component exists that matches the blocking event.
+--  cascade :: Relation -> PAclause -> (Bool, PAclause)
+  cascade dcl (Do srt to _ _) | (not.null) blkErs = (True, ecaAction (head blkErs))
+   where blkErs = [er | er<-ers
+                      , Blk _<-[ecaAction er]
+                      , let t = ecaTriggr er
+                      , eSrt t == srt
+                      , eDcl t == to
+                      , not (dcl ==to)
+                      ]
+  cascade  _  c@Do{}           = (False, c)
+  cascade rel (New c clause m) = ((fst.cascade rel.clause) "dummystr", New c (snd.cascade rel.clause) m)
+  cascade rel (Rmv c clause m) = ((fst.cascade rel.clause) "dummystr", Rmv c (snd.cascade rel.clause) m)
+--cascade rel (Sel c e cl m)   = ((fst.cascade rel.cl) "dummystr",     Sel c e (snd.cascade rel.cl)   m)
+  cascade rel (CHC ds m)       = (any (fst.cascade rel) ds, CHC (map (snd.cascade rel) ds) m)
+  cascade rel (ALL ds m)       = (any (fst.cascade rel) ds, ALL (map (snd.cascade rel) ds) m)
+  cascade  _  (Nop m)          = (False, Nop m)
+  cascade  _  (Blk m)          = (False, Blk m)
+  cascade  _  (Let _ _ _)  = fatal 611 "Deze constructor is niet gedefinieerd" -- HJO, 20131205:Toegevoegd om warning te verwijderen
+  cascade  _  (Ref _)      = fatal 612 "Deze constructor is niet gedefinieerd" -- HJO, 20131205:Toegevoegd om warning te verwijderen
+  cascade  _  (GCH{})      = fatal 655 "Deze constructor is niet gedefinieerd" -- SJO, 20140428:Toegevoegd om warning te verwijderen
+-}
+
+   
+ src/Database/Design/Ampersand/FSpec/ToFSpec/CreateFspec.hs view
@@ -0,0 +1,113 @@+module Database.Design.Ampersand.FSpec.ToFSpec.CreateFspec 
+  (createFSpec,getPopulationsFrom)
+  
+where
+import Prelude hiding (putStrLn, writeFile) -- make sure everything is UTF8
+import Database.Design.Ampersand.Basics
+import Database.Design.Ampersand.Misc
+import Database.Design.Ampersand.ADL1
+import Database.Design.Ampersand.ADL1.P2A_Converters
+import Database.Design.Ampersand.FSpec.FSpec
+import Database.Design.Ampersand.FSpec.ShowMeatGrinder
+import Database.Design.Ampersand.Input
+import Database.Design.Ampersand.FSpec.ToFSpec.ADL2FSpec
+import System.Directory
+import System.FilePath
+import Data.Traversable (sequenceA)
+import Control.Applicative
+import Database.Design.Ampersand.Core.ToMeta
+import Control.Monad
+
+fatal :: Int -> String -> a
+fatal = fatalMsg "CreateFspec"
+
+
+
+-- | create an FSpec, based on the provided command-line options.
+createFSpec :: Options  -- ^The options derived from the command line
+            -> IO(Guarded FSpec)
+createFSpec opts =
+  do userP_Ctx <- parseADL opts (fileName opts) -- the P_Context of the user's sourceFile
+     genFiles userP_Ctx >> genTables userP_Ctx
+   where
+    genFiles :: Guarded P_Context -> IO(Guarded ())
+    genFiles uCtx 
+      = case pCtx2Fspec uCtx of
+          Errors es -> return(Errors es)
+          Checked uFspec
+            ->   when (genASTFile opts) (doGenMetaFile AST uFspec)
+              >> when (genGenericsFile opts) (doGenMetaFile Generics uFspec)
+              >> return (Checked ())
+
+    genTables :: Guarded P_Context -> IO(Guarded FSpec)
+    genTables uCtx= case whatTablesToCreateExtra of
+       Nothing 
+         -> return (pCtx2Fspec uCtx)
+       Just mType
+         -> do rapP_Ctx <- getFormalFile mType -- the P_Context of the 
+               let populationPctx       = unguard ( grind mType <$> pCtx2Fspec uCtx)
+                   populatedRapPctx     = merge.sequenceA $ [rapP_Ctx,populationPctx]
+                   metaPopulatedRapPctx = toMeta opts <$> populatedRapPctx
+                   allCombinedPctx      = merge.sequenceA $ [uCtx, metaPopulatedRapPctx]
+               return $ pCtx2Fspec allCombinedPctx -- the RAP specification that is populated with the user's 'things' is returned.
+
+    whatTablesToCreateExtra :: Maybe MetaType
+    whatTablesToCreateExtra 
+       | genASTTables opts     = Just AST
+       | genGenericTables opts = Just Generics
+       | otherwise             = Nothing
+
+    getFormalFile :: MetaType -> IO(Guarded P_Context)
+    getFormalFile mType
+     = do let file = ampersandDataDir opts 
+                    </> "FormalAmpersand" 
+                    </> (case mType of
+                           Generics -> "Generics.adl"
+                           AST -> "FormalAmpersand.adl")
+          exists <- doesFileExist file
+          if exists then parseADL opts file
+          else fatal 98 $ unlines
+                 [ "Ampersand isn't installed properly. Couldn't read:"
+                 , "  "++show file
+                 , "  (Make sure you have the latest content of Ampersand data. You might need to re-install ampersand...)"
+                 ]
+    
+    
+    toFspec :: A_Context -> Guarded FSpec
+    toFspec = pure . makeFSpec opts
+    pCtx2Fspec :: Guarded P_Context -> Guarded FSpec
+    pCtx2Fspec c = unguard $ toFspec <$> (unguard $ pCtx2aCtx opts <$> c)
+    merge :: Guarded [P_Context] -> Guarded P_Context
+    merge ctxs = fmap f ctxs
+      where
+       f []     = fatal 77 $ "merge must not be applied to an empty list"
+       f (c:cs) = foldr mergeContexts c cs
+    grind :: MetaType -> FSpec -> Guarded P_Context
+    grind mType fSpec
+      = fmap fstIfNoIncludes $ parseCtx f c
+      where (f,c) = makeMetaPopulationFile mType fSpec
+            fstIfNoIncludes (a,includes)
+             = case includes of 
+               [] -> a
+               _  -> fatal 83 "Meatgrinder returns included file. That isn't anticipated."
+            
+     
+getPopulationsFrom :: Options -> FilePath -> IO (Guarded [Population])
+getPopulationsFrom opts filePath =
+ do gpCtx <- parseADL opts filePath
+    return (unguard $ f <$> gpCtx) 
+   where
+     f :: P_Context -> Guarded [Population]
+     f pCtx = unguard $ 
+                pure . initialPops . makeFSpec opts
+                 <$> pCtx2aCtx opts pCtx
+
+doGenMetaFile :: MetaType -> FSpec -> IO()
+doGenMetaFile mType fSpec =
+ do { verboseLn (getOpts fSpec) $ "Generating "++show mType++" meta file for "++name fSpec
+    ; writeFile outputFile contents
+    ; verboseLn (getOpts fSpec) $ show mType++" written into " ++ outputFile ++ ""
+    }
+ where outputFile = combine (dirOutput (getOpts fSpec)) $ fpath
+       (fpath,contents) = makeMetaPopulationFile mType fSpec
+ 
+ src/Database/Design/Ampersand/FSpec/ToFSpec/NormalForms.hs view
@@ -0,0 +1,1739 @@+{-# OPTIONS_GHC -XFlexibleInstances #-}
+module Database.Design.Ampersand.FSpec.ToFSpec.NormalForms
+  (delta,conjNF,disjNF,normPA,cfProof,dfProof,proofPA,simplify
+  ,cfProofs, dfProofs  -- these are for confluence testing.
+  , makeAllConjs, conjuncts
+  ) where
+  
+import Data.Set (Set)
+import qualified Data.Set as Set
+import Data.List (nub, intercalate, permutations)
+import Database.Design.Ampersand.Basics
+import Database.Design.Ampersand.ADL1.ECArule
+import Database.Design.Ampersand.ADL1.Expression
+import Database.Design.Ampersand.ADL1.P2A_Converters (pCpt2aCpt)
+import Database.Design.Ampersand.Classes.Relational
+import Database.Design.Ampersand.Core.AbstractSyntaxTree
+import Database.Design.Ampersand.Core.ParseTree
+import Database.Design.Ampersand.Misc.Options
+import Database.Design.Ampersand.Input (parseRule)
+import Database.Design.Ampersand.FSpec.ShowADL  -- for debug purposes only
+import Prelude hiding (head)
+-- import Debug.Trace
+fatal :: Int -> String -> a
+fatal = fatalMsg "FSpec.ToFSpec.NormalForms"
+
+{- SJC:
+Ideas for future work:
+-> Create a Unifier data type / class with
+   > extend :: key -> value -> Unifier -> Maybe Unifier
+   (returns Nothing if the key is already in the Unifier)
+   > obtain :: key -> Unifier -> value
+   (something like this twice! Handle types separate from relations)
+   > think of a way in which substitution never fails (unify matching and substitution for this)
+-> Make RTerm polymorphic, so we can treat variables and constants separately.
+   We'd have RTerm Expression and RTerm (String,String,String)
+   We'd be able to derive fmap, and make RTerm Foldable.
+-> Really long term: Unify RTerm and Expression in a way that still allows us to write simple code for binary operators. Would require separating = and |- from Expression, which is also nice.
+-}
+
+-- The following was built for the purpose of testing confluence.
+-- These functions produce all derivations of results from the normalizer.
+-- A useful side effect is that it implicitly tests for soundness.
+cfProofs, dfProofs :: Expression -> [(Expression, Proof Expression)]
+(cfProofs, dfProofs) = (prfs False, prfs True)
+ where
+   prfs :: Bool -> Expression -> [(Expression, Proof Expression)]
+   prfs dnf expr
+    = nub [ (rTerm2expr t, map makeExpr derivs) | (t, derivs)<-f (expr2RTerm expr) ]
+      where
+        f :: RTerm -> [(RTerm,[(RTerm, [String], String)])]
+        f term = [ (term,[(term, [], "<=>")]) | null dsteps ]++
+                 [ (t, (term, [showStep dstep], "<=>"):deriv)
+                 | dstep<-dsteps, (t,deriv)<-f (rhs dstep)
+                 ]
+                 where dsteps = [ dstep | dstep<-dSteps tceDerivRules term, w (rhs dstep)<w term]
+        w = weightNF dnf -- the weight function for disjunctive normal form.
+        showStep dstep = " weight: "++(show.w.lhs) dstep++",   "++showADL tmpl++" = "++showADL stp++"  with unifier: "++showADL unif
+                         where (tmpl,unif,stp) = rul dstep
+        makeExpr (term, explStr, logicSym) = (rTerm2expr term, explStr, logicSym)
+
+-- Deriving normal forms and representing the neccessary derivation rules are defined by means of RTerms.
+-- The data structure RTerm is a representation of relation algebra expressions,
+-- which is not redundant with respect to associativity and commutativity.
+-- The reason for this is that we use term rewriting for normalization.
+-- This algorithm performs poorly with commutative rules, because it may explode combinatorially.
+data RTerm = RIsc {rTermSet :: Set RTerm}  -- intersection is associative and commutative
+           | RUni {rTermSet :: Set RTerm}  -- union is associative and commutative
+           | RDif {rTermLft :: RTerm, rTermRht :: RTerm}
+           | RCpl {rTermUny :: RTerm}
+           | RDia {rTermLft :: RTerm, rTermRht :: RTerm}
+           | RLrs {rTermLft :: RTerm, rTermRht :: RTerm}
+           | RRrs {rTermLft :: RTerm, rTermRht :: RTerm}
+           | RRad {rTermList :: [RTerm]}      -- ! is associative
+           | RCps {rTermList :: [RTerm]}      -- ; is associative
+           | RPrd {rTermList :: [RTerm]}      -- # is associative
+           | RKl0 {rTermUny :: RTerm}
+           | RKl1 {rTermUny :: RTerm}
+           | RFlp {rTermUny :: RTerm}
+           | RId  A_Concept
+           | RVee A_Concept A_Concept
+           | RAtm String A_Concept
+           | RVar String String String  -- relation name, source name, target name.
+           | RConst Expression
+           deriving (Eq,Ord,Show)
+
+-- The following condition must hold at all times for every RTerm, in order to make equality work
+-- It ensures that nested RIsc terms do not occur, and RIsc terms are at least 2 terms of length.
+-- The same holds for RUni, RRad, RCps, and RPrd.
+isValid :: RTerm -> Bool
+isValid (RIsc s)   = and [not (isRIsc e) && isValid e && length ls>1 | let ls=Set.toList s, e<-ls]
+isValid (RUni s)   = and [not (isRUni e) && isValid e && length ls>1 | let ls=Set.toList s, e<-ls]
+isValid (RDif l r) = isValid l && isValid r
+isValid (RCpl e)   = isValid e
+isValid (RDia l r) = isValid l && isValid r
+isValid (RLrs l r) = isValid l && isValid r
+isValid (RRrs l r) = isValid l && isValid r
+isValid (RRad ls)  = and [not (isRRad e) && isValid e && length ls>1 | e<-ls]
+isValid (RCps ls)  = and [not (isRCps e) && isValid e && length ls>1 | e<-ls]
+isValid (RPrd ls)  = and [not (isRPrd e) && isValid e && length ls>1 | e<-ls]
+isValid (RKl0 e)   = isValid e
+isValid (RKl1 e)   = isValid e
+isValid (RFlp e)   = isValid e
+isValid _          = True
+
+-- normRT exists to make an arbitrary term satisfy isValid.
+-- So isValid (normRT term) is True, whil term and (normRT term) have the same meaning.
+normRT :: RTerm -> RTerm
+normRT (RIsc s)   = (combSet RIsc . Set.fromList . flat isRIsc . map normRT . Set.toList) s
+normRT (RUni s)   = (combSet RUni . Set.fromList . flat isRUni . map normRT . Set.toList) s
+normRT (RDif l r) = RDif (normRT l) (normRT r)
+normRT (RCpl e)   = RCpl (normRT e)
+normRT (RDia l r) = RDia (normRT l) (normRT r)
+normRT (RLrs l r) = RLrs (normRT l) (normRT r)
+normRT (RRrs l r) = RRrs (normRT l) (normRT r)
+normRT (RRad ls)  = (combLst RRad . flat isRRad . map normRT) ls
+normRT (RCps ls)  = (combLst RCps . flat isRCps . map normRT) ls
+normRT (RPrd ls)  = (combLst RPrd . flat isRPrd . map normRT) ls
+normRT (RKl0 e)   = RKl0 (normRT e)
+normRT (RKl1 e)   = RKl1 (normRT e)
+normRT (RFlp e)   = RFlp (normRT e)
+normRT term       = term
+
+isRIsc, isRUni, isRDif, isRCpl, isRDia, isRLrs, isRRrs, isRRad, isRCps, isRPrd, isRKl0, isRKl1, isRFlp, isRVar :: RTerm -> Bool
+isRIsc (RIsc{}) = True
+isRIsc _        = False
+isRUni (RUni{}) = True
+isRUni _        = False
+isRDif (RDif{}) = True
+isRDif _        = False
+isRCpl (RCpl{}) = True
+isRCpl _        = False
+isRDia (RDia{}) = True
+isRDia _        = False
+isRLrs (RLrs{}) = True
+isRLrs _        = False
+isRRrs (RRrs{}) = True
+isRRrs _        = False
+isRRad (RRad{}) = True
+isRRad _        = False
+isRCps (RCps{}) = True
+isRCps _        = False
+isRPrd (RPrd{}) = True
+isRPrd _        = False
+isRKl0 (RKl0{}) = True
+isRKl0 _        = False
+isRKl1 (RKl1{}) = True
+isRKl1 _        = False
+isRFlp (RFlp{}) = True
+isRFlp _        = False
+isRVar (RVar{}) = True
+isRVar _        = False
+
+{- dSteps computes the expressions that can be obtained in one rewrite step.
+   It yields the steps, for the purpose of constructing the entire proof.
+   The idea is that the environment picks one of the steps produced by dSteps.
+-}
+dSteps :: [DerivRule] -> RTerm -> [DerivStep]
+dSteps drs x = dStps x
+ where
+  dStps :: RTerm -> [DerivStep]
+  dStps (RIsc s)     = dStepSets isRIsc RIsc s
+  dStps (RUni s)     = dStepSets isRUni RUni s
+  dStps (RDif a b)   = dStepBin isRDif RDif a b
+  dStps (RCpl a)     = dStepUny isRCpl RCpl a
+  dStps (RDia a b)   = dStepBin isRDia RDia a b
+  dStps (RLrs a b)   = dStepBin isRLrs RLrs a b
+  dStps (RRrs a b)   = dStepBin isRRrs RRrs a b
+  dStps (RRad ls)    = dStepLists isRRad RRad ls
+  dStps (RCps ls)    = dStepLists isRCps RCps ls
+  dStps (RPrd ls)    = dStepLists isRPrd RPrd ls
+  dStps (RKl0 a)     = dStepUny isRKl0 RKl0 a
+  dStps (RKl1 a)     = dStepUny isRKl1 RKl1 a
+  dStps (RFlp a)     = dStepUny isRFlp RFlp a
+  dStps (RId _)      = [ DStep { lhs = x                                       -- derivs gives the top level rewrites.
+                               , rul = (term, unif, term')                     -- only one rewrite is done in parallel in the top level.
+                               , rhs = substitute rd unif term'                -- so rest is left alone, if partition can be rewritten.
+                               }
+                       | (term@(RId a'), rewriteTerms)<-matchableRules          -- select rewrite rules with the proper combinator
+                       , let unif = Set.fromList [(name a',x)]                  -- find unifiers such that: substitute "" unif term==rCombinator a
+                       , term'<-rewriteTerms                                    -- enumerate right hand side RTerms in order to construct:  substitute "" unif term'
+                       , let rd = showADL term++" -> "++showADL term'           -- rule documentation for fatals in 'substitute'
+                       , if substitute rd unif term==x then True else
+                         fatal 122 ("When analysing rule "++rd++" with unifier "++showADL unif++"\nsubstitute rd unif term:  "++showADL (substitute rd unif term)++"\ndiffers from:  "++showADL x)
+                       ]
+  dStps (RVee a b)   = [ DStep { lhs = x                                       -- derivs gives the top level rewrites.
+                               , rul = (term, unif, term')                     -- only one rewrite is done in parallel in the top level.
+                               , rhs = substitute rd unif term'                -- so rest is left alone, if partition can be rewritten.
+                               }
+                       | (term@(RVee a' b'), rewriteTerms)<-matchableRules      -- select rewrite rules with the proper combinator
+                       , let unif = Set.fromList [(name a',RId a), (name b',RId b)] -- find unifiers such that: substitute "" unif term==rCombinator a
+                       , noDoubles unif                                         -- if one variable is bound to more than one different expressions, the deal is off.
+                       , term'<-rewriteTerms                                    -- enumerate right hand side RTerms in order to construct:  substitute "" unif term'
+                       , let rd = showADL term++" -> "++showADL term'           -- rule documentation for fatals in 'substitute'
+                       , if substitute rd unif term==x then True else
+                         fatal 134 ("When analysing rule "++rd++" with unifier "++showADL unif++"\nsubstitute rd unif term:  "++showADL (substitute rd unif term)++"\ndiffers from:  "++showADL x)
+                       ]
+  dStps (RAtm a c)   = [ DStep { lhs = x                                       -- derivs gives the top level rewrites.
+                               , rul = (term, unif, term')                     -- only one rewrite is done in parallel in the top level.
+                               , rhs = substitute rd unif term'                -- so rest is left alone, if partition can be rewritten.
+                               }
+                       | (term@(RAtm a' c'), rewriteTerms)<-matchableRules      -- select rewrite rules with the proper combinator
+                       , a==a'
+                       , let unif = Set.fromList [(name c',RId c)]              -- find unifiers such that: substitute "" unif term==rCombinator a
+                       , term'<-rewriteTerms                                    -- enumerate right hand side RTerms in order to construct:  substitute "" unif term'
+                       , let rd = showADL term++" -> "++showADL term'            -- rule documentation for fatals in 'substitute'
+                       , if substitute rd unif term==x then True else
+                         fatal 146 ("When analysing rule "++rd++" with unifier "++showADL unif++"\nsubstitute rd unif term:  "++showADL (substitute rd unif term)++"\ndiffers from:  "++showADL x)
+                       ]
+  dStps (RVar _ _ _) = fatal 147 "Cannot rewrite a term with a variable in it." -- This should become a haskell type-error when RTerm is polymorphic
+  dStps (RConst _)   = [] -- the only possibly matching rule has a single variable on the lhs, which we assume does not exist. SJ to SJC: Why? is there a reason why we don't want to include that situation?
+
+  dStepUny :: (RTerm -> Bool)    -- a predicate, isrComb, which tests whether some RTerm r has rCombinator as its root.
+           -> (RTerm -> RTerm)   -- the combinator
+           -> RTerm              -- its argument  (So, we are working with the RTerm   rCombinator a)
+           -> [DerivStep]        -- all derivation steps that start at  rCombinator a, which can be made using the available ruleset
+{- We are trying to find steps in case an expression (rCombinator a) has a unary operator (i.e. RCpl, RKl0, RKl1, RFlp) as its root.
+   First, we try to find a rewrite step on the root level of the expression. The resulting steps are called "derivs".
+   When that fails, we try to find the steps from subexpression a recursively.
+-}
+  dStepUny isrComb rCombinator a
+   = if (not . isValid . rCombinator) a
+     then fatal 180 ("Invalid expression in dStepLists: "++showADL (rCombinator a))
+     else
+     derivs ++
+     [ DStep { lhs = rCombinator a                                     -- try to find steps recursively
+             , rul = rul step
+             , rhs = rCombinator (rhs step)
+             }
+     | step<-dStps a ]
+     where derivs = [ DStep { lhs = rCombinator a                           -- derivs gives the top level rewrites.
+                            , rul = (term, unif, term')                     -- only one rewrite is done in parallel in the top level.
+                            , rhs = substitute rd unif term'                -- so rest is left alone, if partition can be rewritten.
+                            }
+                    | (term, rewriteTerms)<-matchableRules, isrComb term     -- select rewrite rules with the proper combinator
+                    , let subTerm = rTermUny term                            -- now:   rCombinator subTerm = term
+                    , unif<-matches subTerm a                                -- find unifiers such that: substitute "" unif term==rCombinator a
+                    , term'<-rewriteTerms                                    -- enumerate right hand side RTerms in order to construct:  substitute "" unif term'
+                    , let rd = showADL term++" -> "++showADL term'            -- rule documentation for fatals in 'substitute'
+                    , if substitute rd unif term==rCombinator a then True else
+                      fatal 177 ("When analysing rule "++rd++" with unifier "++showADL unif++"\nsubstitute rd unif term:  "++showADL (substitute rd unif term)++"\ndiffers from\nrCombinator a:  "++showADL (rCombinator a))
+                    ]
+
+-- dStepBin follows the same pattern as dStepUny, but for binary RTerms
+  dStepBin :: (RTerm -> Bool) -> (RTerm -> RTerm -> RTerm) -> RTerm -> RTerm -> [DerivStep]
+  dStepBin isrComb rCombinator a b
+   = if (not . isValid) (rCombinator a b)
+     then fatal 202 ("Invalid expression in dStepLists: "++showADL (rCombinator a b))
+     else
+     derivs ++
+     [ DStep { lhs = rCombinator a b
+             , rul = rul rStp
+             , rhs = rCombinator a (rhs rStp)
+             }
+     | rStp<-dStps b ] ++
+     [ DStep { lhs = rCombinator a b
+             , rul = rul lStp
+             , rhs = rCombinator (rhs lStp) b
+             }
+     | lStp<-dStps a ]
+     where derivs = [ DStep { lhs = rCombinator a b             -- derivs gives the top level rewrites.
+                            , rul = (term, unif, term')         -- only one rewrite is done in parallel in the top level.
+                            , rhs = substitute rd unif term'    -- so rest is left alone, if partition can be rewritten.
+                            }
+                    | (term, rewriteTerms)<-matchableRules, isrComb term    -- select rewrite rules with the proper combinator
+                    , let subLft = rTermLft term; subRht = rTermRht term    -- now:   rCombinator subTerm = term
+                    , unif1 <- matches subLft a
+                    , unif2 <- matches subRht b    -- find unifiers such that: substitute "" unif term==rCombinator a
+                    , let unif = Set.union unif1 unif2
+                    , noDoubles unif                          -- if one variable is bound to more than one different expressions, the deal is off.
+                    , term'<-rewriteTerms                     -- enumerate right hand side RTerms in order to construct:  substitute "" unif term'
+                    , let rd = showADL term++" -> "++showADL term'        -- rule documentation for fatals in 'substitute'
+                    , if substitute rd unif term==rCombinator a b then True else
+                      fatal 207 ("When analysing rule "++rd++" with unifier "++showADL unif++"\nsubstitute rd unif term:  "++showADL (substitute rd unif term)++"\ndiffers from\nrCombinator a b:  "++showADL (rCombinator a b))
+                    ]
+
+  dStepLists :: (RTerm -> Bool) -> ([RTerm] -> RTerm) -> [RTerm] -> [DerivStep] -- Note: a and b are both RTerm
+  dStepLists isrComb rCombinator ls
+   = if (not . isValid . rCombinator) ls
+     then fatal 231 ("Invalid expression in dStepLists: "++showADL (rCombinator ls))
+     else
+     [ DStep { lhs = rCombinator ls       -- The original expression
+             , rul = (term, unif, term')  -- only one rewrite step is done without parallelism.
+             , rhs = result
+             }
+     | (term, rewriteTerms)<-matchableRules, isrComb term
+     , let subTerms = rTermList term
+     , let n=length subTerms
+     , (pre,segmentList,post) <- segments n
+     , unif <- mix [ matches l r | (l,r)<-safezip subTerms (map (combLst rCombinator) segmentList) ]
+     , noDoubles unif                                      -- if one variable is bound to more than one different expressions, the deal is off.
+     , term'<-rewriteTerms
+     , let rd = showADL term++" -> "++showADL term'        -- rule documentation for fatals in 'substitute'
+     , let original=flatLst (pre ++ substitute rd unif term :post)  -- is equal to rCombinator ls
+     , let result  =flatLst (pre ++ substitute rd unif term':post)
+     , if original==rCombinator ls then True else
+       fatal 228 ("When analysing rule "++rd++" with unifier "++showADL unif++" on:  "++showADL (rCombinator ls)++
+                  "\nWe substitute:  "++showADL (substitute rd unif term)++
+                  "\nby:             "++showADL (substitute rd unif term')++
+                  ".\nHowever, the original RTerm:  "++showADL (rCombinator ls)++
+                  "\ndiffers from flatLst (pre ++ substitute rd unif term :post):\n  "++
+                  showADL original
+                 )
+     ] ++
+     [ DStep { lhs = rCombinator ls -- is equal to: (pre++lhs dstep:post)
+             , rul = rul dstep
+             , rhs = flatLst (pre++rhs dstep:post)
+             }
+     | (pre,l,post) <- splitList ls
+     , dstep <- dStps l]
+     where dist :: Int -> [RTerm] -> [[[RTerm]]]
+           dist 1 es = [[es]]
+           dist 2 es = [ [ take i es , drop i es ] | i<-[1..length es-1] ]
+           dist n es = [ init ds++st | ds<-dist (n-1) es, let staart=last ds, length staart>=2, st<-dist 2 staart ]
+           segments :: Int -> [([RTerm],[[RTerm]],[RTerm])]
+           segments n
+            = [ ([], ds, []) | ds<-dist n ls] ++
+              [ (head ds, tail ds, []) | ds<-dist (n+1) ls ] ++
+              [ ([], init ds, last ds) | ds<-dist (n+1) ls ] ++
+              [ (head ds, (init.tail) ds, last ds) | ds<-dist (n+2) ls ]
+           flatLst :: [RTerm] -> RTerm
+           flatLst = combLst rCombinator . flat isrComb
+
+  dStepSets  :: (RTerm -> Bool) -> (Set RTerm -> RTerm) -> Set RTerm -> [DerivStep]
+  dStepSets isrComb rCombinator s
+  -- We try to perform a rewrite on the top level, i.e. on some subset of RTerms from s.
+  -- Then, we add rewrites on any of the subexpressins in s.
+  -- Example rCombinator s  = RUni { '1', aap, aap\noot, 'Piet', mies;vuur}
+   = [ DStep { lhs = rCombinator s            -- derivs gives the top level rewrites.
+             , rul = (term, unif, term')      -- only one rewrite is done in parallel in the top level.
+             , rhs = result                   -- so rest is left alone, if partition can be rewritten.
+             }
+     | null [ () | e<-Set.toList s, not (isValid e), fatal 313 ("Invalid subexpr: "++showADL e) ]
+     -- s = { foo;foo~ , -(bar;bar~) , I[C]}
+     , (term, rewriteTerms)<-matchableRules, isrComb term       -- e.g. term = 'Piet' \/ r \/ p\q
+     , let subTerms = rTermSet term                             -- e.g. subTerms = { 'Piet', r, p\q }
+     , let termVars = Set.filter isRVar subTerms                -- e.g. termVars = { r }
+     , let sameTrms = subTerms `Set.intersection` s             -- e.g. sameTrms = { 'Piet' }
+     , let subExprs = s `Set.difference` sameTrms               -- { '1', aap, aap\noot, mies;vuur }
+     , let toMatchs = (subTerms `Set.difference` sameTrms) `Set.difference` termVars -- e.g. toMatchs = { p\q }
+     , let n=Set.size toMatchs -- each element of toMatchs can be matched to one subTerm from subExprs.
+     , (matchCandidates,rest)<-separate n subExprs              -- e.g. matchCandidates = {aap\noot} and rest={ '1', aap, mies;vuur }
+     , let m=Set.size termVars -- each variable in subTerms must be matched to one subset from rest.
+     , (restSets,remainder)<-partsplus m rest                   -- e.g. restSets={ {'1', aap, mies;vuur} }
+     , let restTerms = (Set.map (flatSet . Set.toList)) restSets   -- e.g. restTerms={ RUni {'1', aap, mies;vuur} }
+     , if Set.null restTerms then True else
+       if (isValid . flatSet . Set.toList) restTerms then True else fatal 305 ("Invalid restTerms: "++showADL (rCombinator restTerms))
+     , let remTerm   = let remT = combSet rCombinator remainder in
+                       if Set.null remainder
+                       then fatal 308 "empty remTerm"
+                       else if isValid remT then remT else fatal 309 ("Invalid remTerm: "++showADL remT)            -- e.g. restTerms={ RUni {'1', aap, mies;vuur} }
+     , unif0 <- if Set.null toMatchs then [Set.empty] else
+                if (not.isValid.combSet rCombinator) toMatchs        then fatal 311 ("Invalid toMatchs: "++showADL (rCombinator toMatchs)) else
+                if (not.isValid.combSet rCombinator) matchCandidates then fatal 312 ("Invalid matchCandidates: "++showADL (rCombinator matchCandidates)) else
+                matchSets rCombinator toMatchs matchCandidates  -- e.g. unif0={ p->aap, q->noot }
+     , unif1 <- if Set.null termVars then [Set.empty] else
+                matchSets rCombinator termVars restTerms        -- e.g. unif1={ r->RUni {'1', aap, mies;vuur} }
+     , let unif = unif0 `Set.union` unif1                       -- e.g. unif={ p->aap, q->noot, r->RUni {'1', aap, mies;vuur} }
+     , noDoubles unif
+     , term'<-rewriteTerms
+     , let rd = showADL term++" -> "++showADL term'             -- rule documentation for fatals in 'substitute'
+     , let original = if Set.null remainder
+                      then substitute rd unif term              -- is equal to rCombinator ls
+                      else flatSet [substitute rd unif term,  remTerm]
+     , let result   = if Set.null remainder
+                      then substitute rd unif term'
+                      else flatSet [substitute rd unif term', remTerm]
+     , if original==rCombinator s then True else
+       fatal 327 ("When analysing rule "++rd++" with unifier "++showADL unif++" on:  "++showADL (rCombinator s)++
+                  "\nWe substitute:  "++showADL original++
+                  "\nby:             "++showADL result++
+                  "\nHowever, the original RTerm:  "++showADL (rCombinator s)++
+                  "\ndiffers from subs term:       "++showADL original
+                 )
+     ] ++
+     [ DStep { lhs = rCombinator s -- is equal to: (pre \/ lhs dstep)
+             , rul = rul dstep
+             , rhs = flatSet (pre++rhs dstep:post)
+             }
+     | (pre,l,post) <- splitList (Set.toList s)
+     , dstep <- dStps l]
+     where partsplus :: Ord a => Int -> Set a -> [(Set (Set a), Set a)]
+           partsplus n ss = [ (p,Set.empty) | p<-parts n ss ] ++ [ (Set.delete p prt, p) | prt<-parts (n+1) ss, p<-Set.toList prt ]
+           flatSet :: [RTerm] -> RTerm
+           flatSet = normRT . rCombinator . Set.fromList . flat isrComb
+
+  matchableRules :: [(RTerm,[RTerm])]
+  matchableRules
+   = [ (template, rewriteTerms )     -- each tuple may represent multiple rules.
+     | cl<-eqCl lTerm (concatMap f drs)  -- divide into classes to save a little on the number of matches.
+     , let template = lTerm (head cl)   -- This is the template against which to match full expressions.
+     , let rewriteTerms = stepTerms template cl
+     , not (null rewriteTerms)
+     ]
+     where f (DEquR l r) = [DImpR l r, DImpR r l]
+           f implication = [implication]
+           stepTerms :: RTerm -> [DerivRule] -> [RTerm]
+           stepTerms template cl  -- Only select rules with bindings within the template. Otherwise, we would have to "invent" bindings.
+            = [term' | rule<-cl, let term' = rTerm rule, vars term' `Set.isSubsetOf` vars template ]
+
+{-
+     showMatchableRules :: [(RTerm,[RTerm])] -> String
+     showMatchableRules rs
+      = concat ["\n   "++showADL l++" = "++showADL t | (l,tms) <- rs, t<-tms ]
+-}
+
+splitList :: [a] -> [([a],a,[a])]
+splitList lst = [(take i lst,l,drop (i+1) lst) | (i,l) <- zip [0..] lst]
+
+instance Association RTerm where
+  sign (RIsc a)      = sign$ Set.findMin a
+  sign (RUni a)      = sign$ Set.findMin a
+  sign (RDif a _)    = sign a
+  sign (RCpl a)      = sign a
+  sign (RDia a b)    = Sign (source a) (target b)
+  sign (RLrs a b)    = Sign (source a) (source b)
+  sign (RRrs a b)    = Sign (target a) (target b)
+  sign (RRad as)     = Sign (source (head as)) (target (last as))
+  sign (RCps as)     = Sign (source (head as)) (target (last as))
+  sign (RPrd as)     = Sign (source (head as)) (target (last as))
+  sign (RKl0 a)      = sign a
+  sign (RKl1 a)      = sign a
+  sign (RFlp a)      = Sign (target a) (source a)
+  sign (RId  a)      = Sign a a
+  sign (RVee a b)    = Sign a b
+  sign (RAtm _ b)    = Sign b b
+  sign (RVar _ _ _)  = fatal 324 "Cannot determine the sign of an RVar." -- This should become a haskell type-error when RTerm is polymorphic
+  sign (RConst e)    = sign e
+
+-- In order to write deriviation rules in the Ampersand syntax, RTerms are obtained by means of the (already available) Ampersand parser.
+-- For that reason, we need a function term2rTerm to translate a term obtained by parsing (type: Term TermPrim) to a RTerm.
+term2rTerm :: Term TermPrim -> RTerm
+term2rTerm term
+   = if isValid result then result else fatal 385 ("term2rTerm has produced an invalid result: "++showADL result)
+     where
+      result
+       = case term of
+           PEqu o l r               -> term2rTerm (PIsc o (PImp o l r) (PImp o r l))
+           PImp o l r               -> term2rTerm (PUni o (PCpl o l) r)
+           PIsc _ l r               -> combSet RIsc (lSet `Set.union` rSet)
+                                       where lSet = case term2rTerm l of
+                                                      RIsc terms -> terms
+                                                      trm        -> Set.singleton trm
+                                             rSet = case term2rTerm r of
+                                                      RIsc terms -> terms
+                                                      trm        -> Set.singleton trm
+           PUni _ l r               -> combSet RUni (lSet `Set.union` rSet)
+                                       where lSet = case term2rTerm l of
+                                                      RUni terms -> terms
+                                                      trm        -> Set.singleton trm
+                                             rSet = case term2rTerm r of
+                                                      RUni terms -> terms
+                                                      trm        -> Set.singleton trm
+           PDif _ l r               -> RDif (term2rTerm l) (term2rTerm r)
+           PCpl _ e                 -> RCpl (term2rTerm e)
+           PDia _ l r               -> RDia (term2rTerm l) (term2rTerm r)
+           PLrs _ l r               -> RLrs (term2rTerm l) (term2rTerm r)
+           PRrs _ l r               -> RRrs (term2rTerm l) (term2rTerm r)
+           PRad _ l r               -> RRad (lLst++rLst)
+                                       where lLst = case term2rTerm l of
+                                                      RRad terms -> terms
+                                                      trm        -> [trm]
+                                             rLst = case term2rTerm r of
+                                                      RRad terms -> terms
+                                                      trm        -> [trm]
+           PCps _ l r               -> RCps (lLst++rLst)
+                                       where lLst = case term2rTerm l of
+                                                      RCps terms -> terms
+                                                      trm        -> [trm]
+                                             rLst = case term2rTerm r of
+                                                      RCps terms -> terms
+                                                      trm        -> [trm]
+           PPrd _ l r               -> RPrd (lLst++rLst)
+                                       where lLst = case term2rTerm l of
+                                                      RPrd terms -> terms
+                                                      trm        -> [trm]
+                                             rLst = case term2rTerm r of
+                                                      RPrd terms -> terms
+                                                      trm        -> [trm]
+           PKl0 _ e                 -> RKl0 (term2rTerm e)
+           PKl1 _ e                 -> RKl1 (term2rTerm e)
+           PFlp _ e                 -> RFlp (term2rTerm e)
+           PBrk _ e                 -> term2rTerm e
+           Prim (PNamedR (PNamedRel _ str (Just sgn))) -> RVar str (name (pSrc sgn)) (name (pTgt sgn))
+           Prim (Pid _ c)           -> RId  (pCpt2aCpt c)
+           Prim (Pfull _ s t)       -> RVee (pCpt2aCpt s) (pCpt2aCpt t)
+           Prim (Patm _ a (Just c)) -> RAtm a (pCpt2aCpt c)
+           _                        -> fatal 381 ("Cannot cope with untyped "++showADL term++" in a dRule inside the normalizer.")
+
+expr2RTerm :: Expression -> RTerm
+expr2RTerm expr
+   = if isValid result then result else fatal 443 ("expr2RTerm has produced an invalid result: "++showADL result)
+     where
+      result
+       = case expr of
+          EEqu (l,r)           -> expr2RTerm (EIsc (EImp (l,r), EImp (r,l)))
+          EImp (l,r)           -> expr2RTerm (EUni (ECpl l, r))
+          EIsc (l,r)           -> combSet RIsc (lSet `Set.union` rSet)
+                                  where lSet = case expr2RTerm l of
+                                                 RIsc terms -> terms
+                                                 trm        -> Set.singleton trm
+                                        rSet = case expr2RTerm r of
+                                                 RIsc terms -> terms
+                                                 trm        -> Set.singleton trm
+          EUni (l,r)           -> combSet RUni (lSet `Set.union` rSet)
+                                  where lSet = case expr2RTerm l of
+                                                 RUni terms -> terms
+                                                 trm        -> Set.singleton trm
+                                        rSet = case expr2RTerm r of
+                                                 RUni terms -> terms
+                                                 trm        -> Set.singleton trm
+          EDif (l,r)           -> RDif (expr2RTerm l) (expr2RTerm r)
+          ECpl e               -> RCpl (expr2RTerm e)
+          EDia (l,r)           -> RDia (expr2RTerm l) (expr2RTerm r)
+          ELrs (l,r)           -> RLrs (expr2RTerm l) (expr2RTerm r)
+          ERrs (l,r)           -> RRrs (expr2RTerm l) (expr2RTerm r)
+          ERad (l,r)           -> RRad (lLst++rLst)
+                                  where lLst = case expr2RTerm l of
+                                                 RRad terms -> terms
+                                                 trm        -> [trm]
+                                        rLst = case expr2RTerm r of
+                                                 RRad terms -> terms
+                                                 trm        -> [trm]
+          ECps (l,r)           -> RCps (lLst++rLst)
+                                  where lLst = case expr2RTerm l of
+                                                 RCps terms -> terms
+                                                 trm        -> [trm]
+                                        rLst = case expr2RTerm r of
+                                                 RCps terms -> terms
+                                                 trm        -> [trm]
+          EPrd (l,r)           -> RPrd (lLst++rLst)
+                                  where lLst = case expr2RTerm l of
+                                                 RPrd terms -> terms
+                                                 trm        -> [trm]
+                                        rLst = case expr2RTerm r of
+                                                 RPrd terms -> terms
+                                                 trm        -> [trm]
+          EKl0 e               -> RKl0 (expr2RTerm e)
+          EKl1 e               -> RKl1 (expr2RTerm e)
+          EFlp e               -> RFlp (expr2RTerm e)
+          EBrk e               -> expr2RTerm e
+          EDcD{}               -> RConst expr
+          EDcI c               -> RId c
+          EEps{}               -> RConst expr
+          EDcV sgn             -> RVee (source sgn) (target sgn)
+          EMp1 a c             -> RAtm a c
+--   --      _                    -> RConst expr   -- This alternative has been commented out to avoid an "overlapping patterns" warning from Haskell.
+
+rTerm2expr :: RTerm -> Expression
+-- implementation note: because RTerms contain variables, it is cumbersome to reconstruct the type. So we don't.
+-- Once the variables have been replaced (by means of substitutions) by real expressions, we get a type correct expression again.
+-- As a consequence, we cannot use ./\., .\/., etc. in this code.
+rTerm2expr term
+ = case term of
+     RIsc rs    -> case Set.toList (Set.map rTerm2expr rs) of
+                    [e] -> e
+                    []  -> fatal 445 "empty set in RIsc is illegal."
+                    es  -> let oper l r = EIsc (l,r) in foldr1 oper es
+     RUni rs    -> case Set.toList (Set.map rTerm2expr rs) of
+                    [e] -> e
+                    []  -> fatal 449 "empty set in RUni is illegal."
+                    es  -> let oper l r = EUni (l,r) in foldr1 oper es
+     RDif l r   -> EDif (rTerm2expr l, rTerm2expr r)
+     RCpl e     -> ECpl (rTerm2expr e)
+     RDia l r   -> EDia (rTerm2expr l, rTerm2expr r)
+     RLrs l r   -> ELrs (rTerm2expr l, rTerm2expr r)
+     RRrs l r   -> ERrs (rTerm2expr l, rTerm2expr r)
+     RRad rs    -> case map rTerm2expr rs of
+                    [e] -> e
+                    []  -> fatal 458 "empty set in RRad is illegal."
+                    es  -> let oper l r = ERad (l,r) in foldr1 oper es
+     RCps rs    -> case map rTerm2expr rs of
+                    [e] -> e
+                    []  -> fatal 462 "empty set in RCps is illegal."
+                    es  -> let oper l r = ECps (l,r) in foldr1 oper es
+     RPrd rs    -> case map rTerm2expr rs of
+                    [e] -> e
+                    []  -> fatal 466 "empty set in RPrd is illegal."
+                    es  -> let oper l r = EPrd (l,r) in foldr1 oper es
+     RKl0 e     -> EKl0$ rTerm2expr e
+     RKl1 e     -> EKl1$ rTerm2expr e
+     RFlp e     -> EFlp$ rTerm2expr e
+     RVar r s t -> EDcD (makeDecl r (Sign (makeConcept s) (makeConcept t)))
+     RId  c     -> EDcI c
+     RVee s t   -> EDcV (Sign s t)
+     RAtm a c   -> EMp1 a c
+     RConst e   -> e
+   where
+     makeDecl nm sgn
+      = Sgn { decnm   = nm
+            , decsgn  = sgn
+            , decprps = fatal 480 "Illegal RTerm in rTerm2expr"
+            , decprps_calc = Nothing
+            , decprL  = fatal 482 "Illegal RTerm in rTerm2expr"
+            , decprM  = fatal 483 "Illegal RTerm in rTerm2expr"
+            , decprR  = fatal 484 "Illegal RTerm in rTerm2expr"
+            , decMean = fatal 485 "Illegal RTerm in rTerm2expr"
+            , decfpos = fatal 486 "Illegal RTerm in rTerm2expr"
+            , deciss  = fatal 487 "Illegal RTerm in rTerm2expr"
+            , decusr  = fatal 488 "Illegal RTerm in rTerm2expr"
+            , decpat  = fatal 489 "Illegal RTerm in rTerm2expr"
+            , decplug = fatal 490 "Illegal RTerm in rTerm2expr"
+            }
+     makeConcept "ONE" = ONE
+     makeConcept  str  = 
+        PlainConcept { cptnm = str
+                     }
+
+instance ShowADL RTerm where
+ showADL = showExpr 0
+   where
+     (   inter,   union',  diff,  lresi, rresi,  rDia,   rMul,rAdd,rPrd,closK0,closK1,flp',compl,   lpar, rpar, lbr, star,  rbr)
+      = (" /\\ ", " \\/ ", " - ", " / ", " \\ ", " <> ", ";", "!", "*", "*"  , "+",   "~", ("-"++), "(",  ")",  "[", "*",   "]")
+     showExpr :: Int -> RTerm -> String
+     showExpr i expr
+      = case expr of
+          RIsc ls    -> wrap i 2 (intercalate inter  [showExpr 3 e | e<-Set.toList ls ])
+          RUni ls    -> wrap i 2 (intercalate union' [showExpr 3 e | e<-Set.toList ls ])
+          RDif l r   -> wrap i 4 (showExpr 5 l++diff++showExpr 5 r)
+          RLrs l r   -> wrap i 6 (showExpr 7 l++lresi++showExpr 7 r)
+          RRrs l r   -> wrap i 6 (showExpr 7 l++rresi++showExpr 7 r)
+          RDia l r   -> wrap i 6 (showExpr 7 l++rDia ++showExpr 7 r)
+          RCps ls    -> wrap i 2 (intercalate rMul [showExpr 3 e | e<-ls ])
+          RRad ls    -> wrap i 2 (intercalate rAdd [showExpr 3 e | e<-ls ])
+          RPrd ls    -> wrap i 2 (intercalate rPrd [showExpr 3 e | e<-ls ])
+          RKl0 e     -> wrap i 9 (showExpr 9 e++closK0)
+          RKl1 e     -> wrap i 9 (showExpr 9 e++closK1)
+          RFlp e     -> wrap i 9 (showExpr 9 e++flp')
+          RCpl e     -> wrap i 9 (compl (showExpr 10 e))
+          RVar r s t -> r++lbr++s++star++t++rbr
+          RConst e   -> wrap i i (showADL e)
+          RId c      -> "I"++lbr++name c++rbr
+          RVee s t   -> "V"++lbr++name s++star++name t++rbr
+          RAtm a c   -> "'"++a++"'"++lbr++name c++rbr
+     wrap :: Int -> Int -> String -> String
+     wrap i j e' = if i<=j then e' else lpar++e'++rpar
+
+{- momentarily redundant
+   unVar :: RTerm -> String
+   unVar (RVar r _ _) = r
+   unVar _ = fatal 501 "Illegal call on unVar"
+-}
+
+vars :: RTerm -> Set String
+vars (RIsc rs)     = (Set.unions . map vars . Set.toList) rs
+vars (RUni rs)     = (Set.unions . map vars . Set.toList) rs
+vars (RDif l r)    = vars l `Set.union` vars r
+vars (RCpl e)      = vars e
+vars (RDia l r)    = vars l `Set.union` vars r
+vars (RLrs l r)    = vars l `Set.union` vars r
+vars (RRrs l r)    = vars l `Set.union` vars r
+vars (RRad rs)     = foldr Set.union Set.empty (map vars rs)
+vars (RCps rs)     = foldr Set.union Set.empty (map vars rs)
+vars (RPrd rs)     = foldr Set.union Set.empty (map vars rs)
+vars (RKl0 e)      = vars e
+vars (RKl1 e)      = vars e
+vars (RFlp e)      = vars e
+vars (RId  c)      = Set.fromList [name c]
+vars (RVee s t)    = Set.fromList [name s, name t]
+vars (RVar r s t)  = Set.fromList [r, s, t]
+vars (RConst{})    = Set.empty
+vars  RAtm{}       = Set.empty
+
+data DerivRule = DEquR { lTerm :: RTerm
+                       , rTerm :: RTerm
+                       }
+               | DImpR { lTerm :: RTerm
+                       , rTerm :: RTerm
+                       }
+
+instance Show DerivRule where
+  showsPrec _ r@DEquR{}  = showString (showADL (lTerm r)++" = " ++showADL (rTerm r))
+  showsPrec _ r@DImpR{}  = showString (showADL (lTerm r)++" |- "++showADL (rTerm r))
+
+-- For documentation purposes, the derivation rule which proves the step is included.
+
+data DerivStep = DStep { lhs :: RTerm
+                       , rul :: (RTerm,Unifier,RTerm)
+                       , rhs :: RTerm
+                       }
+
+-- instance Show DerivStep where
+--  showsPrec _ r@DStep{}  = showString ("    "++showADL (lhs r)++"\n =  {" ++show (rul r)++"}\n    " ++showADL (rhs r))
+
+
+
+dRule :: Term TermPrim -> [DerivRule]
+dRule (PEqu _ l r) = [DEquR { lTerm=term2rTerm l, rTerm=term2rTerm r }]
+dRule (PImp _ l r) = [DImpR { lTerm=term2rTerm l, rTerm=term2rTerm r }]
+dRule term         = fatal 279 ("Illegal use of dRule with term "++show term)
+
+slideDown :: (RTerm -> Integer) -> RTerm -> [(Integer,DerivStep)]
+slideDown weight term
+ = let w = weight term in
+   case [dstep | dstep<-dSteps tceDerivRules term, weight (rhs dstep)<w] of
+     dstep: _ -> (w,dstep): (slideDown weight) (rhs dstep)
+     _        -> []
+
+weightNF :: Bool -> RTerm -> Integer
+weightNF dnf term = w term
+ where
+  w :: RTerm -> Integer
+  w trm
+   = case trm of
+       RIsc ls  -> (sum (map w (Set.toList ls))) * if dnf then 1 else 2
+       RUni ls  -> (sum (map w (Set.toList ls))) * if dnf then 2 else 1
+       RDif l r -> (w l+w r+10) * 4
+       RCpl e   -> (w e + 1) * 4
+       RDia l r -> (w l+w r+10) * 4
+       RLrs l r -> (w l+w r+10) * 4
+       RRrs l r -> (w l+w r+10) * 4
+       RRad ls  -> (sum (map w ls)+1)*4
+       RCps ls  -> (sum (map w ls)+1)*4
+       RPrd ls  -> (sum (map w ls)+1)*4
+       RKl0 e   -> (w e + 1) * 4
+       RKl1 e   -> (w e + 1) * 4
+       RFlp e   -> (w e + 1) * 8
+       _        -> 1
+
+-- If  'matches d expr'  yields  'Just ss', then  'substitute anything ss (lTerm d) == expr'
+
+type Unifier = Set (String, RTerm)
+
+instance ShowADL Unifier where
+  showADL s = "{"++intercalate ", " [ str++"->"++showADL t | (str,t)<-Set.toList s ]++"}"
+
+substitute :: String    -- A string to document fatals
+           -> Unifier   -- the substitution, which in reality is a set of string/expression pairs.
+           -> RTerm     -- The term to be transformed to an expression, with all variables replaced by subexpressions
+           -> RTerm
+substitute ruleDoc unifier term
+ = if isValid result then result else fatal 713 ("substitute has produced an invalid result: "++showADL result)
+   where
+    result = subs term
+    subs :: RTerm -> RTerm
+    subs t | not (isValid t) = fatal 680 ("Substituting an invalid term "++showADL t)
+    subs (RIsc s)     = (combSet RIsc . Set.fromList . flat isRIsc . map subs . Set.toList) s
+    subs (RUni s)     = (combSet RUni . Set.fromList . flat isRUni . map subs . Set.toList) s
+    subs (RDif l r)   = RDif (subs l) (subs r)
+    subs (RLrs l r)   = RLrs (subs l) (subs r)
+    subs (RRrs l r)   = RRrs (subs l) (subs r)
+    subs (RDia l r)   = RDia (subs l) (subs r)
+    subs (RCps ls)    = (RCps . flat isRCps . map subs) ls
+    subs (RRad ls)    = (RRad . flat isRRad . map subs) ls
+    subs (RPrd ls)    = (RPrd . flat isRPrd . map subs) ls
+    subs (RKl0 e  )   = RKl0 (subs e)
+    subs (RKl1 e  )   = RKl1 (subs e)
+    subs (RFlp e  )   = RFlp (subs e)
+    subs (RCpl e  )   = RCpl (subs e)
+    subs (RVar r _ _) = case [ e | (v,e)<-Set.toList unifier, v==r] of
+                           [e] -> e
+                           [] ->  fatal 378 ("Rule:  "++ruleDoc++"\nVariable "++r++" is not in term "++showADL term++ " using unifier "++show unifier)
+                           -- e.g. Variable r is not in term -V[A*B] /\ r[A*B] using unifier fromList [("A",RId Verzoek),("B",RId Persoon)]
+                           es ->  fatal 379 ("Rule:  "++ruleDoc++"\nVariable "++r++" in term "++showADL term++" has been bound to multiple expressions:\n   "++intercalate "\n   " [showADL e | e<-es])
+    subs (RId c)      = case [ e | (v,e)<-Set.toList unifier, v==name c] of
+                           [e] -> e  -- This is e@(RId c')
+                           []  -> fatal 382 ("Rule:  "++ruleDoc++"\nVariable "++name c++" is not in term "++showADL term)
+                           es  -> fatal 383 ("Rule:  "++ruleDoc++"\nVariable "++name c++" in term "++showADL term++" has been bound to multiple expressions:\n   "++intercalate "\n   " [showADL e | e<-es])
+    subs (RVee s t)   = case ([ e | (v,e)<-Set.toList unifier, v==name s], [ e | (v,e)<-Set.toList unifier, v==name t]) of
+                           ([RId s'], [RId t']) -> RVee s' t'
+                           (_,_)  -> fatal 386 ("Rule:  "++ruleDoc++"\nSomething wrong with RVee in term "++showADL term++" with unifier "++show unifier)
+    subs (RAtm a c)   = case [ e | (v,e)<-Set.toList unifier, v==name c] of
+                           [RId c'] -> RAtm a c'
+                           []  -> fatal 389 ("Rule:  "++ruleDoc++"\nVariable "++name c++" is not in term "++showADL term)
+                           es  -> fatal 390 ("Rule:  "++ruleDoc++"\nVariable "++name c++" in term "++showADL term++" has been bound to multiple expressions:\n   "++intercalate "\n   " [showADL e | e<-es])
+    subs e@RConst{}   = e
+--     subs t            = fatal 392 ("Rule:  "++ruleDoc++"\nError: "++showADL t++"is not a variable.")  -- commented out, because it causes Haskell to emit an overlapping pattern warning.
+
+flat :: (RTerm -> Bool) -> [RTerm] -> [RTerm]
+flat isrComb ls
+ = case ls of
+    []  -> fatal 689 "Illegal empty list"
+    es  -> concat [ if isrComb e then rTermListForSets e else [e] | e<-es]
+--     es  -> if or [isrComb e | e<-es]   -- SJ: Apparently, the recursion in 'flat' is required. Without it, Misc/Kernmodel.adl did fail on 18 aug 2014.
+--            then (flat isrComb . concat) [ if isrComb e then rTermListForSets e else [e] | e<-es]
+--            else es
+rTermListForSets :: RTerm -> [RTerm]
+rTermListForSets (RIsc s) = Set.toList s
+rTermListForSets (RUni s) = Set.toList s
+rTermListForSets x = rTermList x
+
+matches :: RTerm -> RTerm -> [Unifier]
+matches term expr
+  = if not (isValid term) then fatal 719 ("Invalid term "++showADL term++"\nbeing matched to expression "++showADL expr) else
+    if not (isValid expr) then fatal 720 ("Matching term "++showADL term++"\nto invalid expression "++showADL expr) else
+    case (term,expr) of
+     (RIsc es,        RIsc es')   -> matchSets RIsc es es'
+     (RUni es,        RUni es')   -> matchSets RUni es es'
+     (RDif l r,       RDif l' r') -> matches l l' ++ matches r r'
+     (RLrs l r,       RLrs l' r') -> matches l l' ++ matches r r'
+     (RRrs l r,       RRrs l' r') -> matches l l' ++ matches r r'
+     (RDia l r,       RDia l' r') -> matches l l' ++ matches r r'
+     (RCps ls,        RCps ls')   -> matchLists RCps ls ls'
+     (RRad ls,        RRad ls')   -> matchLists RRad ls ls'
+     (RPrd ls,        RPrd ls')   -> matchLists RPrd ls ls'
+     (RKl0 e,         RKl0 e')    -> matches e e'
+     (RKl1 e,         RKl1 e')    -> matches e e'
+     (RFlp e,         RFlp e')    -> matches e e'
+     (RCpl e,         RCpl e')    -> matches e e'
+     (RId  c,         RId _     ) -> [Set.fromList [(name c,expr)]]
+     (RVee s t,       RVee s' t') -> [Set.fromList [(name s,RId s'), (name t,RId t')]]
+     (RVar v s t,     _         ) -> [Set.fromList [(v,expr),(s,RId (source expr)),(t,RId (target expr))]]
+     (RAtm a c,       RAtm a' c') -> [Set.singleton (name c,RId c') | a==a']
+     (RConst e,       RConst e' ) -> [Set.empty | e==e']
+     (_, _)                       -> []
+
+matchLists :: ([RTerm] -> RTerm) -> [RTerm] -> [RTerm] -> [Unifier]
+matchLists rCombinator es es'
+ = if not (isValid (combLst rCombinator es) ) then fatal 754 ("Invalid term " ++showADL (rCombinator es)++"\nbeing matched to expression "++showADL (rCombinator es')) else
+   if not (isValid (combLst rCombinator es')) then fatal 755 ("Matching term "++showADL (rCombinator es)++"\nto invalid expression " ++showADL (rCombinator es')) else
+   [ unif
+   | let n = length es              -- the length of the template, which contains variables
+   , if n==0 then fatal 681 "n equals 0" else True
+   , ms <- dist n es'     -- determine segments from es' (which is variable free) that have the same length as the template es
+   , if or [null m | m<-ms]
+     then fatal 683 (concat ["\nms:  ["++intercalate ", " (map showADL m)++"]" | m<-ms])
+     else True
+   , let subTerms = map (combLst rCombinator) ms     -- make an RTerm from each sublist in ms
+   , unif<-mix [ matches l r | (l,r)<-safezip es subTerms ]
+   , noDoubles unif                 -- if one variable, v, is bound to more than one different expressions, the deal is off.
+   ]
+   where
+     dist :: Int -> [a] -> [[[a]]]
+     dist 1 ls = [[ls]]
+     dist 2 ls = [ [ take i ls , drop i ls ] | i<-[1..length ls-1] ]
+     dist n ls = [ init ds++st | ds<-dist (n-1) ls, let staart=last ds, length staart>=2, st<-dist 2 staart ]
+     {- examples:
+     dist 1 "abcd" = [["abcd"]]
+     dist 2 "abcd" = [["a","bcd"],["ab","cd"],["abc","d"]]
+     dist 3 "abcd" = [["a","b","cd"],["a","bc","d"],["ab","c","d"]]
+     dist 3 "abcdef" =
+        [ ["a","b","cdef"]
+        , ["a","bc","def"]
+        , ["a","bcd","ef"]
+        , ["a","bcde","f"]
+        , ["ab","c","def"]
+        , ["ab","cd","ef"]
+        , ["ab","cde","f"]
+        , ["abc","d","ef"]
+        , ["abc","de","f"]
+        , ["abcd","e","f"]
+        ]
+     -}
+mix :: [[Unifier]] -> [Unifier]
+mix (ls:lss) = [ Set.union e str | e<-ls, str<-mix lss ]
+mix []       = [Set.empty]
+{- example:
+   mix ["12","xyz","","p"] = [] -- (because the fourth element did not match!)
+   mix ["12","xyz","p"]    = ["1xp","1yp","1zp","2xp","2yp","2zp"]
+-}
+matchSets :: (Set RTerm -> RTerm) -> Set RTerm -> Set RTerm -> [Unifier]
+matchSets rCombinator es es'
+ = -- set sizes are not necessarily equal.
+   if Set.null es || Set.null es' then fatal 858 "cannot match empty sets" else
+   if or [ not (isValid e) | e<-Set.toList es ] then fatal 859 ("Invalid subterm(s): "++intercalate ", " [ showADL e | e<-Set.toList es,  not (isValid e) ]) else
+   if or [ not (isValid e) | e<-Set.toList es'] then fatal 860 ("Invalid subexpr(s): "++intercalate ", " [ showADL e | e<-Set.toList es', not (isValid e) ]) else
+   [ unif
+   | let n = Set.size cdes                      -- the length of the template, which contains variables
+   , partition <- parts n cdes'                 -- determine segments from the expression with the same length. partition :: Set (Set RTerm)
+   , let subTerms = Set.map (combSet rCombinator) partition      -- make an RTerm from each subset in ms. subTerms :: Set RTerm
+   , template <- permutations (Set.toList cdes)
+   , unif <- mix [ matches l r | (l,r) <- safezip template (Set.toList subTerms) ]
+   , noDoubles unif                 -- if one variable, v, is bound to more than one different expressions, the deal is off.
+   ]
+   where
+     isct  = es `Set.intersection` es'            -- E.g.:  {'Piet'}
+     cdes  = es  `Set.difference` isct            -- the terms of es that are not in es' (a set of templates). E.g.: { r;s }
+     cdes' = es' `Set.difference` isct            -- candidates for binding to a variable: { a\b , a;b;c , d , e;f }  (a set of expressions)
+
+separate :: Ord a => Int -> Set a -> [(Set a, Set a)]
+separate n s = [ (part, s `Set.difference` part) | part <- subsetLength n (Set.toList s) ]
+ where
+   subsetLength :: Ord a => Int -> [a] -> [Set a]
+   subsetLength 0 _      = [Set.empty]
+   subsetLength i (x:xs) = map (Set.insert x) (subsetLength (i-1) xs) ++ subsetLength i xs
+   subsetLength _ []     = []
+
+ -- parts produces a fixed number of subsets
+parts :: Ord a => Int -> Set a -> [Set (Set a)]  -- ,   but within this where clause we must make it more specific.
+parts n xsss = (Set.toList . Set.fromList . map Set.fromList . map (map Set.fromList) . p n . Set.toList) xsss
+ where
+   p :: Eq a => Int -> [a] -> [[[a]]]
+   p 0 _  = []
+   p 1 xs = [ [xs] ]
+   p 2 xs = [ [ss,rest] | ss<-init (subsets xs), let rest=[ e | e<-xs, e `notElem` ss ], not (null rest) ]
+   p i xs = [ twoSets++tl | (hd:tl)<-p (i-1) xs, twoSets<-p 2 hd ]
+{- examples:
+   parts 1 "abcd" = {{"abcd"}}
+   parts 2 "abcd" = {{"a","bcd"},{"ab","cd"},{"abc","d"},{"abd","c"},{"ac","bd"},{"acd","b"},{"ad","bc"}}
+   parts 3 "abcd" = {{"a","b","cd"},{"a","bc","d"},{"a","bd","c"},{"ab","c","d"},{"ac","b","d"},{"ad","b","c"}}
+   parts 4 "abcd" = {{"a","b","c","d"}}
+   parts 3 "abcde"
+    = { {"a","b","cde"},{"a","bc","de"},{"a","bcd","e"},{"a","bce","d"},{"a","bd","ce"},{"a","bde","c"}
+      , {"a","be","cd"},{"ab","c","de"},{"ab","cd","e"},{"ab","ce","d"},{"abc","d","e"},{"abd","c","e"}
+      , {"abe","c","d"},{"ac","b","de"},{"ac","bd","e"},{"ac","be","d"},{"acd","b","e"},{"ace","b","d"}
+      , {"ad","b","ce"},{"ad","bc","e"},{"ad","be","c"},{"ade","b","c"},{"ae","b","cd"},{"ae","bc","d"}
+      , {"ae","bd","c"}
+      }
+   parts 6 "abcde" = {}
+-}
+   subsets :: [a] -> [[a]]
+   subsets []  = [[]]
+   subsets (x:xs) = map (x:) (subsets xs) ++ subsets xs
+
+combLst :: ([RTerm] -> RTerm) -> [RTerm] -> RTerm
+combLst rCombinator es
+ = case es of
+        []  -> fatal 791 "Not allowed."
+        [e] -> e
+        _   -> rCombinator es
+
+combSet :: (Set RTerm -> RTerm) -> Set RTerm -> RTerm
+combSet rCombinator s
+ = case Set.toList s of
+        []  -> fatal 798 "Not allowed."
+        [e] -> e
+        _   -> rCombinator s
+
+-- Example: noDoubles { p->A;B, q->'Piet', p->'Z', r->A* } is False, because p binds two different expressions.
+noDoubles :: Unifier -> Bool
+noDoubles unif = and [ n==1 | n<-(map length . eqCl fst . Set.toList) unif ]
+
+safezip :: [a] -> [b] -> [(a,b)]
+safezip (a:as) (b:bs) = (a,b):safezip as bs
+safezip [] [] = []
+safezip _ _ = fatal 827 "Zip of two lists with different lengths!"
+
+{-
+   assignments {a,p} {2,3,4}
+=
+   { {(a,2), (p,3)}, {(a,2), (p,4)}, {(a,3), (p,4)}, {(a,3), (p,4)}, {(a,4), (p,4)}, {(a,4), (p,3)} }
+
+   assignments :: (Ord a, Ord b) => Set a -> Set b -> [Set (a,b)]
+   assignments xs ys = map Set.fromList (recur (Set.toList xs) (Set.toList ys))
+    where
+      recur [] _ = [[]]
+      recur (v:vs) es = [ (v,e):pairs | e<-es, pairs<-recur vs [e' | e'<-es, e'/=e ] ]
+
+-- The function 'names' exists for the purpose of hashing.
+   names :: RTerm -> [String]
+   names term = nub (nms term)
+    where nms trm = case trm of
+                        RIsc ls    -> (nub . concatMap nms . Set.toList) ls
+                        RUni ls    -> (nub . concatMap nms . Set.toList) ls
+                        RDif l r   -> nms l++nms r
+                        RLrs l r   -> nms l++nms r
+                        RRrs l r   -> nms l++nms r
+                        RDia l r   -> nms l++nms r
+                        RCps ls    -> (nub . concatMap nms) ls
+                        RRad ls    -> (nub . concatMap nms) ls
+                        RPrd ls    -> (nub . concatMap nms) ls
+                        RKl0 e     -> nms e
+                        RKl1 e     -> nms e
+                        RFlp e     -> nms e
+                        RCpl e     -> nms e
+                        RVar r s t -> [r++":"++s++"*"++t]
+                        RId c      -> ["I["++name c++"]"]
+                        RVee s t   -> ["V["++name s++"*"++name t++"]"]
+                        RAtm a c   -> ["'"++a++"'["++name c++"]"]
+                        RConst e   -> [showADL e]
+-}
+
+-- In order to write rules for the normalizer in a legible manner, I am using the Ampersand parser.
+-- The terminal symbols, except I and V, are interpreted as variables in these rules.
+-- As these rules may be used in two directions, all concept variables that are used on one side must be used on the other side as well.
+-- relation names r, s, q are used as relation variables and A, B, C are used as concept variables.
+-- If rules are ill formed, this will result in fatal errors.
+
+-- Type conserving equivalences: The following equivalences have an identical signature on either side.
+tceDerivRules :: [DerivRule]
+tceDerivRules = concatMap (dRule.parseRule)
+--    [ "r[A*B]\\/s[A*B] = s[A*B]\\/r[A*B]"                         --  Commutativity of \/
+--    , "r[A*B]/\\s[A*B] = s[A*B]/\\r[A*B]"                         --  Commutativity of /\
+--    , "(r[A*B]\\/s[A*B])\\/q[A*B] = r[A*B]\\/(s[A*B]\\/q[A*B])"   --  Associativity of \/
+--    , "(r[A*B]/\\s[A*B])/\\q[A*B] = r[A*B]/\\(s[A*B]/\\q[A*B])"   --  Associativity of /\
+--    , "(r[A*B];s[B*C]);q[C*D] = r[A*B];(s[B*C];q[C*D])"           --  Associativity of ;
+--    , "(r[A*B]#s[B*C])#q[C*D] = r[A*B]#(s[B*C]#q[C*D])"           --  Associativity of #
+--    , "(r[A*B]!s[B*C])!q[C*D] = r[A*B]!(s[B*C]!q[C*D])"           --  Associativity of !
+ [ "-(-r[A*B]) = r[A*B]"                                       --  Double negation
+ , "(r[A*B]~)~ = r[A*B]"                                       --  Double flip
+ , "-(r[A*B]~) = (-r[A*B])~"                                   --  Peirce's[A*A] trick, which allows us to write -r[A*A]~
+ , "-r[A*B]/\\-s[A*B] = -(r[A*B]\\/s[A*B])"                    --  De Morgan
+ , "-r[A*B]\\/-s[A*B] = -(r[A*B]/\\s[A*B])"                    --  De Morgan
+ , "-r[B*A];-s[A*C] = -(r[B*A]!s[A*C])"                        --  De Morgan
+ , "-r[B*A]!-s[A*C] = -(r[B*A];s[A*C])"                        --  De Morgan
+ , "r[A*B]~/\\s[A*B]~ = (r[A*B]/\\s[A*B])~"                    --  Distribute flip
+ , "r[A*B]~\\/s[A*B]~ = (r[A*B]\\/s[A*B])~"                    --  Distribute flip
+ , "(r[A*A]\\r[A*A]);(r[A*A]\\r[A*A]) = r[A*A]\\r[A*A]"        --  Jipsen&Tsinakis
+ , "(r[A*A]/r[A*A]);(r[A*A]/r[A*A]) = r[A*A]/r[A*A]"           --  Jipsen&Tsinakis
+ , "r[A*A];(r[A*A]\\r[A*A]) = r[A*A]"                          --  Jipsen&Tsinakis
+ , "(r[A*A]/r[A*A]);r[A*A] = r[A*A]"                           --  Jipsen&Tsinakis
+ , "I[A];r[A*B] = r[A*B]"
+ , "r[A*B];I[B] = r[A*B]"
+ , "(r[A*B]\\/s[A*B]);q[B*C] = r[A*B];q[B*C]\\/s[A*B];q[B*C]"  --  Distribution
+ , "r[A*B];(s[B*C]\\/q[B*C]) = r[A*B];s[B*C]\\/r[A*B];q[B*C]"  --  Distribution
+ , "-r[A*B]~!s[A*C] = r[A*B]\\s[A*C]"                          --  eliminate dagger
+ , "-r[A*B]!s[B*C] = r[A*B]~\\s[B*C]"                          --  eliminate dagger
+ , "r[A*C]!-s[B*C]~ = r[A*C]/s[B*C]"                           --  eliminate dagger
+ , "r[A*C]!-s[C*B] = r[A*C]/s[C*B]~"                           --  eliminate dagger
+--  , "r[A*B]#s[B*C]#q[C*D] = r[A*B]#q[C*D]"                      --  eliminate middle in cartesian product -- conditie toevoegen: s[A*B] /= -V
+ , "r[A*B]/\\r[A*B] = r[A*B]"                                  --  Absorb equals
+ , "r[A*B]\\/r[A*B] = r[A*B]"                                  --  Absorb equals
+ , "r[A*B]/\\V[A*B] = r[A*B]"                                  --  Absorb V
+ , "V[A*B]/\\r[A*B] = r[A*B]"                                  --  Absorb V
+ , "r[A*B]/\\-V[A*B] = -V[A*B]"                                --  Contradiction
+ , "-V[A*B]/\\r[A*B] = -V[A*B]"                                --  Contradiction
+ , "r[A*B]\\/V[A*B] = V[A*B]"                                  --  Tautology
+ , "r[A*B]\\/-V[A*B] = r[A*B]"                                 --  Absorb -V
+ , "r[A*B]/\\-r[A*B] = -V[A*B]"                                --  Contradiction
+ , "r[A*B]\\/-r[A*B] =  V[A*B]"                                --  Tautology
+ , "-r[A*B]\\/r[A*B] = V[A*B]"                                 --  Tautology
+ , "(r[A*B]\\/ s[A*B])/\\ s[A*B] = s[A*B]"                      --  Absorption
+ , "(r[A*B]\\/-s[A*B])/\\ s[A*B] = s[A*B]-r[A*B]"               --  Absorption
+ , "(r[A*B]/\\ s[A*B])\\/ s[A*B] = s[A*B]"                      --  Absorption
+ , "(r[A*B]/\\-s[A*B])\\/ s[A*B] = r[A*B]\\/s[A*B]"             --  Absorption
+ , "(r[A*B]/\\ s[A*B])\\/-s[A*B] = r[A*B]\\/-s[A*B]"            --  Absorption
+ , "r[A*A]* = r[A*A];r[A*A]*"
+ , "r[A*A]* = r[A*A]*;r[A*A]"
+ , "r[A*A]+ = r[A*A];r[A*A]+"
+ , "r[A*A]+ = r[A*A]+;r[A*A]"
+ , "I[A]\\/r[A*A]+ = r[A*A]*"
+ ]
+
+{-
+-- Type conserving implications: The following implications have an identical signature on either side.
+tciDerivRules :: [DerivRule]
+tciDerivRules = concatMap (dRule.parseRule)
+ [ "(r[A*B]\\I[A]);s[A*C] |- r[A*B]\\s[A*C]"                   --  T{r\\I[A]}=[B*A] ; T{(r\\I[A]);s}=[B*C] ; T{r\\s}=[B*C] ; Jipsen&Tsinakis
+ , "r[A*C];(I[C]/s[B*C]) |- r[A*C]/s[B*C]"                     --  Jipsen&Tsinakis
+ , "(r[A*B]\\s[A*C]);q[C*D] |- r[A*B]\\(s[A*C];q[C*D])"        --  Jipsen&Tsinakis
+ , "r[A*B];(s[B*C]/q[D*C]) |- (r[A*B];s[B*C])/q[D*C]"          --  Jipsen&Tsinakis
+ , "(r[A*B]\\s[A*C]);(s[A*C]\\q[A*D]) |- r[A*B]\\q[A*D]"       --  Jipsen&Tsinakis
+ , "(r[A*B]/s[A*C]);(s[A*C]/q[D*B]) |- r[A*B]/q[D*B]"          --  Jipsen&Tsinakis
+ , "r[A*B];(s[B*C]!q[C*D]) |- (r[A*B];s[B*C])!q[C*D]"          --  Peirce
+ , "(r[A*B]!s[B*C]);q[C*D] |- r[A*B]!(s[B*C];q[C*D])"          --  Peirce
+ , "(r[A*B]/\\s[A*B]);q[B*C] |- r[A*B];q[B*C]/\\s[A*B];q[B*C]" --  Distribution
+ , "r[A*B];(s[B*C]/\\q[B*C]) |- r[A*B];s[B*C]/\\r[A*B];q[B*C]" --  Distribution
+ , "(r[A*B];s[B*C])/s[B*C] |- r[A*B]"                          --  Absorption
+ , "r[A*B]\\(r[A*B];s[B*C]) |- s[B*C]"                         --  Absorption
+ , "I[A] |- r[A*A]*"
+ , "r[A*B] |- V[A*B]"
+ ]
+-}
+{-
+-- Type altering equivalences: The following equivalences have an different signature on either side.
+taeDerivRules :: [DerivRule]
+taeDerivRules = concatMap (dRule.parseRule)
+ [ "-r[A*B]\\/(q[A*C]/s[B*C]) = -(r[A*B];s[B*C])\\/q[A*C]"     -- T{ -r\\/(q/s)} = [A*B] ;   T{ -(r;s)\\/q} = [A*C] ; remove left residual (/)
+ , "(r[A*B]\\q[A*C])\\/-s[B*C] = -(r[A*B];s[B*C])\\/q[A*C]"    -- T{ (r\\q)\\/-s)} = [B*C] ; T{ -(r;s)\\/q} = [A*C] ; remove right residual (\\)
+ ]
+-}
+
+head :: [a] -> a
+head [] = fatal 30 "head must not be used on an empty list!"
+head (a:_) = a
+
+-- | This delta is meant to be used as a placeholder for inserting or removing links from expressions.
+delta :: Sign -> Expression
+delta sgn
+ = EDcD   Sgn { decnm   = "Delta"
+              , decsgn  = sgn
+              , decprps = []
+              , decprps_calc = Nothing
+              , decprL  = ""
+              , decprM  = ""
+              , decprR  = ""
+              , decMean = AMeaning [ --   A_Markup Dutch   ReST (string2Blocks ReST "Delta is bedoeld als variabele, die de plaats in een expressie vasthoudt waar paren worden ingevoegd of verwijderd.")
+                                     -- , A_Markup English ReST (string2Blocks ReST "Delta is meant as a variable, to be used as a placeholder for inserting or removing links from expressions.")
+                                   ]
+              , decfpos = Origin ("generated relation (Delta "++show sgn++")")
+              , deciss  = True
+              , decusr  = False
+              , decpat  = ""
+              , decplug = True
+              }
+
+{- Normalization of process algebra clauses -}
+
+normPA :: Options -> PAclause -> PAclause
+normPA opts pac = pac'
+    where (pac',_,_) = if null (proofPA opts pac) then fatal 21 "last: empty list" else last (proofPA opts pac)
+
+type Proof a = [(a, [String], String)]
+
+proofPA :: Options -> PAclause -> Proof PAclause
+proofPA opts = {-reverse.take 3.reverse.-}pPA
+ where pPA pac' = case normstepPA opts pac' of
+                    ( _ , []  ,equ) -> [(pac',[]   ,equ)]    -- is dus (pac,[],"<=>")
+                    (res,steps,equ) -> (pac',steps,equ):pPA res
+
+{- The following rewriter is used to simplify the actions inside eca rules.
+-- WHY? Stef, kan je uitleggen wat hier gebeurt? Enig commentaar is hier wel op zijn plaats.
+-- Ook zou het helpen om bij de verschillende constructoren van PAclause een beschrijving te geven van het idee er achter.
+-- BECAUSE! Kan ik wel uitleggen, maar het is een heel verhaal. Dat moet tzt in een wetenschappelijk artikel gebeuren, zodat het er goed staat.
+-- Het idee is dat een procesalgebra is weergegeven in Haskell combinatoren (gedefinieerd als PAclause(..), zie ADL.ECArule).
+-- Die kun je vervolgens normaliseren met herschrijfregels op basis van gelijkheden die gelden in de bewuste procesalgebra.
+-- Helaas zijn de herschrijfregels nu nog hard gecodeerd, zodat ik voor PAclause een afzonderlijke Haskell functie moet schrijven.
+-- Hierna volgt de normalisator voor relatiealgebra-expressies, genaamd normStep. Die heeft dezelfde structuur,
+-- maar gebruikt herschrijfregels vanuit gelijkheden die gelden in relatiealgebra.
+-}
+normstepPA :: Options -> PAclause -> (PAclause,[String],String)
+normstepPA opts pac = (res,ss,"<=>")
+ where
+  (res,ss) = norm pac
+  norm :: PAclause -> (PAclause,[String])
+  norm (CHC [] ms)  = (Blk ms, ["Run out of options"])
+  norm (CHC [r] ms) = (r', ["Flatten ONE"])
+                    where r' = case r of
+                                 Blk{} -> r
+                                 _     -> r{paMotiv = ms}
+  norm (CHC ds ms)  | (not.null) msgs = (CHC ops ms, msgs)
+                    | (not.null) [d | d<-ds, isCHC d] = (CHC (nub [ d' | d<-ds, d'<-if isCHC d then let CHC ops' _ = d in ops' else [d] ]) ms, ["flatten CHC"])  -- flatten
+                    | (not.null) [Nop | Nop{}<-ops] = (Nop{paMotiv=ms}, ["Choose to do nothing"])
+                    | (not.null) [Blk | Blk{}<-ops] = (CHC [op | op<-ops, not (isBlk op)] ms, ["Choose anything but block"])
+                    | (not.null) doubles = (CHC [ head cl | cl<-eqClass (==) ds ] ms, ["remove double occurrences"])
+                    | otherwise = (CHC ds ms, [])
+                    where nds  = map norm ds
+                          msgs = concatMap snd nds
+                          ops  = map fst nds
+                          doubles = [ d | cl<-eqClass (==) ds, length cl>1, d<-cl ]
+  norm (GCH [] ms)  = (Blk ms, ["Run out of options"])
+  norm (GCH ds ms)  | (not.null) [() | (_,links,_)<-normds, isFalse links] = (GCH [(tOp,links,p) | (tOp,links,p)<-normds, not (isFalse links)] ms, ["Remove provably empty guard(s)."])
+                    | (not.null) [()          | (_,  _    ,p)<-normds, isNop p]
+                        = (GCH [(tOp,links,p) | (tOp,links,p)<-normds, not (isNop p)] ms, ["Remove unneccessary SELECT."])
+                    | (not.null) doubles = (GCH [ (fst3 (head cl), foldr1 (.\/.) (map snd3 cl), thd3 (head cl)) | cl<-eqCl (\(tOp,_,p)->(tOp,p)) ds ] ms, ["remove double occurrences"])
+                    | otherwise = (GCH ds ms, [])
+                    where normds = [ (tOp, conjNF opts links, let (p',_)=norm p in p') | (tOp,links,p)<-ds]
+                          doubles = [ d | cl<-eqCl (\(tOp,_,p)->(tOp,p)) ds, length cl>1, d<-cl ]
+  norm (ALL [] ms)  = (Nop ms, ["ALL [] = No Operation"])
+  norm (ALL [d] ms) = (d', ["Flatten ONE"])
+                    where d' = case d of
+                                 Blk{} -> d
+                                 _     -> d{paMotiv = ms}
+  norm (ALL ds ms)  | (not.null) msgs = (ALL ops ms, msgs)
+                    | (not.null) [d | d<-ds, isAll d] = (ALL (nub [ d' | d<-ds, d'<-if isAll d then let ALL ops' _ = d in ops' else [d] ]) ms, ["flatten ALL"])  -- flatten
+                    | (not.null) [Blk | Blk{}<-ops] = (Blk{paMotiv = [m | op@Blk{}<-ops,m<-paMotiv op]}, ["Block all"])
+                    | (not.null) [Nop | Nop{}<-ops] = (ALL [op | op<-ops, not (isNop op)] ms, ["Ignore Nop"])
+                    | (not.null) doubles = (CHC [ head cl | cl<-eqClass (==) ds ] ms, ["remove double occurrences"])
+                    | (not.null) long    = (ALL ds' ms, ["Take the expressions for "++commaEng "and" [(name . paTo . head) cl |cl<-long]++"together"])
+                    | otherwise = (ALL ds ms, [])
+                    where ds'     = [ let p=head cl in
+                                        if length cl==1 then p else p{paDelta=disjNF opts (foldr1 (.\/.) [paDelta c | c<-cl]), paMotiv=concatMap paMotiv cl}
+                                    | cl<-dCls {- not (null cl) is guaranteed by eqCl -} ]
+                                    ++[d | d<-ds, not (isDo d)]
+                          nds     = map norm ds
+                          msgs    = concatMap snd nds
+                          ops     = map fst nds
+                          doubles = [ d | cl<-eqClass (==) ds, length cl>1, d<-cl ]
+                          dCls :: [[PAclause]]
+                          dCls = eqCl to [d | d<-ds, isDo d]
+                          long :: [[PAclause]]
+                          long = [cl | cl<-dCls, length cl>1]
+                          to d = case d of
+                                   Do{} -> (paSrt d, paTo d)
+                                   _    -> fatal 74 "illegal call of to(d)"
+  norm (New c p ms)        = ( case p' of
+                                Blk{} -> p'{paMotiv = ms}
+                                _     -> New c (\x->let (p'', _) = norm (p x) in p'') ms
+                             , msgs)
+                             where (p', msgs) = norm (p "x")
+  norm (Rmv c p ms)        = ( case p' of
+                                Blk{} -> p'{paMotiv = ms}
+                                _     -> Rmv c (\x->let (p'', _) = norm (p x) in p'') ms
+                             , msgs)
+                             where (p', msgs) = norm (p "x")
+  norm p                   = (p, [])
+
+{- Normalization of expressions -}
+
+simplify :: Expression -> Expression
+simplify expr = expr'
+    where (expr',_,_) = if null (simpProof shw expr) then fatal 101 "last: empty list" else last (simpProof shw expr)
+          shw _ = ""
+
+simpProof :: (Expression -> String) -> Expression -> Proof Expression
+simpProof shw expr
+ = if expr==res
+   then [(expr,[],"<=>")]
+   else (expr,steps,equ):simpProof shw res
+ where (res,steps,equ) = normStep shw True True True expr
+
+-- | The purpose of "normStep" is to elaborate a single step in a rewrite process,
+-- in which the expression is normalized by means of rewrite rules.
+-- This function can be used for simplification, which means that an Expression is standardized
+-- using associativity and other 'trivial' rules only.
+-- These 'trivial' rules do not produce a step in the proof.
+-- Use normstep shw eq True expr to do simplification only.
+-- Use normstep shw eq False expr to obtain a single proof step or none when no rule is applicable.
+-- This function returns a resulting expression that is closer to a normal form.
+-- The normal form is not unique. This function simply uses the first rewrite rule it encounters.
+normStep :: (Expression -> String) -> Bool -> Bool -> Bool ->
+            Expression -> (Expression,[String],String) -- This might be generalized to "Expression" if it weren't for the fact that flip is embedded in the Relation type.
+normStep shw   -- a function to print an expression. Might be "showADL"
+         eq    -- If eq==True, only equivalences are used. Otherwise, implications are used as well.
+         dnf   -- If dnf==True, the result is in disjunctive normal form, otherwise in conjunctive normal form
+         simpl -- If True, only simplification rules are used, which is a subset of all rules. Consequently, simplification is implied by normalization.
+         expr = if sign expr==sign res then (res,ss,equ) else
+                fatal 166 ("Violation of sign expr==sign res in the normalizer\n  expr: sign( "++showADL expr++" ) == "++showSign res++"\n  res:  sign( "++showADL res++" ) == "++showSign res)
+{-SJ 20140720: You might wonder why we test sign expr==sign res, which was introduced as a result of ticket #409 (the residu bug)
+It turns out that many rewrite rules in the normalizer change the type of an expression; an aspect I have been overlooking all the time.
+Until the new normalizer works, we will have to work with this one. So I have inserted this test to ensure that the type remains constant during normalization.
+-}
+ where
+  (res,ss,equ) = nM True expr []
+  nM :: Bool -> Expression -> [Expression] -> (Expression,[String],String)
+-- posCpl indicates whether the expression is positive under a complement. It is False when expr is inside a complemented expression.
+  nM posCpl (EEqu (l,r)) _     | simpl = (t .==. f, steps++steps', fEqu [equ',equ''])
+                                         where (t,steps, equ')  = nM posCpl l []  -- TODO: the use of posCpl is erroneous
+                                               (f,steps',equ'') = nM posCpl r []  -- TODO: the use of posCpl is erroneous
+  nM posCpl (EImp (l,r)) _     | simpl = (t .|-. f, steps++steps', fEqu [equ',equ''])
+                                         where (t,steps, equ')  = nM (not posCpl) l []
+                                               (f,steps',equ'') = nM posCpl r []
+  nM posCpl (EUni (EUni (l,k),r)) rs   = nM posCpl (l .\/. (k .\/. r)) rs  -- standardize, using associativity of .\/.
+  nM posCpl (EUni (l,r)) rs    | simpl = (t .\/. f, steps++steps', fEqu [equ',equ''])
+                                         where (t,steps, equ')  = nM posCpl l []
+                                               (f,steps',equ'') = nM posCpl r (l:rs)
+  nM posCpl (EIsc (EIsc (l,k),r)) rs   = nM posCpl (l ./\. (k ./\. r)) rs  -- standardize, using associativity of ./\.
+  nM posCpl (EIsc (l,r)) rs    | simpl = (t ./\. f, steps++steps', fEqu [equ',equ''])
+                                         where (t,steps, equ')  = nM posCpl l []
+                                               (f,steps',equ'') = nM posCpl r (l:rs)
+  nM posCpl (ECps (ECps (l,k),r)) rs   = nM posCpl (l .:. (k .:. r)) rs  -- standardize, using associativity of .:.
+                                             -- Note: function shiftL and shiftR make use of the fact that this normalizes to (l .:. (k .:. r))
+  nM posCpl (ECps (l,r)) rs    | simpl = (t .:. f, steps++steps', fEqu [equ',equ''])
+                                          where (t,steps, equ')  = nM posCpl l []
+                                                (f,steps',equ'') = nM posCpl r (l:rs)
+  nM posCpl (ELrs (l,r)) _     | simpl = (t ./. f, steps++steps', fEqu [equ',equ''])
+                                         where (t,steps, equ')  = nM posCpl l []
+                                               (f,steps',equ'') = nM (not posCpl) r []
+  nM posCpl (ERrs (l,r)) _     | simpl = (t .\. f, steps++steps', fEqu [equ',equ''])
+                                         where (t,steps, equ')  = nM (not posCpl) l []
+                                               (f,steps',equ'') = nM posCpl r []
+  nM posCpl (EDia (l,r)) _     | simpl = (t .<>. f, steps++steps', fEqu [equ',equ''])
+                                         where (t,steps, equ')  = nM posCpl l []  -- TODO: the use of posCpl is erroneous
+                                               (f,steps',equ'') = nM posCpl r []  -- TODO: the use of posCpl is erroneous
+  nM posCpl (ERad (ERad (l,k),r)) rs   = nM posCpl (l .!. (k .!. r)) rs  -- standardize, using associativity of .!.
+  nM posCpl (ERad (l,r)) rs    | simpl = (t .!. f, steps++steps', fEqu [equ',equ''])
+                                         where (t,steps, equ')    = nM posCpl l []
+                                               (f,steps',equ'')   = nM posCpl r (l:rs)
+  nM posCpl (EPrd (EPrd (l,k),r)) rs   = nM posCpl (l .*. (k .*. r)) rs  -- standardize, using associativity of .*.
+  nM posCpl (EPrd (l,r)) _     | simpl = (t .*. f, steps++steps', fEqu [equ',equ''])
+                                         where (t,steps, equ')  = nM posCpl l []
+                                               (f,steps',equ'') = nM posCpl r []
+  nM posCpl (EKl0 e)              _    = (EKl0 res', steps, equ')
+                                         where (res',steps,equ') = nM posCpl e []
+  nM posCpl (EKl1 e)              _    = (EKl1 res', steps, equ')
+                                         where (res',steps,equ') = nM posCpl e []
+  nM posCpl (ECpl (ECpl e))         rs = nM posCpl e rs
+  nM posCpl (ECpl e) _         | simpl = (notCpl res',steps,equ')
+                                         where (res',steps,equ') = nM (not posCpl) e []
+  nM posCpl (EBrk e)                _  = nM posCpl e []
+  nM posCpl (EFlp (ECpl e))         rs = nM posCpl (notCpl (flp e)) rs
+  nM _      x _                | simpl = (x,[],"<=>")
+-- up to here, simplification has been treated. The remaining rules can safely assume  simpl==False
+  nM _      (EEqu (l,r)) _                            = ((l .|-. r) ./\. (r .|-. l), ["remove ="],"<=>")
+  nM _      (EImp (x,r@(ELrs (z,y)))) _               = if sign x==sign z -- necessary to guarantee that sign expr is equal to sign of the result
+                                                        then (x .:. y .|-. z, ["remove left residual (/)"],"<=>")
+                                                        else (notCpl x .\/. r, ["remove |-"],"<=>")
+  nM _      (EImp (y,r@(ERrs (x,z)))) _               = if sign y==sign z -- necessary to guarantee that sign expr is equal to sign of the result
+                                                        then (x .:. y .|-. z, ["remove right residual (\\)"],"<=>")
+                                                        else (notCpl y .\/. r, ["remove |-"],"<=>")
+  nM _      (EImp (l,r)) _                            = (notCpl l .\/. r, ["remove |-"],"<=>")
+--   nM posCpl e@(ECpl EIsc{}) _           | posCpl==dnf = (deMorganEIsc e, ["De Morgan"], "<=>")
+--   nM posCpl e@(ECpl EUni{}) _           | posCpl/=dnf = (deMorganEUni e, ["De Morgan"], "<=>")
+  nM _      e@(ECpl EIsc{}) _                         = (deMorganEIsc e, ["De Morgan"], "<=>")
+  nM _      e@(ECpl EUni{}) _                         = (deMorganEUni e, ["De Morgan"], "<=>")
+  nM _      e@(ECpl (ERad (_,ECpl{}))) _              = (deMorganERad e, ["De Morgan"], "<=>")
+  nM _      e@(ECpl (ERad (ECpl{},_))) _              = (deMorganERad e, ["De Morgan"], "<=>")
+  nM _      e@(ECpl (ECps (ECpl{},ECpl{}))) _         = (deMorganECps e, ["De Morgan"], "<=>")
+  nM posCpl (ECpl e) _                                = (notCpl res',steps,equ')
+                                                        where (res',steps,equ') = nM (not posCpl) e []
+  nM _      (ECps (EEps c (Sign s _),EEps c' (Sign _  t'))) _ | c ==c' = (EEps c  (Sign s t'), [], "<=>")
+  nM _      (ECps (EEps c (Sign s t),EEps c' (Sign _  t'))) _ | c ==t  = (EEps c' (Sign s t'), [], "<=>")
+  nM _      (ECps (EEps c (Sign s _),EEps c' (Sign s' t'))) _ | s'==c' = (EEps c  (Sign s t'), [], "<=>")
+  nM _      (ECps (EEps c (Sign s _),ECps(EEps c' (Sign _  t'),r))) _ | c ==c' = (ECps (EEps c  (Sign s t'),r), [], "<=>")
+  nM _      (ECps (EEps c (Sign s t),ECps(EEps c' (Sign _  t'),r))) _ | c ==t  = (ECps (EEps c' (Sign s t'),r), [], "<=>")
+  nM _      (ECps (EEps c (Sign s _),ECps(EEps c' (Sign s' t'),r))) _ | s'==c' = (ECps (EEps c  (Sign s t'),r), [], "<=>")
+  nM _      (ECps (ERrs (x,e),y)) _ | not eq && isIdent e = (ERrs (x,y), ["Jipsen&Tsinakis: (x\\I);y |- x\\y"], "==>")
+  nM _      (ECps (x,ELrs (e,y))) _ | not eq && isIdent e = (ELrs (x,y), ["Jipsen&Tsinakis: x;(I/y) |- x/y"], "==>")
+  nM _      (ECps (ERrs (x,y),z)) _          | not eq = (ERrs (x,ECps (y,z)), ["Jipsen&Tsinakis: (x\\y);z |- x\\(y;z)"], "==>")
+  nM _      (ECps (x,ELrs (y,z))) _          | not eq = (ERrs (x,ECps (y,z)), ["Jipsen&Tsinakis: x;(y/z) |- (x;y)/z"], "==>")
+  nM _      (ECps (ERrs (x,y),ERrs (y',z))) _ | not eq && y==y' = (ERrs (x,z), ["Jipsen&Tsinakis: (x\\y);(y\\z) |- x\\z"], "==>")
+  nM _      (ECps (ELrs (x,y),ELrs (y',z))) _ | not eq && y==y' = (ERrs (x,z), ["Jipsen&Tsinakis: (x/y);(y/z) |- x/z"], "==>")
+  nM _      (ECps (ERrs (x,y),ERrs (y',z))) _ | y==y' && x==y && x==z = (ERrs (x,z), ["Jipsen&Tsinakis: (x\\x);(x\\x) = x\\x"], "<=>")
+  nM _      (ECps (ELrs (x,y),ELrs (y',z))) _ | y==y' && x==y && x==z = (ERrs (x,z), ["Jipsen&Tsinakis: (x/x);(x/x) = x/x"], "<=>")
+  nM _      (ECps (x,ERrs (y,z))) _    | x==y && x==z = (x, ["Jipsen&Tsinakis: x;(x\\x) = x"], "<=>")
+  nM _      (ECps (ELrs (x,y),z)) _    | x==z && y==z = (x, ["Jipsen&Tsinakis: (x/x);x = x"], "<=>")
+  nM _      (ECps (l,r)) _                | isIdent l = (r, ["I;x = x"], "<=>")
+  nM _      (ECps (l,r)) _                | isIdent r = (l, ["x;I = x"], "<=>")
+  nM True   (ECps (r,ERad (s,q))) _          | not eq = ((r.:.s).!.q, ["Peirce: r;(s!q) |- (r;s)!q"],"==>")
+  nM True   (ECps (ERad (r,s),q)) _          | not eq = (r.!.(s.:.q), ["Peirce: (r!s);q |- r!(s;q)"],"==>")
+  nM True   (ECps (EIsc (r,s),q)) _          | not eq = ((r.:.q)./\.(s.:.q), ["distribute ; over /\\"],"==>")
+  nM True   (ECps (r,EIsc (s,q))) _          | not eq = ((r.:.s)./\.(r.:.q), ["distribute ; over /\\"],"==>")
+  nM _      (ECps (EUni (q,s),r)) _                   = ((q.:.r).\/.(s.:.r), ["distribute ; over \\/"],"<=>")
+  nM _      (ECps (l,EUni (q,s))) _                   = ((l.:.q).\/.(l.:.s), ["distribute ; over \\/"],"<=>")
+  nM _      x@(ECps (l@EFlp{},r)) _ | not eq && flp l==r && isInj l   = (EDcI (source x), ["r~;r |- I (r is univalent)"], "==>")
+  nM _      x@(ECps (l,       r)) _ | not eq && l==flp r && isInj l   = (EDcI (source x), ["r;r~ |- I (r is injective)"], "==>")
+  nM _      x@(ECps (l@EFlp{},r)) _ | flp l==r && isInj l && isTot l  = (EDcI (source x), ["r~;r=I because r is univalent and surjective"], "<=>")
+  nM _      x@(ECps (l,       r)) _ | l==flp r && isInj l && isTot l  = (EDcI (source x), ["r;r~=I because r is injective and total"], "<=>")
+  nM posCpl (ECps (l,r))           rs                 = (t .:. f, steps++steps', fEqu [equ',equ''])
+                                                          where (t,steps, equ')  = nM posCpl l []
+                                                                (f,steps',equ'') = nM posCpl r (l:rs)
+  nM _      x@(EEps i sgn) _ | source sgn==i && i==target sgn = (EDcI i, ["source and target are equal to "++name i++", so "++showADL x++"="++showADL (EDcI i)], "<=>")
+  nM _      (ELrs (ECps (x,y),z)) _ | not eq && y==z  = (x,     ["(x;y)/y |- x"], "==>")
+  nM _      (ELrs (ECps (x,y),z)) _ | not eq && flp x==z= (flp y, [case (x, y) of
+                                                                        (EFlp _, EFlp _) -> "(SJ) (x~;y~)/x |- y"
+                                                                        (     _, EFlp _) -> "(SJ) (x;y~)/x~ |- y"
+                                                                        (EFlp _,      _) -> "(SJ) (x~;y)/x |- y~"
+                                                                        (     _,      _) -> "(SJ) (x;y)/x~ |- y~"], "==>")
+  nM _      (ELrs (ELrs (x,z),y)) _                     = (ELrs (x,ECps (y,z)), ["Jipsen&Tsinakis: x/yz = (x/z)/y"], "<=>") -- note: sign (x/yz) == sign ((x/z)/y)
+  nM posCpl (ELrs (l,r)) _                              = (t ./. f, steps++steps', fEqu [equ',equ''])
+                                                          where (t,steps, equ')  = nM posCpl l []
+                                                                (f,steps',equ'') = nM (not posCpl) r []
+  nM _      (ERrs (y,ERrs (x,z))) _                     = (ERrs (ECps (x,y),z), ["Jipsen&Tsinakis: xy\\z = y\\(x\\z)"], "<=>")
+  nM _      (ERrs (x,ECps (y,z))) _ | not eq && x==y    = (z,     ["x\\(x;y) |- y"], "==>")
+  nM posCpl (ERrs (l,r)) _                              = (t .\. f, steps++steps', fEqu [equ',equ''])
+                                                          where (t,steps, equ')  = nM (not posCpl) l []
+                                                                (f,steps',equ'') = nM posCpl r []
+  nM posCpl (EDia (l,r)) _                              = (t .<>. f, steps++steps', fEqu [equ',equ''])
+                                                          where (t,steps, equ')  = nM posCpl l []
+                                                                (f,steps',equ'') = nM posCpl r []
+  nM _      (ERad (l,r)) _                   | isImin l = (r, ["-I!x = x"], "<=>")
+  nM _      (ERad (l,r)) _                   | isImin r = (l, ["x!-I = x"], "<=>")
+--     nM False  (ERad (ECps (r,s),q)) _            | not eq = (r.:.(s.!.q), ["Peirce: (r;s)!q |- r;(s!q)"],"==>")  -- SJ 20131124 TODO: check this rule. It is wrong!
+--     nM False  (ERad (r,ECps (s,q))) _            | not eq = ((r.!.s).:.q, ["Peirce: (r!s);q |- r!(s;q)"],"==>")  -- SJ 20131124 TODO: check this rule. It is wrong!
+  nM False  (ERad (EUni (r,s),q)) _            | not eq = ((r.!.q).\/.(s.!.q), ["distribute ! over \\/"],"==>")
+  nM False  (ERad (r,EUni (s,q))) _            | not eq = ((r.!.s).\/.(r.!.q), ["distribute ! over \\/"],"==>")
+  nM _      (ERad (EIsc (q,s),r)) _                     = ((q.!.r)./\.(s.!.r), ["distribute ! over /\\"],"<=>")
+  nM _      (ERad (l,EIsc (q,s))) _                     = ((l.!.q)./\.(l.!.s), ["distribute ! over /\\"],"<=>")
+  nM _      (ERad(ECpl l,r))      _                     = (flp l .\. r, [case l of EFlp{} -> "-l~!r = l\\r"; _ -> "-l!r = l~\\r"], "<=>")
+  nM _      (ERad(l,ECpl r))      _                     = (l ./. flp r, [case r of EFlp{} -> "l!-r~ = l/r"; _ -> "l!-r = l/r~"], "<=>")
+  nM posCpl (ERad (l,r))         rs                     = (t .!. f, steps++steps', fEqu [equ',equ''])
+                                                              where (t,steps, equ')  = nM posCpl l []
+                                                                    (f,steps',equ'') = nM posCpl r (l:rs)
+  nM _      (EPrd (l,EPrd (_,r))) _                     = (l .*. r, ["eliminate middle in cartesian product"], "<=>")
+  nM posCpl (EPrd (l,r)) _                              = (t .*. f, steps++steps', fEqu [equ',equ''])
+                                                              where (t,steps, equ')  = nM posCpl l []
+                                                                    (f,steps',equ'') = nM posCpl r []
+  nM posCpl (EIsc (EUni (l,k),r)) _       | posCpl/=dnf = ((l./\.r) .\/. (k./\.r), ["distribute /\\ over \\/"],"<=>")
+  nM posCpl (EIsc (l,EUni (k,r))) _       | posCpl/=dnf = ((l./\.k) .\/. (l./\.r), ["distribute /\\ over \\/"],"<=>")
+  nM posCpl x@(EIsc (l,r)) rs
+-- Absorb equals:    r/\r  -->  r
+      | or [length cl>1 |cl<-absorbClasses]
+           = ( case absorbClasses of [] -> fatal 243 "Going into foldr1 with empty absorbClasses"; _ -> foldr1 (./\.) [head cl | cl<-absorbClasses]
+             , [shw e++" /\\ "++shw e++" = "++shw e | cl<-absorbClasses, length cl>1, let e=head cl]
+             , "<=>"
+             )
+-- Absorb True:    r/\V  --> r
+      | isTrue l                      = (r, ["V/\\x = x"], "<=>")
+      | isTrue r                      = (l, ["x/\\V = x"], "<=>")
+-- Inconsistency:    r/\-r   -->  False
+      | not (null incons)
+           = let i = head incons in (notCpl (EDcV (sign i)), [shw (notCpl i)++" /\\ "++shw i++" = V-"], "<=>")
+-- Inconsistency:    x/\\V-  -->  False
+      | isFalse l                     = (notCpl (EDcV (sign x)), ["-V/\\x = -V"], "<=>")
+      | isFalse r                     = (notCpl (EDcV (sign x)), ["x/\\-V = -V"], "<=>")
+-- Absorb if r is antisymmetric:    r/\r~ --> I
+      | t/=l || f/=r
+           = (t ./\. f, steps++steps', fEqu [equ',equ''])
+      | not eq && or [length cl>1 |cl<-absorbAsy]
+           = ( foldr1 (./\.) [if length cl>1 then EDcI (source e) else e | cl<-absorbAsy, let e=head cl]
+             , [shw e++" /\\ "++shw (flp e)++" |- I, because"++shw e++" is antisymmetric" | cl<-absorbAsy, let e=head cl]
+             , "==>"
+             )
+-- Absorb if r is antisymmetric and reflexive:    r/\r~ = I
+      | or [length cl>1 |cl<-absorbAsyRfx]
+           = ( foldr1 (./\.) [if length cl>1 then EDcI (source e) else e | cl<-absorbAsyRfx, let e=head cl]
+             , [shw e++" /\\ "++shw (flp e)++" = I, because"++shw e++" is antisymmetric and reflexive" | cl<-absorbAsyRfx, let e=head cl]
+             , "<=>"
+             )
+-- Absorb:    (x\\/y)/\\y  =  y
+      | isEUni l && not (null absor0)
+           = let t'=head absor0  in (r, ["absorb "++shw l++" because of "++shw t'++", using law  (x\\/y)/\\y = y"], "<=>")
+      | isEUni r && not (null absor0')
+           = let t'=head absor0' in (r, ["absorb "++shw r++" because of "++shw t'++", using law  (x\\/y)/\\x = x"], "<=>")
+-- Absorb:    (x\\/-y)/\\y  =  y-x
+      | isEUni l && not (null absor1)
+           = ( case head absor1 of
+                 (_,[]) -> r
+                 (_,ts) -> r .-. foldr1 (.\/.) ts
+             , ["absorb "++shw t'++", using law (x\\/-y)/\\y  =  y-x" | (t',_)<-absor1] -- this take 1 is necessary. See Ticket #398
+             , "<=>"
+             )
+      | isEUni r && not (null absor1')
+           = ( case head absor1' of
+                 (_,[]) -> l
+                 (_,ts) -> l .-. foldr1 (.\/.) ts
+             , ["absorb "++shw t'++", using law x/\\(y\\/-x)  =  x-y" | (t',_)<-absor1'] -- this take 1 is necessary. See Ticket #398
+             , "<=>"
+             )
+      | otherwise = (t ./\. f, steps++steps', fEqu [equ',equ''])
+      where (t,steps, equ')  = nM posCpl l []
+            (f,steps',equ'') = nM posCpl r (l:rs)
+            absorbClasses = eqClass (==) (exprIsc2list l++exprIsc2list r)
+            incons = [conjunct |conjunct<-exprIsc2list r,conjunct==notCpl l]
+            absor0  = [disjunct | disjunct<-exprUni2list l, f'<-rs++exprIsc2list r, disjunct==f']
+            absor0' = [disjunct | disjunct<-exprUni2list r, f'<-rs++exprIsc2list l, disjunct==f']
+            absor1  = [(disjunct, exprUni2list l>-[disjunct]) | disjunct<-exprUni2list l, ECpl f'<-rs++exprIsc2list r, disjunct==f']++
+                      [(disjunct, exprUni2list l>-[disjunct]) | disjunct@(ECpl t')<-exprUni2list l, f'<-rs++exprIsc2list r, t'==f']
+            absor1' = [(disjunct, exprUni2list r>-[disjunct]) | disjunct<-exprUni2list r, ECpl f'<-rs++exprIsc2list l, disjunct==f']++
+                      [(disjunct, exprUni2list r>-[disjunct]) | disjunct@(ECpl t')<-exprUni2list r, f'<-rs++exprIsc2list l, t'==f']
+            absorbAsy = eqClass same eList where e `same` e' = isAsy e && isAsy e' && e == flp e'
+            absorbAsyRfx = eqClass same eList where e `same` e' = isRfx e && isAsy e && isRfx e' && isAsy e' && e == flp e'
+            eList  = rs++exprIsc2list l++exprIsc2list r
+  nM posCpl (EUni (EIsc (l,k),r)) _  | posCpl==dnf    = ((l.\/.r) ./\. (k.\/.r), ["distribute \\/ over /\\"],"<=>")
+  nM posCpl (EUni (l,EIsc (k,r))) _  | posCpl==dnf    = ((l.\/.k) ./\. (l.\/.r), ["distribute \\/ over /\\"],"<=>")
+  nM posCpl (EUni (ECpl x,r@(ELrs (z,y)))) _          = if sign x==sign z -- necessary to guarantee that sign expr is equal to sign of the result
+                                                        then (notCpl (x .:. y) .\/. z, ["remove left residual (/)"],"<=>")
+                                                        else (notCpl t .\/. f, steps++steps', fEqu [equ',equ''])
+                                                           where (t,steps, equ')  = nM (not posCpl) x []
+                                                                 (f,steps',equ'') = nM posCpl r []
+  nM posCpl (EUni (l@(ELrs (z,y)),ECpl x)) _          = if sign x==sign z -- necessary to guarantee that sign expr is equal to sign of the result
+                                                        then (notCpl (x .:. y) .\/. z, ["remove left residual (/)"],"<=>")
+                                                        else (notCpl t .\/. f, steps++steps', fEqu [equ',equ''])
+                                                           where (t,steps, equ')  = nM (not posCpl) x []
+                                                                 (f,steps',equ'') = nM posCpl l []
+  nM posCpl (EUni (l@(ERrs (x,z)),ECpl y)) _          = if sign y==sign z -- necessary to guarantee that sign expr is equal to sign of the result
+                                                        then (notCpl (x .:. y) .\/. z, ["remove right residual (\\)"],"<=>")
+                                                        else (notCpl t .\/. f, steps++steps', fEqu [equ',equ''])
+                                                           where (t,steps, equ')  = nM (not posCpl) y []
+                                                                 (f,steps',equ'') = nM posCpl l []
+  nM posCpl (EUni (ECpl y,r@(ERrs (x,z)))) _          = if sign y==sign z -- necessary to guarantee that sign expr is equal to sign of the result
+                                                        then (notCpl (x .:. y) .\/. z, ["remove right residual (\\)"],"<=>")
+                                                        else (notCpl t .\/. f, steps++steps', fEqu [equ',equ''])
+                                                           where (t,steps, equ')  = nM (not posCpl) y []
+                                                                 (f,steps',equ'') = nM posCpl r []
+  nM posCpl x@(EUni (l,r)) rs
+-- Absorb equals:    r\/r  -->  r
+      | t/=l || f/=r
+           = (t .\/. f, steps++steps', fEqu [equ',equ''])
+      | or [length cl>1 |cl<-absorbClasses]   -- yields False if absorbClasses is empty
+           = ( foldr1 (.\/.) [head cl | cl<-absorbClasses]  -- cl cannot be empty, because it is made by eqClass
+             , [shw e++" \\/ "++shw e++" = "++shw e | cl<-absorbClasses, length cl>1, let e=head cl]
+             , "<=>"
+             )
+-- Tautologies:
+      | (not.null) tauts               = (EDcV (sign x), ["let e = "++ shw (head tauts)++". Since -e\\/e = V we get"], "<=>")   -- r\/-r  -->  V
+      | isTrue l                       = (EDcV (sign x), ["V\\/x = V"], "<=>")                                                  -- r\/V   -->  V
+      | isTrue r                       = (EDcV (sign x), ["x\\/V = V"], "<=>")
+-- Absorb -V:    r\/-V  --> r
+      | isFalse l                      = (r, ["-V\\/x = x"], "<=>")
+      | isFalse r                      = (l, ["x\\/-V = x"], "<=>")
+-- Absorb:    (x/\\y)\\/y  =  y
+      | isEIsc l && not (null absor0)  = let t'=head absor0  in (r, ["absorb "++shw l++" because of "++shw t'++", using law  (x/\\y)\\/y = y"], "<=>")
+      | isEIsc r && not (null absor0') = let t'=head absor0' in (r, ["absorb "++shw r++" because of "++shw t'++", using law  (x/\\y)\\/x = x"], "<=>")
+-- Absorb:    (x/\\-y)\\/y  =  x\\/y
+      | isEIsc l && not (null absor1)
+           = ( case head absor1 of
+                 (_,[]) -> r
+                 (_,ts) -> foldr1 (./\.) ts .\/. r
+             , ["absorb "++shw t'++", using law (x/\\-y)\\/y  =  x\\/y" | (t',_)<-absor1]
+             , "<=>"
+             )
+      | isEIsc r && not (null absor1')
+           = ( case head absor1' of
+                 (_,[]) -> l
+                 (_,ts) -> l .\/. foldr1 (./\.) ts
+             , ["absorb "++shw t'++", using law x\\/(y/\\-x)  =  x\\/y" | (t',_)<-absor1' ]
+             , "<=>"
+             )
+      | otherwise = (t .\/. f, steps++steps', fEqu [equ',equ''])
+      where (t,steps, equ')  = nM posCpl l []
+            (f,steps',equ'') = nM posCpl r (l:rs)
+         -- absorption can take place if two terms are equal. So let us make a list of equal terms: absorbClasses (for substituting r\/r by r)
+            absorbClasses = eqClass (==) (exprUni2list l++exprUni2list r)
+         -- tautologies occur if -r\/r, so we are looking for pairs, (x,l) such that x== -l
+            tauts = [t' |disjunct<-exprUni2list r,disjunct==notCpl l, ECpl t'<-[disjunct,l]]
+            absor0  = [t' | t'<-exprIsc2list l, f'<-rs++exprUni2list r, t'==f']
+            absor0' = [t' | t'<-exprIsc2list r, f'<-rs++exprUni2list l, t'==f']
+            absor1  = [(t', exprIsc2list l>-[t']) | t'<-exprIsc2list l, ECpl f'<-rs++exprUni2list r, t'==f']++[(e, exprIsc2list l>-[e]) | e@(ECpl t')<-exprIsc2list l, f'<-rs++exprUni2list r, t'==f']
+            absor1' = [(t', exprIsc2list r>-[t']) | t'<-exprIsc2list r, ECpl f'<-rs++exprUni2list l, t'==f']++[(e, exprIsc2list r>-[e]) | e@(ECpl t')<-exprIsc2list r, f'<-rs++exprUni2list l, t'==f']
+  nM _ (EFlp e) _ | isSym e =  (e,[shw e++" is symmetric"],"<=>")
+  nM _ x _               = (x,[],"<=>")
+
+fEqu :: [String] -> String
+fEqu ss = if and [s=="<=>" | s<-ss] then "<=>" else "==>"
+{-
+   nfProof :: (Expression -> String) -> Expression -> Proof Expression
+   nfProof shw = nfPr shw True True -- The first boolean True means that clauses are derived using <=> derivations. The second True means that a disjunctive normal form is produced.
+-}
+
+nfPr :: (Expression -> String) -> Bool -> Bool -> Expression -> [(Expression, [String], String)]
+nfPr shw eq dnf expr
+ = {-if showADL expr=="r \\/ s"
+   then fatal 360 ("Diagnose expr: "++showADL expr++"\n"++
+                   "eq:            "++show eq++"\n"++
+                   "dnf:           "++show eq++"\n"++
+                   "res:           "++showADL res++"\n"++
+                   "expr==res:     "++show (expr==res)
+                  ) else-}
+   if expr==res
+   then [(expr,[],"<=>")]
+   else (expr,steps,equ):nfPr shw eq dnf (simplify res)
+ where (res,steps,equ) = normStep shw eq dnf False expr
+
+conjNF, disjNF :: Options -> Expression -> Expression
+(conjNF, disjNF) = (pr False, pr True)
+ where pr dnf opts expr
+        = case oldNormalizer opts of
+           False -> let rterm = expr2RTerm expr
+                    in (rTerm2expr.last.((:) (rterm)).map (rhs.snd).slideDown (weightNF dnf)) rterm
+           True  -> let proof = if dnf then dfProof opts else cfProof opts
+                        (e,_,_) = if null (proof expr) then fatal 340 "last: empty list" else last (proof expr)
+                    in e
+
+cfProof, dfProof :: Options -> Expression -> Proof Expression
+(cfProof,dfProof) = (proof False, proof True)
+ where
+   proof :: Bool -> Options -> Expression -> Proof Expression
+   proof dnf opts expr
+    = case oldNormalizer opts of
+       False -> [ (rTerm2expr term, explStr, logicSym) | (term, explStr, logicSym)<-prRT (expr2RTerm expr) ]
+       True  -> [line | step, line<-init pr]++
+                [line | step', line<-init pr']++
+                [last ([(expr,[],"<=>")]++
+                       [line | step, line<-pr]++
+                       [line | step', line<-pr']
+                      )]
+      where
+        prRT :: RTerm -> [(RTerm, [String], String)]
+        prRT term
+           = case slideDown (weightNF dnf) term of
+               [] -> [ (term, ["weight: "++show (weightNF dnf term)], "<=>") ]
+               ds -> [ (lhs d, [" weight: "++show w++",   "++showADL tmpl++" = "++showADL stp++"  with unifier: "++showADL unif | let (tmpl,unif,stp) = rul d], "<=>")
+                     | (w,d)<-ds ] ++
+                     [ (rhs d, [], "<=>")
+                     | let (_,d) = last ds ]
+        pr           = nfPr showADL True dnf expr
+        (expr',_,_)  = if null pr then fatal 356 "last: empty list" else last pr
+        step         = simplify expr/=simplify expr'
+        pr'          = nfPr showADL True dnf expr'
+        step'        = simplify expr'/=simplify expr''
+        (expr'',_,_) = if null pr' then fatal 365 "last: empty list" else last pr'
+
+{-
+   cfProof :: Expression -> Proof Expression
+   cfProof expr
+    = [line | step, line<-init pr]++
+      [line | step', line<-init pr']++
+      [last ([(expr,[],"<=>")]++
+             [line | step, line<-pr]++
+             [line | step', line<-pr']
+            )]
+      where pr           = nfPr showADL True False (simplify expr)
+            (expr',_,_)  = if null pr then fatal 328 "last: empty list" else last pr
+            step         = simplify expr/=expr' -- obsolete?    || and [null s | (_,ss,_)<-pr, s<-ss]
+            pr'          = nfPr showADL True False (simplify expr')
+            step'        = simplify expr'/=simplify expr'' -- obsolete?    || and [null s | (_,ss,_)<-pr', s<-ss]
+            (expr'',_,_) = if null pr' then fatal 337 "last: empty list" else last pr'
+
+   dfProof :: Expression -> Proof Expression
+   dfProof expr
+    = [line | step, line<-init pr]++
+      [line | step', line<-init pr']++
+      [last ([(expr,[],"<=>")]++
+             [line | step, line<-pr]++
+             [line | step', line<-pr']
+            )]
+      where pr           = nfPr showADL True True expr
+            (expr',_,_)  = if null pr then fatal 356 "last: empty list" else last pr
+            step         = simplify expr/=simplify expr'
+            pr'          = nfPr showADL True True expr'
+            step'        = simplify expr'/=simplify expr''
+            (expr'',_,_) = if null pr' then fatal 365 "last: empty list" else last pr'
+-}
+
+isEUni :: Expression -> Bool
+isEUni EUni{}  = True
+isEUni _       = False
+
+isEIsc :: Expression -> Bool
+isEIsc EIsc{}  = True
+isEIsc _       = False
+
+
+
+
+
+conjuncts :: Options -> Rule -> [Expression]
+conjuncts opts = exprIsc2list.conjNF opts.rrexp
+
+allShifts :: Options -> DnfClause -> [DnfClause]
+allShifts opts conjunct =  (map head.eqClass (==).filter pnEq.map normDNF) (shiftL conjunct++shiftR conjunct)  -- we want to nub all dnf-clauses, but nub itself does not do the trick...
+-- allShifts conjunct = error $ show conjunct++concat [ "\n"++show e'| e'<-shiftL conjunct++shiftR conjunct] -- for debugging
+ where
+ {-
+  diagnostic
+   = intercalate "\n  "
+       [ "shiftL: [ "++intercalate "\n          , " [showHS opts "\n            " e | e<-shiftL conjunct    ]++"\n          ]"
+       , "shiftR: [ "++intercalate "\n          , " [showHS opts "\n            " e | e<-shiftR conjunct    ]++"\n          ]"
+       ] -}
+  shiftL :: DnfClause -> [DnfClause]
+  shiftL dc
+   | null (antcs dc)|| null (conss dc) = [dc] --  shiftL doesn't work here. This is just to make sure that both antss and conss are really not empty
+   | otherwise = [ Dnf { antcs = ass
+                       , conss = case css of
+                                   [] -> let antcExpr = foldr1 (./\.) ass in
+                                         if isEndo antcExpr then [EDcI (source antcExpr)] else fatal 425 "antcExpr should be endorelation"
+                                   _  -> css
+                       }
+                 | (ass,css)<-nub (move (antcs dc) (conss dc))
+                 ]
+   where
+   -- example:  r;s /\ p;r |- x;y   and suppose x and y are both univalent.
+   --  antcs =  [ r;s, p;r ]
+   --  conss =  [ x;y ]
+    move :: [Expression] -> [Expression] -> [([Expression],[Expression])]
+    move ass [] = [(ass,[])]
+    move ass css
+     = (ass,css):
+       if and [ (not.isEDcI) cs | cs<-css]     -- all cs are nonempty because: (not.and.map isEDcI) cs ==> not (null cs)
+       then [ts | let headEs = map headECps css
+                , length (eqClass (==) headEs) == 1                    -- example: True, because map head css == [ "x" ]
+                , let h=head headEs                                    -- example: h= "x"
+                , isUni h                                              -- example: assume True
+                , ts<-move [if source h==source as then flp h.:.as else fatal 455 "type mismatch"
+                           |as<-ass] (map tailECps css)]++ -- example: ts<-move [ [flp "x","r","s"], [flp "x","p","r"] ]  [ ["y","z"] ]
+            [ts | let lastEs = map lastECps css
+                , length (eqClass (==) lastEs) == 1
+                , let l=head lastEs
+                , isInj l
+                , ts<-move [if target as==target l then as.:.flp l else fatal 461 "type mismatch"
+                           |as<-ass] (map initECps css)]   -- example: ts<-move [ ["r","s",flp "z"], ["p","r",flp "z"] ]  [ ["x","y"] ]
+       else []
+   -- Here is (informally) what the example does:
+   -- move [ r;s , p;r ] [ x;y ]
+   -- ( [ r;s , p;r ] , [ x;y ] ): [ ts | ts<-move [flp x.:.as | as<-[ r;s , p;r ] [ y ] ] ]
+   -- ( [ r;s , p;r ] , [ x;y ] ): ( [ x~;r;s , x~;p;r ] , [ y ] ): [ ts | ts<-move [flp y.:.as | as<-[ y~;x~;r;s , y~;x~;p;r ] [] ] ]
+   -- ( [ r;s , p;r ] , [ x;y ] ): ( [ x~;r;s , x~;p;r ] , [ y ] ): [ [ y~;x~;r;s , y~;x~;p;r ] , [] ] ]
+   -- [ ( [ r;s , p;r ] , [ x;y ] ), ( [ x~;r;s , x~;p;r ] , [ y ] ), ( [ y~;x~;r;s , y~;x~;p;r ] , [] ) ]
+
+  shiftR :: DnfClause -> [DnfClause]
+  shiftR dc
+   | null (antcs dc) || null (conss dc) = [dc] --  shiftR doesn't work here. This is just to make sure that both antss and conss are really not empty
+   | otherwise                = [ Dnf (case ass of
+                                        [] -> let consExpr = foldr1 (.\/.) css in
+                                              if source consExpr==target consExpr then [EDcI (source consExpr)] else fatal 463 "consExpr should be endorelation"
+                                        _  -> ass
+                                      ) css
+                                | (ass,css)<-nub (move (antcs dc) (conss dc))
+                                ]
+   where
+   -- example  "r;s /\ r;r |- x;y"   and suppose r is both surjective.
+   --  ass =  [ r;s , r;r ]
+   --  css =  [ x;y ]
+    move :: [Expression] -> [Expression] -> [([Expression],[Expression])]
+    move ass css =
+     case ass of
+      [] -> [] -- was [([EDcI (target (last css))],css)]
+      _  ->
+       (ass,css):
+       if and [ (not.isEDcI) as | as<-ass]
+       then [ts | let headEs = map headECps ass
+                , length (eqClass (==) headEs) == 1                      -- example: True, because map headECps ass == [ "r", "r" ]
+                , let h=head headEs                                      -- example: h= "r"
+                , isSur h                                                -- example: assume True
+                , ts<-move (map tailECps ass) [if source h==source cs then flp h.:.cs else fatal 496 "type mismatch"
+                                              |cs<-css]]++   -- example: ts<-move  [["s"], ["r"]] [ [flp "r","x","y","z"] ]
+            [ts | let lastEs = map lastECps ass
+                , length (eqClass (==) lastEs) == 1                      -- example: False, because map lastECps ass == [ ["s"], ["r"] ]
+                , let l=head lastEs
+                , isTot l
+                , ts<-move (map initECps ass) [if target cs==target l then cs.:.flp l else fatal 502 "type mismatch"
+                                              |cs<-css]]     -- is dit goed? cs.:.flp l wordt links zwaar, terwijl de normalisator rechts zwaar maakt.
+       else []
+   -- Here is (informally) what the example does:
+   -- move [ r;s , r;r ] [ x;y ]
+   -- ( [ r;s , r;r ] , [ x;y ] ): move [ s , r ] [ r~;x;y ]
+   -- ( [ r;s , r;r ] , [ x;y ] ): ( [ s , r ]  , [ r~;x;y ] ) : []
+   -- [ [ r;s , r;r ] , [ x;y ] ), ( [ s , r ]  , [ r~;x;y ] ) ]
+   --  diagnostic
+   --    = "\n  antcs: [ "++intercalate "\n         , " [showADL a | a<-antcs ]++"\n       ]"++
+   --      "\n  conss: [ "++intercalate "\n         , " [showADL c | c<-conss ]++"\n       ]"++
+   --      "\n  move:  [ "++intercalate "\n         , " ["("++sh " /\\ " as++"\n           ,"++sh " \\/ " cs++")" | (as,cs)<-move antcs conss ]++"\n       ]"
+   --  sh :: String -> [Expression] -> String
+   --  sh str es = intercalate str [ showADL e | e<-es]
+
+  normDNF :: DnfClause -> DnfClause
+  normDNF dc = 
+    Dnf { antcs = case antcs dc of
+                   [] -> []
+                   _  -> (exprIsc2list . conjNF opts . foldr1 (./\.)) (antcs dc)
+        , conss = case conss dc of
+                   [] -> []
+                   _  -> (exprUni2list . disjNF opts . foldr1 (.\/.)) (conss dc)
+        }
+
+  pnEq :: DnfClause -> Bool
+  pnEq dc = antcs dc /= conss dc
+
+  headECps :: Expression -> Expression
+  headECps expr = f expr
+   where f (ECps (l@ECps{},_)) = f l
+         f (ECps (l,_)) = l
+         f _ = expr
+
+  tailECps :: Expression -> Expression
+  tailECps expr = f expr
+   where f (ECps (ECps (l,r),q)) = f (ECps (l, ECps (r,q)))
+         f (ECps (_,r)) = r
+         f _ = EDcI (target expr)
+
+  initECps :: Expression -> Expression
+  initECps expr = f expr
+   where f (ECps (l, ECps (r,q))) = initECps (ECps (ECps (l,r),q))
+         f (ECps (l,_)) = l
+         f _ = EDcI (source expr)
+
+  lastECps :: Expression -> Expression
+  lastECps expr = f expr
+   where f (ECps (_,r@ECps{})) = f r
+         f (ECps (_,r)) = r
+         f _ = expr
+
+  isEDcI :: Expression -> Bool
+  isEDcI EDcI{} = True
+  isEDcI _ = False
+
+
+makeAllConjs :: Options -> [Rule] -> [Conjunct]
+makeAllConjs opts allRls =
+  let conjExprs :: [(Expression, [Rule])]
+      conjExprs = converse [ (rule, conjuncts opts rule) | rule <- allRls ]
+      
+      conjs = [ Cjct { rc_id = "conj_"++show (i :: Int)
+                     , rc_orgRules   = rs
+                     , rc_conjunct   = expr
+                     , rc_dnfClauses = allShifts opts (expr2dnfClause expr)
+                     }
+              | ((expr, rs),i) <- zip conjExprs [0..]
+              ]
+  in  conjs
+   where
+      expr2dnfClause :: Expression -> DnfClause
+      expr2dnfClause conj = (split (Dnf [] []).exprUni2list) conj
+       where
+         split :: DnfClause -> [Expression] -> DnfClause
+         split (Dnf antc cons) (ECpl e: rest) = split (Dnf (e:antc) cons) rest
+         split (Dnf antc cons) (     e: rest) = split (Dnf antc (e:cons)) rest
+         split dc              []             = dc
+

+ src/Database/Design/Ampersand/Input.hs view
@@ -0,0 +1,7 @@+module Database.Design.Ampersand.Input
+   ( module Database.Design.Ampersand.Input.ADL1.CtxError
+   , module Database.Design.Ampersand.Input.Parsing
+   ) where
+import Database.Design.Ampersand.Input.ADL1.CtxError (CtxError,Guarded(..),showErr,unguard)
+import Database.Design.Ampersand.Input.Parsing (parseADL,parseADL1pExpr,parseRule,parseCtx)
+         
+ src/Database/Design/Ampersand/Input/ADL1/CtxError.hs view
@@ -0,0 +1,289 @@+{-# OPTIONS_GHC -XFlexibleInstances #-}
+module Database.Design.Ampersand.Input.ADL1.CtxError
+  ( CtxError(PE)
+  , showErr
+  , cannotDisamb, cannotDisambRel
+  , mustBeOrdered, mustBeOrderedLst, mustBeOrderedConcLst
+  , mustBeBound
+  , GetOneGuarded(..), uniqueNames, mkDanglingPurposeError
+  , mkUndeclaredError, mkMultipleInterfaceError, mkInterfaceRefCycleError, mkIncompatibleInterfaceError
+  , mkMultipleDefaultError, mkDanglingRefError
+  , mkIncompatibleViewError, mkOtherAtomInSessionError
+  , Guarded(..)
+  , whenCheckedIO
+  , unguard
+  )
+-- SJC: I consider it ill practice to export CTXE
+-- Reason: CtxError should obtain all error messages
+-- By not exporting anything that takes a string, we prevent other modules from containing error message
+-- If you build a function that must generate an error, put it in CtxError and call it instead
+-- see `getOneExactly' / `GetOneGuarded' as a nice example
+-- Although I also consider it ill practice to export PE, I did this as a quick fix for the parse errors
+where
+import Control.Applicative
+import Database.Design.Ampersand.ADL1
+import Database.Design.Ampersand.FSpec.ShowADL
+import Database.Design.Ampersand.Basics
+-- import Data.Traversable
+import Data.List  (intercalate)
+import GHC.Exts (groupWith)
+import Database.Design.Ampersand.Input.ADL1.UU_Scanner (Token)
+import UU.Parsing (Message(..),Action(..))
+import Database.Design.Ampersand.Core.ParseTree
+
+fatal,_notUsed :: Int -> String -> a
+fatal = fatalMsg "Input.ADL1.CtxError"
+_notUsed = fatal
+
+-- unguard is like an applicative join, which can be used to elegantly express monadic effects for Guarded.
+-- The function is a bit more compositional than the previous ly used <?> as you don't have to tuple all the arguments.
+-- Similar to join and bind we have: unguard g = id <?> g, and f <?> g = unguard $ f <$> g
+unguard :: Guarded (Guarded a) -> Guarded a
+unguard (Errors errs) = Errors errs
+unguard (Checked g)   = g  
+
+data CtxError = CTXE Origin String -- SJC: I consider it ill practice to export CTXE, see remark at top
+              | PE (Message Token (Maybe Token))
+              deriving Show
+
+errors :: Guarded t -> [CtxError]
+errors (Checked _) = []
+errors (Errors lst) = lst
+
+class GetOneGuarded a where
+  getOneExactly :: (Traced a1, ShowADL a1) => a1 -> [a] -> Guarded a
+  getOneExactly _ [a] = Checked a
+  getOneExactly o l@[] = hasNone l o
+  getOneExactly o lst = Errors [CTXE o'$ "Found too many:\n  "++s | CTXE o' s <- errors (hasNone lst o)]
+  hasNone :: (Traced a1, ShowADL a1) => [a] -- this argument should be ignored! It is only here to help indicate a type (you may put [])
+                                     -> a1  -- the object where the problem is arising
+                                     -> Guarded a
+  hasNone _ o = getOneExactly o []
+
+instance GetOneGuarded (P_SubIfc a) where
+  hasNone _ o = Errors [CTXE (origin o)$ "Required: one subinterface in "++showADL o]
+
+instance GetOneGuarded (SubInterface) where
+  hasNone _ o = Errors [CTXE (origin o)$ "Required: one subinterface in "++showADL o]
+
+instance GetOneGuarded Declaration where
+  getOneExactly _ [d] = Checked d
+  getOneExactly o []  = Errors [CTXE (origin o)$ "No declaration for "++showADL o]
+  getOneExactly o lst = Errors [CTXE (origin o)$ "Too many declarations match "++showADL o++".\n  Be more specific. These are the matching declarations:"++concat ["\n  - "++showADL l++" at "++(showFullOrig$origin l) | l<-lst]]
+
+cannotDisambRel :: TermPrim -> [Expression] -> Guarded Expression
+cannotDisambRel o exprs
+ = Errors [CTXE (origin o) message]
+  where 
+   message =
+    case exprs of
+     [] -> "No declarations match the relation: "++showADL o
+     _  -> case o of
+             (PNamedR(PNamedRel _ _ Nothing)) 
+                -> intercalate "\n" $
+                       ["Cannot disambiguate the relation: "++showADL o
+                       ,"  Please add a signature (e.g. [A*B]) to the relation."
+                       ,"  Relations you may have intended:"
+                       ]++
+                       ["  "++showADL e++"["++name (source e)++"*"++name (target e)++"]"
+                       |e<-exprs]
+             _  -> intercalate "\n" $
+                       ["Cannot disambiguate: "++showADL o
+                       ,"  Please add a signature."
+                       ,"  You may have intended one of these:"
+                       ]++
+                       ["  "++showADL e|e<-exprs]
+
+cannotDisamb :: TermPrim -> Guarded Expression
+cannotDisamb o = Errors [CTXE (origin o)$ "Cannot disambiguate: "++showADL o++"\n  Please add a signature to it"]
+
+uniqueNames :: (Named a, Traced a) =>
+                     [a] -> Guarded ()
+uniqueNames a = case (filter moreThanOne . groupWith name)  a of
+                  [] -> pure ()
+                  xs -> Errors (map messageFor xs)
+    where
+     moreThanOne (_:_:_) = True
+     moreThanOne  _      = False
+     messageFor :: (Named a, Traced a) => [a] -> CtxError
+     messageFor (x:xs) = CTXE (origin x)
+                      ("Names / labels must be unique. "++(show . name) x++", however, is used at:"++
+                        concatMap (("\n    "++ ) . show . origin) (x:xs)
+                        ++"."
+                       )
+     messageFor _ = fatal 90 "messageFor must only be used on lists with more that one element!"
+
+mkDanglingPurposeError :: Purpose -> CtxError
+mkDanglingPurposeError p = CTXE (origin p) $ "Purpose refers to non-existent " ++ showADL (explObj p) 
+-- Unfortunately, we cannot use position of the explanation object itself because it is not an instance of Trace.
+mkDanglingRefError :: String -- The type of thing that dangles. eg. "Rule"
+                   -> String -- the reference itself. eg. "Rule 42"
+                   -> Origin -- The place where the thing is found.
+                   -> CtxError
+mkDanglingRefError entity ref orig =
+  CTXE orig $ "Refference to non-existent " ++ entity ++ ": "++show ref   
+mkUndeclaredError :: (Traced e, Named e) => String -> e -> String -> CtxError
+mkUndeclaredError entity objDef ref = 
+  CTXE (origin objDef) $ "Undeclared " ++ entity ++ " " ++ show ref ++ " referenced at field " ++ show (name objDef)
+
+mkMultipleInterfaceError :: String -> Interface -> [Interface] -> CtxError
+mkMultipleInterfaceError role ifc duplicateIfcs = 
+  CTXE (origin ifc) $ "Multiple interfaces named " ++ show (name ifc) ++ " for role " ++ show role ++ ":" ++ 
+                      concatMap (("\n    "++ ) . show . origin) (ifc:duplicateIfcs)       
+
+mkInterfaceRefCycleError :: [Interface] -> CtxError
+mkInterfaceRefCycleError []                 = fatal 108 "mkInterfaceRefCycleError called on []"
+mkInterfaceRefCycleError cyclicIfcs@(ifc:_) = -- take the first one (there will be at least one) as the origin of the error
+  CTXE (origin ifc) $ "Interfaces form a reference cycle:\n" ++
+                      unlines [ "- " ++ show (name i) ++ " at position " ++ show (origin i) | i <- cyclicIfcs ] 
+                              
+mkIncompatibleInterfaceError :: P_ObjDef a -> A_Concept -> A_Concept -> String -> CtxError 
+mkIncompatibleInterfaceError objDef expTgt refSrc ref = 
+  CTXE (origin objDef) $ "Incompatible interface reference "++ show ref ++ " at field " ++ show (name objDef) ++ 
+                         ":\nReferenced interface "++show ref++" has type " ++ show (name refSrc) ++ 
+                         ", which is not comparable to the target " ++ show (name expTgt) ++ " of the expression at this field."
+
+mkMultipleDefaultError :: (A_Concept, [ViewDef]) -> CtxError
+mkMultipleDefaultError (_, [])              = fatal 118 "mkMultipleDefaultError called on []"
+mkMultipleDefaultError (c, viewDefs@(vd0:_)) =
+  CTXE (origin vd0) $ "Multiple default views for concept " ++ show (name c) ++ ":" ++ 
+                      concat ["\n    VIEW " ++ vdlbl vd ++ " (at " ++ show (origin vd) ++ ")"
+                             | vd <- viewDefs ]       
+
+mkIncompatibleViewError :: P_ObjDef a -> String -> String -> String -> CtxError
+mkIncompatibleViewError objDef viewId viewRefCptStr viewCptStr =
+  CTXE (origin objDef) $ "Incompatible view annotation <"++viewId++"> at field " ++ show (name objDef) ++ ":\nView " ++ show viewId ++ " has type " ++ show viewCptStr ++
+                         ", which should be equal to or more general than the target " ++ show viewRefCptStr ++ " of the expression at this field."
+
+mkOtherAtomInSessionError :: String -> CtxError
+mkOtherAtomInSessionError atomValue =
+  CTXE OriginUnknown $ "The special concept `SESSION` must not contain anything else then `_SESSION`. However it is populated with `"++atomValue++"`."
+  
+class ErrorConcept a where
+  showEC :: a -> String
+  showMini :: a -> String
+  
+instance ErrorConcept (P_ViewD a) where
+  showEC x = showADL (vd_cpt x) ++" given in VIEW "++vd_lbl x
+  showMini x = showADL (vd_cpt x)
+instance ErrorConcept (P_IdentDef) where
+  showEC x = showADL (ix_cpt x) ++" given in Identity "++ix_lbl x
+  showMini x = showADL (ix_cpt x)
+
+instance (ShowADL a2) => ErrorConcept (SrcOrTgt, A_Concept, a2) where
+  showEC (p1,c1,e1) = showEC' (p1,c1,showADL e1)
+  showMini (_,c1,_) = showADL c1
+  
+showEC' :: (SrcOrTgt, A_Concept, String) -> String
+showEC' (p1,c1,e1) = showADL c1++" ("++show p1++" of "++e1++")"
+  
+instance (ShowADL a2, Association a2) => ErrorConcept (SrcOrTgt, a2) where
+  showEC (p1,e1)
+   = case p1 of
+      Src -> showEC' (p1,source e1,showADL e1)
+      Tgt -> showEC' (p1,target e1,showADL e1)
+  showMini (p1,e1)
+   = case p1 of
+      Src -> showADL (source e1)
+      Tgt -> showADL (target e1)
+      
+instance (ShowADL a2, Association a2) => ErrorConcept (SrcOrTgt, Origin, a2) where
+  showEC (p1,o,e1)
+   = case p1 of
+      Src -> showEC' (p1,source e1,showADL e1 ++ ", "++showMinorOrigin o)
+      Tgt -> showEC' (p1,target e1,showADL e1 ++ ", "++showMinorOrigin o)
+  showMini (p1,_,e1)
+   = case p1 of
+      Src -> showADL (source e1)
+      Tgt -> showADL (target e1)
+
+mustBeOrdered :: (Traced a1, ErrorConcept a2, ErrorConcept a3) => a1 -> a2 -> a3 -> Guarded a
+mustBeOrdered o a b
+ = Errors [CTXE (origin o)$ "Type error, cannot match:\n  the concept "++showEC a
+                                          ++"\n  and concept "++showEC b
+                   ++"\n  if you think there is no type error, add an order between concepts "++showMini a++" and "++showMini b++"."]
+
+mustBeOrderedLst :: (Traced o, ShowADL o, ShowADL a) => o -> [(A_Concept, SrcOrTgt, a)] -> Guarded b
+mustBeOrderedLst o lst
+ = Errors [CTXE (origin o)$ "Type error in "++showADL o++"\n  Cannot match:"++ concat
+             [ "\n  - concept "++showADL c++", "++show st++" of "++showADL a
+             | (c,st,a) <- lst ] ++
+             "\n  if you think there is no type error, add an order between the mismatched concepts."
+          ]
+
+mustBeOrderedConcLst :: Origin -> (SrcOrTgt, Expression) -> (SrcOrTgt, Expression) -> [[A_Concept]] -> Guarded a
+mustBeOrderedConcLst o (p1,e1) (p2,e2) cs
+ = Errors [CTXE o$ "Ambiguous type when matching: "++show p1++" of "++showADL e1++"\n"
+                                          ++" and "++show p2++" of "++showADL e2++".\n"
+                   ++"  The type can be "++intercalate " or " (map (showADL . Slash) cs)
+                   ++"\n  None of these concepts is known to be the smallest, you may want to add an order between them."]
+
+newtype Slash a = Slash [a]
+instance ShowADL a => ShowADL (Slash a) where
+  showADL (Slash x) = intercalate "/" (map showADL x)
+
+mustBeBound :: Origin -> [(SrcOrTgt, Expression)] -> Guarded a
+mustBeBound o [(p,e)]
+ = Errors [CTXE o$ "An ambiguity arises in type checking. Be more specific by binding the "++show p++" of the expression "++showADL e++".\n"++
+                   "  You could add more types inside the expression, or just write "++writeBind e++"."]
+mustBeBound o lst
+ = Errors [CTXE o$ "An ambiguity arises in type checking. Be more specific in the expressions "++intercalate " and " (map (showADL . snd) lst) ++".\n"++
+                   "  You could add more types inside the expression, or write:"++
+                   concat ["\n  "++writeBind e| (_,e)<-lst]]
+
+writeBind :: Expression -> String
+writeBind (ECpl e)
+ = "("++showADL (EDcV (sign e))++" - "++showADL e++")"
+writeBind e
+ = "("++showADL e++") /\\ "++showADL (EDcV (sign e))
+
+data Guarded a = Errors [CtxError] | Checked a deriving Show
+
+instance Functor Guarded where
+ fmap _ (Errors a) = (Errors a)
+ fmap f (Checked a) = Checked (f a)
+
+instance Applicative Guarded where
+ pure = Checked
+ (<*>) (Checked f) (Checked a) = Checked (f a)
+ (<*>) (Errors  a) (Checked _) = Errors a
+ (<*>) (Checked _) (Errors  b) = Errors b
+ (<*>) (Errors  a) (Errors  b) = Errors (a ++ b) -- this line makes Guarded not a monad
+ -- Guarded is NOT a monad!
+ -- Reason: (<*>) has to be equal to `ap' if it is, and this definition is different
+ -- Use <?> if you wish to use the monad-like thing
+
+-- Shorthand for working with Guarded in IO
+whenCheckedIO :: IO  (Guarded a) -> (a -> IO (Guarded b)) -> IO (Guarded b)
+whenCheckedIO ioGA fIOGB =
+ do { gA <- ioGA 
+    ; case gA of
+         Errors errs -> return $ Errors errs
+         Checked a   ->
+          do { gB <- fIOGB a
+             ; return gB
+             }
+    }
+
+showErr :: CtxError -> String
+showErr (CTXE o s) = s ++ "\n  " ++ showFullOrig o
+showErr (PE msg)   = showMessage msg
+ where showMessage (Msg expecting token action) =  
+         let pos = case token of
+                     Nothing -> "at end of file"
+                     Just s  -> case action of 
+                                  Insert _ -> "before " ++ show s
+                                  Delete t -> "at " ++ show t  
+                                  Other str -> str -- Probably never used, UU.Parsing.parseIO ignores this case
+         in  "\nParse error " ++ pos ++
+             "\nExpecting " ++ show expecting ++
+             "\nTry " ++ show action ++ "\n"                
+ 
+
+showFullOrig :: Origin -> String
+showFullOrig (FileLoc (FilePos (filename,Database.Design.Ampersand.ADL1.Pos l c,t)))
+              = "Error at symbol "++ t ++ " in file " ++ filename++" at line " ++ show l++" : "++show c
+showFullOrig x = show x
+showMinorOrigin :: Origin -> String
+showMinorOrigin (FileLoc (FilePos (_,Database.Design.Ampersand.ADL1.Pos l c,_))) = "line " ++ show l++" : "++show c
+showMinorOrigin v = show v

+ src/Database/Design/Ampersand/Input/ADL1/FilePos.hs view
@@ -0,0 +1,56 @@+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE DeriveGeneric #-}
+module Database.Design.Ampersand.Input.ADL1.FilePos
+         (FilePos(..), Origin(..), Pos(Pos) , Traced(..)) where
+
+import Database.Design.Ampersand.Input.ADL1.UU_Scanner (Pos(Pos))
+import Database.Design.Ampersand.Basics
+import Data.Typeable
+import GHC.Generics (Generic)
+import Data.Hashable
+
+--fatal :: Int -> String -> a
+--fatal = fatalMsg "Input.ADL1.FilePos"
+
+--Traced a have an origin, which may be unknown.
+data FilePos = FilePos (String, Pos, String) deriving (Eq, Ord, Generic)
+instance Hashable FilePos where
+  hashWithSalt s (FilePos (fn,Pos l c, sym))
+    = s  `hashWithSalt`
+      fn `hashWithSalt`
+      l  `hashWithSalt`
+      c  `hashWithSalt`
+      sym
+data Origin = OriginUnknown | Origin String | FileLoc FilePos | DBLoc String deriving (Eq, Ord, Typeable, Generic)
+instance Unique Origin where
+  showUnique = show
+instance Hashable Origin
+
+instance Show FilePos where
+  show (FilePos (fn,Pos l c,_))
+    = "line " ++ show l++":"++show c
+         ++ ", file " ++ show fn
+
+instance Show Origin where
+  show (FileLoc pos) = show pos
+  show (DBLoc str)   = "Database location: "++str
+  show (Origin str)  = str
+  show OriginUnknown = "Unknown origin"
+class Traced a where
+  origin :: a -> Origin
+  filenm :: a -> String
+  linenr :: a -> Int
+  colnr :: a -> Int
+  filenm x = case origin x of
+               FileLoc (FilePos (nm, _, _)) -> nm
+               _ -> ""
+  linenr x = case origin x of
+               FileLoc (FilePos (_,Pos l _,_)) -> l
+               _ -> 0
+  colnr x  = case origin x of
+               FileLoc (FilePos (_,Pos _ c,_)) -> c
+               _ -> 0
+
+instance Traced Origin where
+  origin = id
+

+ src/Database/Design/Ampersand/Input/ADL1/Parser.hs view
@@ -0,0 +1,823 @@+{-# OPTIONS_GHC -fno-enable-rewrite-rules #-} -- Disable rewrite rules to drastically improve compilation speed
+{-# LANGUAGE FlexibleContexts #-}
+module Database.Design.Ampersand.Input.ADL1.Parser
+  (AmpParser, pContext, pPopulations,pTerm, pRule, keywordstxt, keywordsops, specialchars, opchars) where
+
+import Database.Design.Ampersand.Input.ADL1.UU_Scanner
+         ( Token(..),TokenType(..),noPos
+         , pKey,pConid,pString,pSpec,pExpl,pVarid,pComma,pSemi)
+import UU.Parsing hiding (Parser)
+import Database.Design.Ampersand.Basics
+import Database.Design.Ampersand.Core.ParseTree
+import Data.List
+import Data.Maybe
+
+fatal :: Int -> String -> a
+fatal = fatalMsg "Input.ADL1.Parser"
+
+type AmpParser a = AnaParser [Token] Pair Token (Maybe Token) a
+
+
+--  The Ampersand scanner takes the file name (String) for documentation and error messaging.
+--   scanner :: String -> String -> [Token]
+--   scanner fn str = scan keywordstxt keywordsops specialchars opchars fn initPos str
+
+keywordstxt :: [String]
+keywordstxt       = [ "INCLUDE"
+                    , "CONTEXT", "ENDCONTEXT", "EXTENDS", "THEMES"
+                    , "META"
+                    , "PATTERN", "ENDPATTERN"
+                    , "PROCESS", "ENDPROCESS"
+                    , "INTERFACE", "CLASS", "FOR", "BOX", "ROWS", "TABS", "COLS", "INITIAL", "SQLPLUG", "PHPPLUG", "TYPE"
+                    , "POPULATION", "CONTAINS"
+                    , "UNI", "INJ", "SUR", "TOT", "SYM", "ASY", "TRN", "RFX", "IRF", "AUT", "PROP", "ALWAYS"
+                    , "RULE", "MESSAGE", "VIOLATION", "SRC", "TGT", "TEST"
+                    , "RELATION", "MEANING", "CONCEPT", "IDENT"
+                    , "VIEW", "ENDVIEW", "DEFAULT", "TXT", "PRIMHTML", "TEMPLATE"
+                    , "KEY" -- HJO, 20130605: Obsolete. Only useful as long as the old prototype generator is still in use.
+                    , "IMPORT", "SPEC", "ISA", "IS", "I", "V"
+                    , "CLASSIFY"
+                    , "PRAGMA", "PURPOSE", "IN", "REF", "ENGLISH", "DUTCH"
+                    , "REST", "HTML", "LATEX", "MARKDOWN"
+                    , "ONE"
+                    , "BYPLUG"
+                    , "ROLE", "EDITS", "MAINTAINS"
+                    ]
+keywordsops :: [String]
+keywordsops       = [ "|-", "-", "->", "<-", "=", "~", "+", "*", ";", "!", "#", "::", ":", "\\/", "/\\", "\\", "/", "<>"
+                    , "..", "." , "0", "1"]
+specialchars :: String
+specialchars      = "()[],{}<>"
+opchars :: String
+opchars           = nub (sort (concat keywordsops))
+
+--to parse files containing only populations
+pPopulations :: AmpParser [P_Population]
+pPopulations = pList1 pPopulation
+
+pContext :: AmpParser (P_Context, [String]) -- the result is the parsed context and a list of include filenames
+pContext  = rebuild <$> pKey_pos "CONTEXT" <*> pConceptName
+                         <*> pLanguageRef
+                         <*> pMaybe pTextMarkup
+                         <*> pList pContextElement <* pKey "ENDCONTEXT"
+  where
+    rebuild :: Origin -> String -> Lang -> Maybe PandocFormat -> [ContextElement] -> (P_Context, [String])
+    rebuild    pos'      nm        lang          fmt                   ces
+     = (PCtx{ ctx_nm     = nm
+            , ctx_pos    = [pos']
+            , ctx_lang   = lang
+            , ctx_markup = fmt
+            , ctx_thms   = (nub.concat) [xs | CThm xs<-ces] -- Names of patterns/processes to be printed in the functional specification. (For partial documents.)
+            , ctx_pats   = [p | CPat p<-ces]       -- The patterns defined in this context
+            , ctx_PPrcs  = [p | CPrc p<-ces]       -- The processes as defined by the parser
+            , ctx_rs     = [p | CRul p<-ces]       -- All user defined rules in this context, but outside patterns and outside processes
+            , ctx_ds     = [p | CRel p<-ces]       -- The relations defined in this context, outside the scope of patterns
+            , ctx_cs     = [c ("CONTEXT "++nm) | CCon c<-ces]    -- The concept definitions defined in this context, outside the scope of patterns
+            , ctx_gs     = [g | CGen g<-ces]       -- The gen definitions defined in this context, outside the scope of patterns
+            , ctx_ks     = [k | CIndx k<-ces]      -- The identity definitions defined in this context, outside the scope of patterns
+            , ctx_rrules = []  -- TODO: Allow MAINTAINS statements in the context
+            , ctx_rrels  = []  -- TODO: Allow EDITS statements in the context
+            , ctx_vs     = [v | CView v<-ces]      -- The view definitions defined in this context, outside the scope of patterns
+            , ctx_ifcs   = [s | Cifc s<-ces]       -- The interfaces defined in this context, outside the scope of patterns -- fatal 78 ("Diagnostic: "++concat ["\n\n   "++show ifc | Cifc ifc<-ces])
+            , ctx_sql    = [p | CSqlPlug p<-ces]   -- user defined sqlplugs, taken from the Ampersand scriptplug<-ces]
+            , ctx_php    = [p | CPhpPlug p<-ces]   -- user defined phpplugs, taken from the Ampersand script
+            , ctx_ps     = [e | CPrp e<-ces]       -- The purposes defined in this context, outside the scope of patterns
+            , ctx_pops   = [p | CPop p<-ces]       -- The populations defined in this contextplug<-ces]
+            , ctx_metas  = [meta | CMeta meta <-ces]
+            }
+       , [s | CIncl s<-ces]) -- the INCLUDE filenames
+
+    pContextElement :: AmpParser ContextElement
+    pContextElement = CMeta    <$> pMeta         <|>
+                      CPat     <$> pPatternDef   <|>
+                      CPrc     <$> pProcessDef   <|>
+                      CRul     <$> pRuleDef      <|>
+                      CCfy     <$> pClassify     <|>
+                      CRel     <$> pRelationDef  <|>
+                      CCon     <$> pConceptDef   <|>
+                      CGen     <$> pGenDef       <|>
+                      CIndx    <$> pIndex        <|>
+                      CView    <$> pViewDef      <|>
+                      Cifc     <$> pInterface    <|>
+                      CSqlPlug <$> pSqlplug      <|>
+                      CPhpPlug <$> pPhpplug      <|>
+                      CPrp     <$> pPurpose      <|>
+                      CPop     <$> pPopulation   <|>
+                      CThm     <$> pPrintThemes  <|>
+                      CIncl    <$> pIncludeStatement
+
+data ContextElement = CMeta Meta
+                    | CPat P_Pattern
+                    | CPrc P_Pattern
+                    | CRul (P_Rule TermPrim)
+                    | CCfy P_Gen
+                    | CRel P_Declaration
+                    | CCon (String->ConceptDef)
+                    | CGen P_Gen
+                    | CIndx P_IdentDef
+                    | CView P_ViewDef
+                    | Cifc P_Interface
+                    | CSqlPlug P_ObjectDef
+                    | CPhpPlug P_ObjectDef
+                    | CPrp PPurpose
+                    | CPop P_Population
+                    | CThm [String]    -- a list of themes to be printed in the functional specification. These themes must be PATTERN or PROCESS names.
+                    | CIncl String     -- an INCLUDE statement
+
+pIncludeStatement :: AmpParser String
+pIncludeStatement = pKey "INCLUDE" *> pString
+
+pLanguageRef :: AmpParser Lang
+pLanguageRef = pKey "IN" *>
+               (( Dutch   <$ pKey "DUTCH"  ) <|>
+                ( English <$ pKey "ENGLISH")
+               )
+pTextMarkup :: AmpParser PandocFormat
+pTextMarkup = ( ReST     <$ pKey "REST"     ) <|>
+              ( HTML     <$ pKey "HTML"     ) <|>
+              ( LaTeX    <$ pKey "LATEX"    ) <|>
+              ( Markdown <$ pKey "MARKDOWN" )
+
+pMeta :: AmpParser Meta
+pMeta = Meta <$> pKey_pos "META" <*> pMetaObj <*> pString <*> pString
+ where pMetaObj = pSucceed ContextMeta -- for the context meta we don't need a keyword
+
+pPatternDef :: AmpParser P_Pattern
+pPatternDef = rebuild <$> pKey_pos "PATTERN" <*> pConceptName   -- The name spaces of patterns, processes and concepts are shared.
+                      <*> pList pPatElem
+                      <*> pKey_pos "ENDPATTERN"
+  where
+    rebuild :: Origin -> String -> [PatElem] -> Origin -> P_Pattern
+    rebuild pos' nm pes end
+     = P_Pat { pt_nm  = nm
+             , pt_pos = pos'
+             , pt_end = end
+             , pt_rls = [r | Pr r<-pes]
+             , pt_gns = [g | Pg g<-pes]
+             , pt_dcs = [d | Pd d<-pes]
+             , pt_RRuls = []  -- TODO: Add P_RoleRule to Pattern
+             , pt_RRels = []  -- TODO: Add P_RoleRelation to Pattern
+             , pt_cds = [c nm | Pc c<-pes]
+             , pt_ids = [k | Pk k<-pes]
+             , pt_vds = [v | Pv v<-pes]
+             , pt_xps = [e | Pe e<-pes]
+             , pt_pop = [p | Pp p<-pes]
+             }
+    pPatElem :: AmpParser PatElem
+    pPatElem = Pr <$> pRuleDef      <|>
+               Py <$> pClassify     <|>
+               Pd <$> pRelationDef  <|>
+               Pc <$> pConceptDef   <|>
+               Pg <$> pGenDef       <|>
+               Pk <$> pIndex        <|>
+               Pv <$> pViewDef      <|>
+               Pe <$> pPurpose      <|>
+               Pp <$> pPopulation
+
+data PatElem = Pr (P_Rule TermPrim)
+             | Py P_Gen
+             | Pd P_Declaration
+             | Pc (String->ConceptDef)
+             | Pg P_Gen
+             | Pk P_IdentDef
+             | Pv P_ViewDef
+             | Pe PPurpose
+             | Pp P_Population
+
+pProcessDef :: AmpParser P_Pattern
+pProcessDef = rebuild <$> pKey_pos "PROCESS" <*> pConceptName   -- The name spaces of patterns, processes and concepts are shared.
+                      <*> pList pProcElem
+                      <*> pKey_pos "ENDPROCESS"
+   where
+    rebuild :: Origin -> String -> [ProcElem] -> Origin -> P_Pattern
+    rebuild pos' nm pes end
+      = P_Pat { pt_nm    = nm
+              , pt_pos   = pos'
+              , pt_end   = end
+              , pt_rls = [rr | PrR rr<-pes]
+              , pt_gns  = [g  | PrG g <-pes]
+              , pt_dcs  = [d  | PrD d <-pes]
+              , pt_RRuls = [rr | PrM rr<-pes]
+              , pt_RRels = [rr | PrL rr<-pes]
+              , pt_cds   = [cd nm | PrC cd<-pes]
+              , pt_ids   = [ix | PrI ix<-pes]
+              , pt_vds   = [vd | PrV vd<-pes]
+              , pt_xps   = [e  | PrE e <-pes]
+              , pt_pop   = [p  | PrP p <-pes]
+              }
+    pProcElem :: AmpParser ProcElem
+    pProcElem = PrR <$> pRuleDef      <|>
+                PrY <$> pClassify     <|>
+                PrD <$> pRelationDef  <|>
+                PrM <$> pRoleRule     <|>
+                PrL <$> pRoleRelation <|>
+                PrC <$> pConceptDef   <|>
+                PrG <$> pGenDef       <|>
+                PrI <$> pIndex        <|>
+                PrV <$> pViewDef      <|>
+                PrE <$> pPurpose      <|>
+                PrP <$> pPopulation
+
+data ProcElem = PrR (P_Rule TermPrim)
+              | PrY P_Gen
+              | PrD P_Declaration
+              | PrM P_RoleRule
+              | PrL P_RoleRelation
+              | PrC (String->ConceptDef)
+              | PrG P_Gen
+              | PrI P_IdentDef
+              | PrV P_ViewDef
+              | PrE PPurpose
+              | PrP P_Population
+
+pClassify :: AmpParser P_Gen   -- Example: CLASSIFY A IS B /\ C /\ D
+pClassify = rebuild <$> pKey_pos "CLASSIFY"
+                    <*> pConceptRef
+                    <*  pKey "IS"
+                    <*> pCterm
+               where
+                 rebuild po lhs rhs
+                   = P_Cy { gen_spc  = lhs             --  Left hand side concept expression
+                          , gen_rhs  = rhs             --  Right hand side concept expression
+                          , gen_fp   = po
+                          }
+                 pCterm  = f <$> pList1Sep (pKey "/\\") pCterm1
+                 pCterm1 = g <$> pConceptRef                        <|>
+                           h <$> (pSpec '(' *> pCterm <* pSpec ')')  -- brackets are allowed for educational reasons.
+                 f ccs = concat ccs
+                 g c = [c]
+                 h cs = cs
+
+pRuleDef :: AmpParser (P_Rule TermPrim)
+pRuleDef =  rebuild <$> pKey_pos "RULE"
+                    <*> pMaybe (pADLid <* pKey ":" )
+                    <*> pRule
+                    <*> pList pMeaning
+                    <*> pList pMessage
+                    <*> pMaybe pViolation
+               where
+                 rebuild po mn rexp mean msg mViolation
+                   = P_Ru { rr_nm   = fromMaybe (rulid po) mn
+                          , rr_exp  = rexp
+                          , rr_fps  = po
+                          , rr_mean = mean
+                          , rr_msg  = msg
+                          , rr_viol = mViolation
+                          }
+                 rulid (FileLoc(FilePos (_,Pos l _,_))) = "rule@line"++show l
+                 rulid _ = fatal 226 "pRuleDef is expecting a file location."
+                 pViolation :: AmpParser (PairView (Term TermPrim))
+                 pViolation = id <$ pKey "VIOLATION" <*> pPairView
+
+                 pPairView :: AmpParser (PairView (Term TermPrim))
+                 pPairView = PairView <$ pSpec '(' <*> pList1Sep (pSpec ',') pPairViewSegment <* pSpec ')'
+
+                 pPairViewSegment :: AmpParser (PairViewSegment (Term TermPrim))
+                 pPairViewSegment = rebuildSrc <$> pKey_pos "SRC" <*> pTerm 
+                                <|> rebuildTgt <$> pKey_pos "TGT" <*> pTerm
+                                <|> PairViewText <$> pKey_pos "TXT" <*> pString
+                   where rebuildSrc p t = PairViewExp p Src t
+                         rebuildTgt p t = PairViewExp p Tgt t
+
+pRelationDef :: AmpParser P_Declaration
+pRelationDef      = ( rebuild <$> pVarid  <*> pKey_pos "::"  <*> pConceptRef  <*> pFun  <*> pConceptRef
+                      <|> rbd <$> pKey_pos "RELATION" <*> pVarid  <*> pSign
+                    )
+                      <*> ((True <$ pKey "BYPLUG") `opt` False)
+                      <*> (pProps `opt` [])
+                      <*> ((True <$ pKey "BYPLUG") `opt` False)
+                      <*> (pPragma `opt` [])
+                      <*> pList pMeaning
+                      <*> ((pKey "=" *> pContent) `opt` [])
+                      <* (pKey "." `opt` "")         -- in the syntax before 2011, a dot was required. This optional dot is there to save user irritation during the transition to a dotless era  :-) .
+                    where rebuild nm pos' src fun' trg bp1 props --bp2 pragma meanings content
+                            = rbd pos' nm (P_Sign src trg) bp1 props' --bp2 pragma meanings content
+                              where props'= nub (props `uni` fun')
+                          rbd pos' nm sgn bp1 props bp2 pragma meanings content
+                            = P_Sgn { dec_nm   = nm
+                                    , dec_sign = sgn
+                                    , dec_prps = props
+                                    , dec_prL  = head pr
+                                    , dec_prM  = pr!!1
+                                    , dec_prR  = pr!!2
+                                    , dec_Mean = meanings
+                                    , dec_popu = content
+                                    , dec_fpos = pos'
+                                    , dec_plug = bp1 || bp2
+                                    }
+                              where pr = pragma++["","",""]
+
+                          pProps :: AmpParser [Prop]
+                          pProps  = (f.concat) <$> (pSpec '[' *> pListSep (pSpec ',') pProp <* pSpec ']')
+                              where f ps = nub (ps ++ concat [[Uni, Inj] | null ([Sym, Asy]>-ps)])
+                          pProp :: AmpParser [Prop]
+                          pProp   = k [Uni] "UNI" <|> k [Inj] "INJ" <|> k [Sur] "SUR" <|> k [Tot] "TOT" <|>
+                                    k [Sym] "SYM" <|> k [Asy] "ASY" <|> k [Trn] "TRN" <|>
+                                    k [Rfx] "RFX" <|> k [Irf] "IRF" <|> k [Aut] "AUT" <|> k [Sym, Asy] "PROP"
+                              where k obj str = f <$> pKey str where f _ = obj
+                          pPragma :: AmpParser [String]
+                          pPragma = pKey "PRAGMA" *> pList1 pString
+                          pFun :: AmpParser [Prop]
+                          pFun    = []        <$ pKey "*"  <|>
+                                    [Uni,Tot] <$ pKey "->" <|>
+                                    [Sur,Inj] <$ pKey "<-" <|>
+                                    (rbld     <$  pSpec '['
+                                              <*> (pMult (Sur,Inj) `opt` [])
+                                              <*  pKey "-"
+                                              <*> (pMult (Tot,Uni) `opt` [])
+                                              <*  pSpec ']'
+                                    )
+                              where
+                                pMult :: (Prop,Prop) -> AmpParser [Prop]
+                                pMult (ts,ui) = rbld  <$> (( []   <$ pKey "0") <|> ([ts] <$ pKey "1") )
+                                                      <*  pKey ".."
+                                                      <*> (( [ui] <$ pKey "1") <|> ([]   <$ pKey "*" )) <|>
+                                                [] <$ pKey "*"  <|>
+                                                [ts,ui] <$ pKey "1"
+                                rbld a b = a++b
+
+pConceptDef :: AmpParser (String->ConceptDef)
+pConceptDef       = Cd <$> pKey_pos "CONCEPT"
+                       <*> pConceptName           -- the concept name
+                       <*> ((True <$ pKey "BYPLUG") `opt` False)
+                       <*> pString                -- the definition text
+                       <*> ((pKey "TYPE" *> pString) `opt` "")     -- the type of the concept.
+                       <*> (pString `opt` "")     -- a reference to the source of this definition.
+
+pGenDef :: AmpParser P_Gen
+pGenDef           = rebuild <$> pKey_pos "SPEC"     <*> pConceptRef <* pKey "ISA" <*> pConceptRef <|>  -- SPEC is obsolete syntax. Should disappear!
+                    rebuild <$> pKey_pos "CLASSIFY" <*> pConceptRef <* pKey "ISA" <*> pConceptRef <|>
+                    pClassify
+                    where rebuild p spc gen = PGen{gen_spc=spc, gen_gen=gen, gen_fp =p}
+
+-- | A identity definition looks like:   IDENT onNameAdress : Person(name, address),
+-- which means that name<>name~ /\ address<>addres~ |- I[Person].
+-- The label 'onNameAddress' is used to refer to this identity.
+-- You may also use an expression on each attribute place, for example: IDENT onpassport: Person(nationality, passport;documentnr),
+-- which means that nationality<>nationality~ /\ passport;documentnr<>(passport;documentnr)~ |- I[Person].
+pIndex :: AmpParser P_IdentDef
+pIndex  = identity <$ pKey "IDENT" <*> pLabel <*> pConceptRefPos <* pSpec '(' <*> pList1Sep (pSpec ',') pIndSegment <* pSpec ')'
+    where identity :: Label -> (P_Concept, Origin) -> [P_IdentSegment] -> P_IdentDef
+          identity (Lbl nm _ _) (c, orig) ats
+           = P_Id { ix_pos = orig
+                  , ix_lbl = nm
+                  , ix_cpt = c
+                  , ix_ats = ats
+                  }
+
+          pIndSegment :: AmpParser P_IdentSegment
+          pIndSegment = P_IdentExp <$> pIndAtt
+
+          pIndAtt :: AmpParser P_ObjectDef
+          pIndAtt  = attL <$> pLabelProps <*> pTerm <|>
+                     att <$> pTerm
+              where attL (Lbl nm p strs) attexpr =
+                       P_Obj { obj_nm   = nm
+                             , obj_pos  = p
+                             , obj_ctx  = attexpr
+                             , obj_mView = Nothing
+                             , obj_msub = Nothing
+                             , obj_strs = strs
+                             }
+                    att attexpr =
+                        P_Obj { obj_nm   = ""
+                              , obj_pos  = Origin "pIndAtt CC664"
+                              , obj_ctx  = attexpr
+                              , obj_mView = Nothing
+                              , obj_msub = Nothing
+                              , obj_strs = []
+                              }
+
+pViewDef :: AmpParser P_ViewDef
+pViewDef  = pFancyViewDef <|> pViewDefLegacy -- introduces a bit of harmless backtracking, but is more elegant than rewriting pViewDefLegacy to disallow "KEY ... ENDVIEW".
+
+pFancyViewDef :: AmpParser P_ViewDef
+pFancyViewDef  = mkViewDef <$  pKey "VIEW" <*> pLabel <*> pConceptOneRefPos <*> pMaybe (pKey "DEFAULT") <* pSpec '{' <*> pList1Sep (pSpec ',') pViewObj <* pSpec '}'
+                           <*> pMaybe pHtmlView 
+                           <*  pKey "ENDVIEW"
+    where mkViewDef :: Label -> (P_Concept, Origin) -> Maybe String -> [P_ObjectDef] -> Maybe ViewHtmlTemplate -> P_ViewDef
+          mkViewDef (Lbl nm _ _) (c, orig) mDefault objs mHtml =
+            P_Vd { vd_pos = orig
+                 , vd_lbl = nm
+                 , vd_cpt = c
+                 , vd_isDefault = isJust mDefault
+                 , vd_html = mHtml
+                 , vd_ats = map P_ViewExp objs
+                 }
+
+          pViewObj :: AmpParser P_ObjectDef
+          pViewObj = mkObj <$> pLabel <*> pTerm
+            where mkObj (Lbl nm p strs) attexpr = 
+                    P_Obj { obj_nm    = nm
+                          , obj_pos   = p
+                          , obj_ctx   = attexpr
+                          , obj_mView = Nothing
+                          , obj_msub  = Nothing
+                          , obj_strs  = strs -- will always be []
+                          }
+          
+          pHtmlView :: AmpParser ViewHtmlTemplate                 
+          pHtmlView = ViewHtmlTemplateFile <$ pKey "HTML" <* pKey "TEMPLATE" <*> pString
+          
+
+-- | A view definition looks like:
+--      VIEW onSSN: Person("social security number":ssn)
+-- or
+--      VIEW SaveAdlFile: SaveAdlFile(PRIMHTML "<a href='../../index.php?operation=2&file=", filepath , filename
+--      ,PRIMHTML "&userrole=", savecontext~;sourcefile;uploaded~;userrole
+--      ,PRIMHTML "'>", filename/\V[SaveAdlFile*FileName], PRIMHTML "</a>")
+-- which can be used to define a proper user interface by assigning labels and markup to the attributes in a view.
+pViewDefLegacy :: AmpParser P_ViewDef
+pViewDefLegacy  = vd <$ (pKey "VIEW" <|> pKey "KEY") <*> pLabelProps <*> pConceptOneRefPos <* pSpec '(' <*> pList1Sep (pSpec ',') pViewSegment <* pSpec ')'
+    where vd :: Label -> (P_Concept, Origin) -> [P_ViewSegment] -> P_ViewDef
+          vd (Lbl nm _ _) (c, orig) ats
+              = P_Vd { vd_pos = orig
+                     , vd_lbl = nm
+                     , vd_cpt = c
+                     , vd_isDefault = True -- Legacy view defs are always assumed to be the default (only one is allowed)
+                     , vd_html = Nothing
+                     , vd_ats = [ case viewSeg of
+                                     P_ViewExp x       -> if null (obj_nm x) then P_ViewExp $ x{obj_nm="seg_"++show i} else P_ViewExp x
+                                     P_ViewText _ -> viewSeg
+                                     P_ViewHtml _ -> viewSeg
+                                | (i,viewSeg) <- zip [(1::Integer)..] ats]
+                     }  -- counter is used to name anonymous segments (may skip numbers because text/html segments are also counted)
+          pViewSegment :: AmpParser P_ViewSegment
+          pViewSegment = P_ViewExp  <$> pViewAtt <|>
+                         P_ViewText <$ pKey "TXT" <*> pString <|>
+                         P_ViewHtml <$ pKey "PRIMHTML" <*> pString
+          pViewAtt :: AmpParser P_ObjectDef
+          pViewAtt = rebuild <$> pMaybe pLabelProps <*> pTerm
+              where
+                rebuild mLbl attexpr =
+                  case mLbl of
+                    Just (Lbl nm p strs) ->
+                            P_Obj { obj_nm   = nm
+                                  , obj_pos  = p
+                                  , obj_ctx  = attexpr
+                                  , obj_mView = Nothing
+                                  , obj_msub = Nothing
+                                  , obj_strs = strs
+                                  }
+                    Nothing ->
+                            P_Obj { obj_nm   = ""
+                                  , obj_pos  = origin attexpr
+                                  , obj_ctx  = attexpr
+                                  , obj_mView = Nothing
+                                  , obj_msub = Nothing
+                                  , obj_strs = []
+                                  }
+
+pInterface :: AmpParser P_Interface
+pInterface = lbl <$> (pKey "INTERFACE" *> pADLid_val_pos) <*>
+                     (pMaybe $ pKey "CLASS" *> (pConid <|> pString)) <*> -- the class is an upper-case identifier or a quoted string
+                     (pParams `opt` [])                   <*>       -- a list of expressions, which say which relations are editable within this service.
+                                                                    -- either  Prel _ nm
+                                                                    --       or  PNamedRel _ nm sgn
+                     (pArgs   `opt` [])                   <*>
+                     (pRoles  `opt` [])                   <*>
+                     (pKey ":" *> pTerm)                  <*>
+                     pSubInterface
+    where lbl :: (String, Origin) -> Maybe String -> [P_NamedRel] -> [[String]] -> [Role] -> (Term TermPrim) -> P_SubInterface -> P_Interface
+          lbl (nm,p) iclass params args roles expr sub
+             = P_Ifc { ifc_Name   = nm
+                     , ifc_Class  = iclass
+                     , ifc_Params = params
+                     , ifc_Args   = args
+                     , ifc_Roles  = roles
+                     , ifc_Obj    = P_Obj { obj_nm   = nm
+                                          , obj_pos  = p
+                                          , obj_ctx  = expr
+                                          , obj_mView = Nothing
+                                          , obj_msub = Just sub
+                                          , obj_strs = args
+                                          }
+                     , ifc_Pos    = p
+                     , ifc_Prp    = ""   --TODO: Nothing in syntax defined for the purpose of the interface.
+                     }
+          pParams = pSpec '(' *> pList1Sep (pSpec ',') pNamedRel          <* pSpec ')'
+          pArgs   = pSpec '{' *> pList1Sep (pSpec ',') (pList1 pADLid)   <* pSpec '}'
+          pRoles  = pKey "FOR" *> pList1Sep (pSpec ',') pRole
+
+pSubInterface :: AmpParser P_SubInterface
+pSubInterface = (\(o,cl) objs -> P_Box o cl objs) <$> pBoxKey <*> pBox
+            <|> (\(n,p) -> P_InterfaceRef p n) <$ pKey "INTERFACE" <*> pADLid_val_pos
+  where pBoxKey :: AmpParser (Origin, Maybe String)
+        pBoxKey = (\o mCl -> (o,mCl))     <$> pKey_pos "BOX" <*> pMaybe (pSpec '<' *> pConid <* pSpec '>')
+              <|> (\o -> (o,Just "ROWS")) <$> pKey_pos "ROWS"
+              <|> (\o -> (o,Just "COLS")) <$> pKey_pos "COLS"
+              <|> (\o -> (o,Just "TABS")) <$> pKey_pos "TABS"
+
+pObjDef :: AmpParser P_ObjectDef
+pObjDef            = obj <$> pLabelProps
+                         <*> pTerm            -- the context expression (for example: I[c])
+                         <*> pMaybe (pSpec '<' *> pConid <* pSpec '>')
+                         <*> pMaybe pSubInterface  -- the optional subinterface
+                     where obj (Lbl nm pos' strs) expr mView msub  =
+                             P_Obj { obj_nm   = nm
+                                   , obj_pos  = pos'
+                                   , obj_ctx  = expr
+                                   , obj_mView = mView
+                                   , obj_msub = msub
+                                   , obj_strs = strs
+                                   }
+pBox :: AmpParser [P_ObjectDef]
+pBox              = pSpec '[' *> pList1Sep (pSpec ',') pObjDef <* pSpec ']'
+
+pSqlplug :: AmpParser P_ObjectDef
+pSqlplug          = pKey_pos "SQLPLUG" *> pObjDef
+
+pPhpplug :: AmpParser P_ObjectDef
+pPhpplug          = pKey_pos "PHPPLUG" *> pObjDef
+
+pPurpose :: AmpParser PPurpose
+pPurpose          = rebuild <$> pKey_pos "PURPOSE"  -- "EXPLAIN" has become obsolete
+                            <*> pRef2Obj
+                            <*> pMaybe pLanguageRef
+                            <*> pMaybe pTextMarkup
+                            <*> ((pKey "REF" *> (pList1Sep pSemi pString)) `opt` [])
+                            <*> pExpl
+     where
+       rebuild :: Origin -> PRef2Obj -> Maybe Lang -> Maybe PandocFormat -> [String] -> String -> PPurpose
+       rebuild    orig      obj         lang          fmt                   refs       str
+           = PRef2 orig obj (P_Markup lang fmt str) (concatMap (splitOn ";") refs)
+              where splitOn :: Eq a => [a] -> [a] -> [[a]]
+                    splitOn [] s = [s]
+                    splitOn s t  = case findIndex (isPrefixOf s) (tails t) of
+                                     Nothing -> [t]
+                                     Just i  -> [take i t]  ++ splitOn s (drop (i+length s) t)
+
+       pRef2Obj :: AmpParser PRef2Obj
+       pRef2Obj = PRef2ConceptDef  <$ pKey "CONCEPT"   <*> pConceptName <|>
+                  PRef2Declaration <$ pKey "RELATION"  <*> pNamedRel    <|>
+                  PRef2Rule        <$ pKey "RULE"      <*> pADLid       <|>
+                  PRef2IdentityDef <$ pKey "IDENT"     <*> pADLid       <|>
+                  PRef2ViewDef     <$ pKey "VIEW"      <*> pADLid       <|>
+                  PRef2Pattern     <$ pKey "PATTERN"   <*> pADLid       <|>
+                  PRef2Pattern     <$ pKey "PROCESS"   <*> pADLid       <|>
+                  PRef2Interface   <$ pKey "INTERFACE" <*> pADLid       <|>
+                  PRef2Context     <$ pKey "CONTEXT"   <*> pADLid
+
+pPopulation :: AmpParser P_Population
+pPopulation = prelpop <$> pKey_pos "POPULATION" <*> pNamedRel    <* pKey "CONTAINS" <*> pContent <|>
+              pcptpop <$> pKey_pos "POPULATION" <*> pConceptName <* pKey "CONTAINS" <*> (pSpec '[' *> pListSep pComma pString <* pSpec ']')
+    where
+      prelpop :: Origin -> P_NamedRel -> Pairs -> P_Population
+      prelpop orig (PNamedRel _ nm mSgn)  contents =
+        case mSgn of Nothing  -> P_RelPopu { p_rnme   = nm
+                                           , p_orig   = orig
+                                           , p_popps  = contents
+                                           }
+                     Just sgn -> P_TRelPop { p_rnme   = nm
+                                           , p_type   = sgn
+                                           , p_orig   = orig
+                                           , p_popps  = contents
+                                           }
+                                           
+      pcptpop :: Origin -> String -> [String] -> P_Population
+      pcptpop    orig      cnm       contents
+       = P_CptPopu { p_cnme   = cnm
+                   , p_orig   = orig
+                   , p_popas  = contents
+                   }
+
+pRoleRelation :: AmpParser P_RoleRelation
+pRoleRelation      = rr <$> pKey_pos "ROLE"              <*>
+                            pList1Sep (pSpec ',') pRole <*
+                            pKey "EDITS"                 <*>
+                            pList1Sep (pSpec ',') pNamedRel
+                     where rr p roles rels = P_RR roles rels p
+
+pRoleRule :: AmpParser P_RoleRule
+pRoleRule         = rr <$> pKey_pos "ROLE"               <*>
+                           pList1Sep (pSpec ',') pRole  <*
+                           pKey "MAINTAINS"              <*>
+                           pList1Sep (pSpec ',') pADLid
+                    where rr p roles rulIds = Maintain roles rulIds p
+pRole :: AmpParser Role
+pRole =  Role <$> pADLid
+
+pPrintThemes :: AmpParser [String]
+pPrintThemes = pKey "THEMES"
+            *> pList1Sep (pSpec ',') pConceptName  -- Patterns, processes and concepts share the same name space, so these names must be checked whether the processes and patterns exist.
+pMeaning :: AmpParser PMeaning
+pMeaning = rebuild <$  pKey "MEANING"
+                   <*> pMaybe pLanguageRef
+                   <*> pMaybe pTextMarkup
+                   <*> (pString <|> pExpl)
+   where rebuild :: Maybe Lang -> Maybe PandocFormat -> String -> PMeaning
+         rebuild    lang          fmt                   mkup   =
+            PMeaning (P_Markup lang fmt mkup)
+pMessage :: AmpParser PMessage
+pMessage = rebuild <$ pKey "MESSAGE"
+                   <*> pMaybe pLanguageRef
+                   <*> pMaybe pTextMarkup
+                   <*> (pString <|> pExpl)
+   where rebuild :: Maybe Lang -> Maybe PandocFormat -> String -> PMessage
+         rebuild    lang          fmt                   mkup   =
+            PMessage (P_Markup lang fmt mkup)
+
+{-  Basically we would have the following expression syntax:
+pRule ::= pTrm1   "="    pTerm                           |  -- equivalence
+       pTrm1   "|-"   pTerm                           |  -- implication or subset
+       pTrm1 .
+pTerm ::= pList1Sep "/\\" pTrm2                          |  -- intersection
+       pList1Sep "\\/" pTrm2                          |  -- union
+       pTrm2 .
+pTrm2 ::= pTrm3    "-"    pTrm3                          |  -- set difference
+       pTrm3 .
+pTrm3 ::= pTrm4   "\\"   pTrm4                           |  -- right residual
+       pTrm4   "/"    pTrm4                           |  -- left residual
+       pTrm4 .
+pTrm4 ::= pList1Sep ";" pTrm5                            |  -- composition       (semicolon)
+       pList1Sep "!" pTrm5                            |  -- relative addition (dagger)
+       pList1Sep "#" pTrm5                            |  -- cartesian product (asterisk)
+       pTrm5 .
+pTrm5 ::= "-"     pTrm6                                  |  -- unary complement
+       pTrm6   pSign                                  |  -- unary type cast
+       pTrm6   "~"                                    |  -- unary flip
+       pTrm6   "*"                                    |  -- unary Kleene star
+       pTrm6   "+"                                    |  -- unary Kleene plus
+       pTrm6 .
+pTrm6 ::= pRelation                                      |
+       "("   pTerm   ")" .
+In practice, we have it a little different.
+ - In order to avoid "associative" brackets, we parse the associative operators "\/", "/\", ";", and "!" with pList1Sep. That works.
+ - We would like the user to disambiguate between "=" and "|-" by using brackets.
+-}
+
+{- In theory, the expression is parsed by:
+pRule :: AmpParser (Term TermPrim)
+pRule  =  fEequ <$> pTrm1  <*>  pKey_pos "="   <*>  pTerm   <|>
+          fEimp <$> pTrm1  <*>  pKey_pos "|-"  <*>  pTerm   <|>
+          pTrm1
+          where fequ  lExp orig rExp = PEqu orig lExp rExp
+                fEimp lExp orig rExp = PImp orig lExp rExp
+-- However elegant, this solution needs to be left-factored in order to get a performant parser.
+-}
+pRule :: AmpParser (Term TermPrim)
+pRule  =  pTerm <??> (fEqu  <$> pKey_pos "="  <*> pTerm <|>
+                      fImpl <$> pKey_pos "|-" <*> pTerm )
+          where fEqu  orig rExp lExp = PEqu orig lExp rExp
+                fImpl orig rExp lExp = PImp orig lExp rExp
+
+{-
+pTrm1 is slightly more complicated, for the purpose of avoiding "associative" brackets.
+The idea is that each operator ("/\\" or "\\/") can be parsed as a sequence without brackets.
+However, as soon as they are combined, brackets are needed to disambiguate the combination.
+There is no natural precedence of one operator over the other.
+Brackets are enforced by parsing the subexpression as pTrm5.
+In order to maintain performance standards, the parser is left factored.
+The functions pars and f have arguments 'combinator' and 'operator' only to avoid writing the same code twice.
+-}
+pTerm :: AmpParser (Term TermPrim)
+pTerm   = pTrm2 <??> (f PIsc <$> pars PIsc "/\\" <|> f PUni <$> pars PUni "\\/")
+          where pars combinator operator
+                 = g <$> pKey_pos operator <*> pTrm2 <*> pMaybe (pars combinator operator)
+                          where g orig y Nothing  = (orig, y)
+                                g orig y (Just (org,z)) = (orig, combinator org y z)
+                f combinator (orig, y) x = combinator orig x y
+
+-- The left factored version of difference: (Actually, there is no need for left-factoring here, but no harm either)
+pTrm2 :: AmpParser (Term TermPrim)
+pTrm2   = pTrm3 <??> (f <$> pKey_pos "-" <*> pTrm3)
+          where f orig rExp lExp = PDif orig lExp rExp
+
+-- The left factored version of right- and left residuals:
+pTrm3 :: AmpParser (Term TermPrim)
+pTrm3  =  pTrm4 <??> (fLrs <$> pKey_pos "/" <*> pTrm4 <|> fRrs <$> pKey_pos "\\"  <*> pTrm4 <|> fDia <$> pKey_pos "<>" <*> pTrm4 )
+          where fLrs orig rExp lExp = PLrs orig lExp rExp
+                fRrs orig rExp lExp = PRrs orig lExp rExp
+                fDia orig rExp lExp = PDia orig lExp rExp
+
+{- by the way, a slightly different way of getting exactly the same result is:
+pTrm3 :: AmpParser (Term TermPrim)
+pTrm3  =  pTrm4 <??> (f <$>  (pKey_val_pos "/" <|> pKey_val_pos "\\" <|> pKey_val_pos "<>") <*> pTrm4 )
+          where f ("\\", orig) rExp lExp = PRrs orig lExp rExp
+                f ("/" , orig) rExp lExp = PLrs orig lExp rExp
+                f (_   , orig) rExp lExp = PDia orig lExp rExp
+-}
+
+-- composition and relational addition are associative, and parsed similar to union and intersect...
+pTrm4 :: AmpParser (Term TermPrim)
+pTrm4   = pTrm5 <??> (f PCps <$> pars PCps ";" <|> f PRad <$> pars PRad "!" <|> f PPrd <$> pars PPrd "#")
+          where pars combinator operator
+                 = g <$> pKey_pos operator <*> pTrm5 <*> pMaybe (pars combinator operator)
+                          where g orig y Nothing  = (orig, y)
+                                g orig y (Just (org,z)) = (orig, combinator org y z)
+                f combinator (orig, y) x = combinator orig x y
+
+pTrm5 :: AmpParser (Term TermPrim)
+pTrm5  =  f <$> pList (pKey_val_pos "-") <*> pTrm6  <*> pList ( pKey_val_pos "~" <|> pKey_val_pos "*" <|> pKey_val_pos "+" )
+          where f ms pe (("~",_):ps) = let x=f ms pe ps in PFlp (origin x) x  -- the type checker requires that the origin of x is equal to the origin of its converse.
+                f ms pe (("*",orig):ps) = PKl0 orig (f ms pe ps)              -- e*  Kleene closure (star)
+                f ms pe (("+",orig):ps) = PKl1 orig (f ms pe ps)              -- e+  Kleene closure (plus)
+                f (_:_:ms) pe ps        = f ms pe ps                          -- -e  complement     (unary minus)
+                f ((_,orig):ms) pe ps   = let x=f ms pe ps in PCpl orig x     -- the type checker requires that the origin of x is equal to the origin of its complement.
+                f _ pe _                = pe
+
+pTrm6 :: AmpParser (Term TermPrim)
+pTrm6  =  (Prim <$> pRelationRef)  <|>
+          PBrk <$>  pSpec_pos '('  <*>  pTerm  <*  pSpec ')'
+
+pRelationRef :: AmpParser TermPrim
+pRelationRef      = PNamedR <$> pNamedRel                                                           <|>
+                    pid   <$> pKey_pos "I"  <*> pMaybe (pSpec '[' *> pConceptOneRef <* pSpec ']')  <|>
+                    pfull <$> pKey_pos "V"  <*> pMaybe pSign                                       <|>
+                    singl <$> pAtom_val_pos <*> pMaybe (pSpec '[' *> pConceptOneRef <* pSpec ']')
+                    where pid orig Nothing = PI orig
+                          pid orig (Just c)= Pid orig c
+                          pfull orig Nothing = PVee orig
+                          pfull orig (Just (P_Sign src trg)) = Pfull orig src trg
+                          singl (nm,orig) x  = Patm orig nm x
+
+pNamedRel :: AmpParser P_NamedRel
+pNamedRel = pnamedrel  <$> pVarid_val_pos <*> pMaybe pSign
+            where pnamedrel (nm,orig) mSgn = PNamedRel orig nm mSgn
+
+pSign :: AmpParser P_Sign
+pSign = mkSign <$ pSpec '[' <*> pConceptOneRef <*> pMaybe (pKey "*" *> pConceptOneRef) <* pSpec ']'
+   where mkSign :: P_Concept -> Maybe P_Concept -> P_Sign
+         mkSign src mTgt =
+           case mTgt of Just tgt -> P_Sign src tgt
+                        Nothing  -> P_Sign src src
+
+pConceptName ::   AmpParser String
+pConceptName    = pConid <|> pString
+
+pConceptRef ::    AmpParser P_Concept
+pConceptRef     = PCpt <$> pConceptName
+
+pConceptOneRef :: AmpParser P_Concept
+pConceptOneRef  = (P_Singleton <$ pKey "ONE") <|> pConceptRef
+
+pConceptRefPos :: AmpParser (P_Concept, Origin)
+pConceptRefPos     = conid <$> pConid_val_pos   <|>   conid <$> pString_val_pos
+                     where conid :: (String, Origin) ->  (P_Concept, Origin)
+                           conid (c,orig) = (PCpt c, orig)
+
+pConceptOneRefPos :: AmpParser (P_Concept, Origin)
+pConceptOneRefPos  = singl <$> pKey_pos "ONE"   <|>   conid <$> pConid_val_pos   <|>   conid <$> pString_val_pos
+                     where singl :: Origin ->  (P_Concept, Origin)
+                           singl orig     = (P_Singleton, orig)
+                           conid :: (String, Origin) ->  (P_Concept, Origin)
+                           conid (c,orig) = (PCpt c, orig)
+
+--  (SJ) Why does a label have (optional) strings?
+--  (GM) This is a binding mechanism for implementation specific properties, such as SQL/PHP plug,PHP web app,etc.
+--  (SJ April 15th, 2013) Since KEY has been replaced by IDENT and VIEW, there is a variant with props  (pLabelProps) and one without (pLabel).
+pLabelProps :: AmpParser Label
+pLabelProps       = lbl <$> pADLid_val_pos
+                        <*> (pArgs `opt` [])
+                        <*  pKey_pos ":"
+                    where lbl :: (String, Origin) -> [[String]] -> Label
+                          lbl (nm,pos') strs = Lbl nm pos' strs
+                          pArgs = pSpec '{' *> pList1Sep (pSpec ',') (pList1 pADLid) <* pSpec '}'
+
+pLabel :: AmpParser Label
+pLabel       = lbl <$> pADLid_val_pos <*  pKey ":"
+               where lbl :: (String, Origin) -> Label
+                     lbl (nm,pos') = Lbl nm pos' []
+
+pContent :: AmpParser Pairs
+pContent          = pSpec '[' *> pListSep pComma pRecord <* pSpec ']'
+                <|> pSpec '[' *> pListSep (pKey ";") pRecordObs <* pSpec ']' --obsolete
+    where
+    pRecord = mkPair<$> pString <* pKey "*" <*> pString
+    pRecordObs = mkPair<$ pSpec '(' <*> pString <* pComma   <*> pString <* pSpec ')' --obsolete
+
+pADLid :: AmpParser String
+pADLid            = pVarid <|> pConid <|> pString
+
+pADLid_val_pos :: AmpParser (String, Origin)
+pADLid_val_pos    = pVarid_val_pos <|> pConid_val_pos <|> pString_val_pos
+
+pMaybe :: IsParser p s => p a -> p (Maybe a)
+pMaybe p = Just <$> p <|> pSucceed Nothing
+
+
+get_tok_pos :: Token -> Origin
+get_tok_pos     (Tok _ _ s l f) = FileLoc(FilePos (f,l,s))
+get_tok_val_pos :: Token -> (String, Origin)
+get_tok_val_pos (Tok _ _ s l f) = (s,FileLoc(FilePos (f,l,s)))
+
+gsym_pos :: IsParser p Token => TokenType -> String -> String -> p Origin
+gsym_pos kind val' val2' = get_tok_pos <$> pSym (Tok kind val' val2' noPos "")
+
+gsym_val_pos :: IsParser p Token => TokenType -> String -> String -> p (String,Origin)
+gsym_val_pos kind val' val2' = get_tok_val_pos <$> pSym (Tok kind val' val2' noPos "")
+
+pKey_pos :: String -> AmpParser Origin
+pKey_pos keyword  =   gsym_pos TkKeyword   keyword   keyword
+pSpec_pos :: Char -> AmpParser Origin
+pSpec_pos s       =   gsym_pos TkSymbol    [s]       [s]
+
+pString_val_pos, pVarid_val_pos, pConid_val_pos, pAtom_val_pos ::  IsParser p Token => p (String,Origin)
+pString_val_pos    =   gsym_val_pos TkString    ""        "?STR?"
+pVarid_val_pos     =   gsym_val_pos TkVarid     ""        "?LC?"
+pConid_val_pos     =   gsym_val_pos TkConid     ""        "?UC?"
+pAtom_val_pos      =   gsym_val_pos TkAtom      ""        ""    -- TODO: does not escape, i.e. 'Mario\'s Pizzas' will fail to parse
+pKey_val_pos ::  IsParser p Token => String -> p (String,Origin)
+pKey_val_pos keyword = gsym_val_pos TkKeyword   keyword   keyword
+--   pSpec_val_pos ::  IsParser p Token => Char -> p (String,Origin)
+--   pSpec_val_pos s      = gsym_val_pos TkSymbol    [s]       [s]

+ src/Database/Design/Ampersand/Input/ADL1/UU_BinaryTrees.hs view
@@ -0,0 +1,67 @@+module Database.Design.Ampersand.Input.ADL1.UU_BinaryTrees
+   ( BinSearchTree(..)
+   , tab2tree
+   , btFind
+   , btLocateIn
+   )
+   where
+
+   data BinSearchTree av
+    = Node (BinSearchTree av) av (BinSearchTree av)
+    | Nil
+
+   tab2tree :: [av] -> BinSearchTree av
+   tab2tree tab = tree
+    where
+     (tree,[]) = sl2bst (length tab) tab
+     sl2bst 0 list     = (Nil   , list)
+     sl2bst n list
+      = let
+         ll = (n - 1) `div` 2 ; rl = n - 1 - ll
+         (lt,a:list1) = sl2bst ll list
+         (rt,  list2) = sl2bst rl list1
+        in (Node lt a rt, list2)
+
+   btFind :: (a -> b -> Ordering) -> BinSearchTree (a, c) -> b -> Maybe c
+   btLocateIn :: (a -> b -> Ordering) -> BinSearchTree a      -> b -> Maybe a
+   btFind     = btLookup fst snd
+   btLocateIn = btLookup id id
+   btLookup :: (d -> a) -> (d -> c) -> (a -> b -> Ordering) -> BinSearchTree d -> (b -> Maybe c)
+   btLookup  key val cmp (Node Nil  kv Nil)
+     =  let comp = cmp (key kv)
+            r    = val kv
+        in \i -> case comp i of
+                 LT -> Nothing
+                 EQ -> Just r
+                 GT -> Nothing
+
+   btLookup key val cmp (Node left kv Nil)
+     =  let comp = cmp (key kv)
+            findleft = btLookup key val cmp left
+            r    = val kv
+        in \i -> case comp i of
+                 LT -> Nothing
+                 EQ -> Just r
+                 GT -> findleft i
+
+   btLookup key val cmp (Node Nil kv right )
+     =  let comp      = cmp (key kv)
+            findright = btLookup key val cmp right
+            r         = val kv
+            in \i -> case comp i of
+                     LT -> findright i
+                     EQ -> Just r
+                     GT -> Nothing
+
+   btLookup key val cmp (Node left kv right)
+     =  let comp = cmp (key kv)
+            findleft  = btLookup key val cmp left
+            findright = btLookup key val cmp right
+            r    = val kv
+        in \i -> case comp i of
+                 LT -> findright i
+                 EQ -> Just r
+                 GT -> findleft i
+
+   btLookup _ _ _ Nil   =  const Nothing
+

+ src/Database/Design/Ampersand/Input/ADL1/UU_Scanner.hs view
@@ -0,0 +1,336 @@+{-# LANGUAGE FlexibleContexts, MultiParamTypeClasses, MagicHash #-}
+module Database.Design.Ampersand.Input.ADL1.UU_Scanner 
+         ( scan,initPos,Pos(..)
+         , Token(..),TokenType(..),noPos
+         , pKey,pConid,pString,pSpec,pExpl,pVarid,pComma,pInteger,pSemi)
+where
+
+import Data.Char hiding(isSymbol)
+import Data.List
+import Data.Maybe
+import Database.Design.Ampersand.Input.ADL1.UU_BinaryTrees(tab2tree,btLocateIn)
+import UU.Parsing(Symbol(..),IsParser,pSym,(<$>))
+import Database.Design.Ampersand.Basics (fatalMsg)
+fatal :: Int -> String -> a
+fatal = fatalMsg "UU_Scanner"
+
+data TokenType
+  = TkSymbol
+  | TkVarid
+  | TkConid
+  | TkKeyword
+  | TkOp
+  | TkString
+  | TkExpl
+  | TkAtom
+  | TkChar
+  | TkInteger8
+  | TkInteger10
+  | TkInteger16
+  | TkTextnm
+  | TkTextln
+  | TkSpace
+  | TkError
+  deriving (Eq, Ord)
+
+type Line = Int
+type Column = Int
+
+data Pos = Pos{line:: !Line, column:: !Column} deriving (Eq, Ord, Show)
+type Filename   = String
+
+data Token = Tok { tp' :: TokenType
+                 , val1 :: String
+                 , val2 :: String
+                 , pos :: !Pos
+                 , file :: !Filename
+                 }
+
+instance Eq Token where
+  --(Tok TkOp       ""      l _ _) ==  (Tok TkOp       ""      r _ _) =  l == r
+  --(Tok TkOp       ""      l _ _) ==  (Tok TkOp       r       _ _ _) =  l == r
+  --(Tok TkOp       l       _ _ _) ==  (Tok TkOp       ""      r _ _) =  l == r
+  (Tok ttypel     stringl _ _ _) ==  (Tok ttyper     stringr _ _ _) =  ttypel == ttyper && stringl == stringr
+
+instance   Ord Token where
+  compare x y | x==y      = EQ
+              | x<=y      = LT
+              | otherwise = GT
+  (Tok ttypel     stringl _ _ _ ) <= (Tok ttyper    stringr _ _  _ )
+      =     ttypel <  ttyper
+        || (ttypel == ttyper && stringl <= stringr)
+
+maybeshow :: Pos -> Filename -> String
+maybeshow (Pos 0 0) _  =  ""
+maybeshow (Pos l c) fn =  " at line " ++ show l
+                       ++ ", column " ++ show c
+                       ++ " of file " ++ show fn
+
+initPos :: Pos
+initPos = Pos 1 1
+
+noPos :: Pos
+noPos = Pos 0 0
+
+advl ::  Line -> Pos ->Pos
+advl i (Pos l _) = Pos (l+i) 1
+
+advc :: Column -> Pos ->  Pos
+advc i (Pos l c) = Pos l (c+i)
+
+adv :: Pos -> Char -> Pos
+adv pos' c = case c of
+  '\t' -> advc (tabWidth (column pos')) pos'
+  '\n' -> advl 1 pos'
+  _    -> advc 1 pos'
+
+tabWidth :: Column -> Int
+tabWidth c = 8 - ((c-1) `mod` 8)
+
+instance Show Token where
+  showsPrec _ token'
+    = showString
+       (case token' of
+        (Tok TkSymbol    _  s2 i fn)  -> "symbol "                ++ s2         ++ maybeshow i fn
+        (Tok TkOp        _  s2 i fn)  -> "operator "              ++ s2         ++ maybeshow i fn
+        (Tok TkKeyword   _  s2 i fn)  ->                        show s2         ++ maybeshow i fn
+        (Tok TkString    _  s2 i fn)  -> "string \""              ++ s2 ++ "\"" ++ maybeshow i fn
+        (Tok TkExpl      _  s2 i fn)  -> "explanation {+"         ++ s2 ++ "-}" ++ maybeshow i fn
+        (Tok TkAtom      _  s2 i fn)  -> "atom '"                 ++ s2 ++ "'"  ++ maybeshow i fn
+        (Tok TkChar      _  s2 i fn)  -> "character '"            ++ s2 ++ "'"  ++ maybeshow i fn
+        (Tok TkInteger8  _  s2 i fn)  -> "octal integer "         ++ s2         ++ maybeshow i fn
+        (Tok TkInteger10 _  s2 i fn)  -> "decimal Integer "       ++ s2         ++ maybeshow i fn
+        (Tok TkInteger16 _  s2 i fn)  -> "hexadecimal integer "   ++ s2         ++ maybeshow i fn
+        (Tok TkVarid     _  s2 i fn)  -> "lower case identifier " ++ s2         ++ maybeshow i fn
+        (Tok TkConid     _  s2 i fn)  -> "upper case identifier " ++ s2         ++ maybeshow i fn
+        (Tok TkTextnm    _  s2 i fn)  -> "text name "             ++ s2         ++ maybeshow i fn
+        (Tok TkTextln    _  s2 i fn)  -> "text line "             ++ s2         ++ maybeshow i fn
+        (Tok TkSpace     _  _  i fn)  -> "spaces "                              ++ maybeshow i fn
+        (Tok TkError     _  s2 i fn)  -> "error in scanner: "     ++ s2         ++ maybeshow i fn
+       )
+
+instance  Symbol Token where
+  deleteCost (Tok TkKeyword _ _ _ _) = 10#
+  deleteCost _                       = 5#
+
+keyToken,token :: TokenType -> String -> Pos -> Filename -> Token
+keyToken tp key  = Tok tp key key
+token  tp  = Tok tp ""
+
+errToken :: String -> Pos -> Filename -> Token
+errToken = token TkError
+
+scan :: [String] -> [String] -> String -> String -> String -> Pos -> String -> [Token]
+scan keywordstxt keywordsops specchars opchars fn pos' input
+  = doScan pos' input
+
+ where
+   locatein :: Ord a => [a] -> a -> Bool
+   locatein es = isJust . btLocateIn compare (tab2tree (sort es))
+   iskw     = locatein keywordstxt
+   isop     = locatein keywordsops
+   isSymbol = locatein specchars
+   isOpsym  = locatein opchars
+
+   isIdStart c = isLower c || c == '_'
+
+   isIdChar c =  isAlphaNum c
+--               || c == '\''   -- character literals are not used in Ampersand. Since this scanner was used for Haskell-type languages, this alternative is commented out...
+              || c == '_'
+
+   scanIdent p s = let (name,rest) = span isIdChar s
+                   in (name,advc (length name) p,rest)
+   doScan _ [] = []
+   doScan p (c:s)        | isSpace c = let (sp,next) = span isSpace s
+                                       in  doScan (foldl adv p (c:sp)) next
+
+   doScan p ('-':'-':s)  = doScan p (dropWhile (/= '\n') s)
+   doScan p ('-':'+':s)  = token TkExpl (dropWhile isSpace (takeWhile (/= '\n') s)) p fn
+                           : doScan p (dropWhile (/= '\n') s)
+   doScan p ('{':'-':s)  = lexNest fn doScan (advc 2 p) s
+   doScan p ('{':'+':s)  = lexExpl fn doScan (advc 2 p) s
+   doScan p ('"':ss)
+     = let (s,swidth,rest) = scanString ss
+       in if null rest || head rest /= '"'
+             then errToken "Unterminated string literal" p fn : doScan (advc swidth p) rest
+             else token TkString s p fn : doScan (advc (swidth+2) p) (tail rest)
+{- In Ampersand, atoms may be promoted to singleton relations by single-quoting them. For this purpose, we treat
+   single quotes exactly as the double quote for strings. That substitutes the scanner code for character literals. -}
+   doScan p ('\'':ss)
+     = let (s,swidth,rest) = scanAtom ss
+       in if null rest || head rest /= '\''
+             then errToken "Unterminated atom literal" p fn : doScan (advc swidth p) rest
+             else token TkAtom s p fn : doScan (advc (swidth+2) p) (tail rest)
+
+
+   -- In Haskell infix identifiers consist of three separate tokens(two backquotes + identifier)
+   doScan p ('`':ss)
+     = case ss of
+         []    -> [errToken "Unterminated infix identifier" p fn]
+         (c:s) -> let res | isIdStart c || isUpper c =
+                                   let (name,p1,rest) = scanIdent (advc 2 p) s
+                                       ident = c:name
+                                       tokens | null rest ||
+                                                head rest /= '`' = errToken "Unterminated infix identifier" p fn
+                                                                 : doScan p1 rest
+                                              | iskw ident       = errToken ("Keyword used as infix identifier: " ++ ident) p fn
+                                                                 : doScan (advc 1 p1) (tail rest)
+                                              | otherwise        = token TkOp ident p fn
+                                                                 : doScan (advc 1 p1) (tail rest)
+                                   in tokens
+                          | otherwise = errToken ("Unexpected character in infix identifier: " ++ show c) p fn
+                                      : doScan (adv p c) s
+                  in res
+   doScan p cs@(c:s)
+     | isSymbol c = keyToken TkSymbol [c] p fn
+                  : doScan(advc 1 p) s
+     | isIdStart c || isUpper c
+         = let (name', p', s')    = scanIdent (advc 1 p) s
+               name               = c:name'
+               tok    | iskw name = keyToken TkKeyword name p fn
+                      | null name' && isSymbol c
+                                  = keyToken TkSymbol [c] p fn
+                      | otherwise = token (if isIdStart c then TkVarid else TkConid) name p fn
+           in tok :  doScan p' s'
+     | isOpsym c = let (name, s') = getOp cs   -- was:      span isOpsym cs
+                       tok | isop name = keyToken TkKeyword name p fn
+                           | otherwise = keyToken TkOp name p fn
+                   in tok : doScan (foldl adv p name) s'
+     | isDigit c = let (tktype,number,width,s') = getNumber cs
+                   in  token tktype number p fn : doScan (advc width p) s'
+     | otherwise = errToken ("Unexpected character " ++ show c) p fn
+                 : doScan (adv p c) s
+
+   getOp cs -- the longest prefix of cs occurring in keywordsops
+    = f keywordsops cs ""
+      where
+       f ops (e:s) op = if null [s' | o:s'<-ops, e==o] then (op,e:s) --was: f ops (e:s) op = if and (map null ops) then (op,e:s) --b.joosten
+                        else f [s' | o:s'<-ops, e==o] s (op++[e])
+       f []  _     _  = ("",cs)
+       f _   []    op = (op,[])
+
+lexNest :: Filename -> (Pos -> [Char] -> [Token]) -> Pos -> [Char] -> [Token]
+lexNest fn cont pos' inp = lexNest' cont pos' inp
+ where lexNest' c p ('-':'}':s) = c (advc 2 p) s
+       lexNest' c p ('{':'-':s) = lexNest' (lexNest' c) (advc 2 p) s
+       lexNest' c p (x:s)       = lexNest' c (adv p x) s
+       lexNest' _ _ []          = [ errToken "Unterminated nested comment" pos' fn ]
+
+lexExpl :: Filename -> (Pos -> [Char] -> [Token]) -> Pos -> [Char] -> [Token]
+lexExpl fn cont pos' inp = lexExpl' "" cont pos' inp
+ where lexExpl' str c p ('-':'}':s) = token TkExpl str p fn: c (advc 2 p) s
+       lexExpl' str c p ('{':'-':s) = lexNest fn (lexExpl' str c) (advc 2 p) s
+       lexExpl' str c p ('-':'-':s) = lexExpl' str c  p (dropWhile (/= '\n') s)
+       lexExpl' str c p (x:s)       = lexExpl' (str++[x]) c (adv p x) s
+       lexExpl' _ _ _ []            = [ errToken "Unterminated PURPOSE section" pos' fn ]
+
+scanString :: [Char] -> ([Char],Int,[Char])
+scanString []            = ("",0,[])
+scanString ('\\':'&':xs) = let (str,w,r) = scanString xs  -- TODO: why do we ignore \& ?  
+                           in (str,w+2,r)
+scanString ('\\':'\'':xs) = let (str,w,r) = scanString xs -- escaped single quote: \'  (redundant, but allowed in most languages, and it makes escaping generated code a lot easier.)    
+                           in ('\'': str,w+2,r)
+scanString ('\'':xs)     = let (str,w,r) = scanString xs  -- single quote: '
+                           in ('\'': str,w+1,r)
+scanString xs = let (ch,cw,cr) = getchar xs
+                    (str,w,r)  = scanString cr
+--                    str' = maybe "" (:str) ch
+                in maybe ("",0,xs) (\c -> (c:str,cw+w,r)) ch
+
+scanAtom :: [Char] -> ([Char],Int,[Char])
+scanAtom []              = ("",0,[])
+scanAtom ('\\':'&':xs)   = let (str,w,r) = scanAtom xs
+                           in (str,w+2,r)
+scanAtom ('"':xs)        = let (str,w,r) = scanAtom xs
+                           in ('"': str,w+1,r)
+scanAtom xs   = let (ch,cw,cr) = getchar xs
+                    (str,w,r)  = scanAtom cr
+--                    str' = maybe "" (:str) ch
+                in maybe ("",0,xs) (\c -> (c:str,cw+w,r)) ch
+
+getchar :: [Char] -> (Maybe Char, Int, [Char])
+getchar []          = (Nothing,0,[])
+getchar s@('\n':_ ) = (Nothing,0,s )
+getchar s@('\t':_ ) = (Nothing,0,s)
+getchar s@('\'':_ ) = (Nothing,0,s)
+getchar s@('"' :_ ) = (Nothing,0,s)
+getchar   ('\\':xs) = let (c,l,r) = getEscChar xs
+                      in (c,l+1,r)
+getchar (x:xs)      = (Just x,1,xs)
+
+getEscChar :: [Char] -> (Maybe Char, Int, [Char])
+getEscChar [] = (Nothing,0,[])
+getEscChar s@(x:xs) | isDigit x = let (tp,n,len,rest) = getNumber s
+                                      val = case tp of
+                                              TkInteger8  -> readn 8  n
+                                              TkInteger16 -> readn 16 n
+                                              TkInteger10 -> readn 10 n
+                                              _           -> fatal 279 "getExcChar: unknown tokentype."
+                                  in  if val >= 0 && val <= 255
+                                         then (Just (chr val),len, rest)
+                                         else (Nothing,1,rest)
+                    | otherwise = case x `lookup` cntrChars of
+                                 Nothing -> (Nothing,0,s)
+                                 Just c  -> (Just c,1,xs)
+  where cntrChars = [('a','\a'),('b','\b'),('f','\f'),('n','\n'),('r','\r'),('t','\t')
+                    ,('v','\v'),('\\','\\'),('"','\"')]
+-- character literals are not used in Ampersand. Since this scanner was used for Haskell-type languages, ('\'','\'') has been removed from cntrChars...
+
+readn :: Int -> [Char] -> Int
+readn base = foldl (\r x  -> value x + base * r) 0
+
+getNumber :: [Char] -> (TokenType, [Char], Int, [Char])
+getNumber [] = fatal 294 "getNumber" 
+getNumber cs@(c:s)
+  | c /= '0'         = num10
+  | null s           = const0
+  | hs `elem` "xX"   = num16
+  | hs `elem` "oO"   = num8
+  | otherwise        = num10
+  where (hs:ts) = s
+        const0 = (TkInteger10, "0",1,s)
+        num10  = let (n,r) = span isDigit cs
+                 in (TkInteger10,n,length n,r)
+        num16   = readNum isHexaDigit  ts TkInteger16
+        num8    = readNum isOctalDigit ts TkInteger8
+        readNum p ts' tk
+          = let (n,rs) = span p ts'
+            in  if null n then const0
+                          else (tk         , n, 2+length n,rs)
+
+isHexaDigit :: Char -> Bool
+isHexaDigit  d = isDigit d || (d >= 'A' && d <= 'F') || (d >= 'a' && d <= 'f')
+isOctalDigit :: Char -> Bool
+isOctalDigit d = d >= '0' && d <= '7'
+
+value :: Char -> Int
+value c | isDigit c = ord c - ord '0'
+        | isUpper c = ord c - ord 'A' + 10
+        | isLower c = ord c - ord 'a' + 10
+        | otherwise = fatal 321 ("value undefined for '"++ show c++"'")
+
+get_tok_val :: Token -> String
+get_tok_val (Tok _ _ s _ _) = s
+
+gsym :: IsParser p Token => TokenType -> String -> String -> p String
+gsym kind val val2' = get_tok_val <$> pSym (Tok kind val val2' noPos "")
+pKey :: IsParser p Token => String -> p String
+pKey  keyword  =   gsym TkKeyword   keyword   keyword
+pSpec :: IsParser p Token => Char -> p String
+pSpec s        =   gsym TkSymbol    [s]       [s]
+
+pString, pExpl, pInteger10, pVarid, pConid,
+  pInteger :: IsParser p Token => p String
+pString        =   gsym TkString    ""        ""
+pExpl          =   gsym TkExpl      ""        ""
+pInteger10     =   gsym TkInteger10 ""        "1"
+pVarid         =   gsym TkVarid     ""        "?lc?"
+pConid         =   gsym TkConid     ""        "?uc?"
+
+pInteger       =   pInteger10
+
+pComma, pSemi :: IsParser p Token => p String
+pComma  = pSpec ','
+pSemi   = pSpec ';'
+
+

+ src/Database/Design/Ampersand/Input/Parsing.hs view
@@ -0,0 +1,106 @@+{-# OPTIONS_GHC  -XScopedTypeVariables #-}
+-- 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 Database.Design.Ampersand.Input.Parsing 
+  ( parseADL, parseADL1pExpr, parseRule, parseCtx
+  )
+where
+
+import Database.Design.Ampersand.ADL1
+import Prelude hiding (putStrLn, writeFile) -- make sure everything is UTF8
+import Database.Design.Ampersand.Basics
+import Database.Design.Ampersand.Misc
+import Database.Design.Ampersand.Input.ADL1.UU_Scanner (scan,initPos, Token)
+import UU.Parsing (parse, evalSteps, getMsgs, Pair(..), Message, Parser)
+import Database.Design.Ampersand.Input.ADL1.Parser
+import Database.Design.Ampersand.Input.ADL1.CtxError
+import Data.List
+import System.Directory
+import System.FilePath
+import Data.Traversable (sequenceA)
+
+fatal :: Int -> String -> a
+fatal = fatalMsg "Parsing"
+
+-- Parse an Ampersand file and all transitive includes
+parseADL  :: Options -> FilePath -> IO (Guarded P_Context)
+parseADL opts filePath =
+  whenCheckedIO (parseSingleADL opts filePath) $ \(ctxt, filePaths) ->
+    whenCheckedIO (parseADLs opts [filePath] filePaths) $ \ctxts ->
+      return $ Checked $ foldl mergeContexts ctxt ctxts
+
+parseADLs :: Options -> [FilePath] -> [FilePath] -> IO (Guarded [P_Context])
+parseADLs _    _               []        = return $ Checked []
+parseADLs opts parsedFilePaths filePaths =
+ do { let filePathsToParse = nub filePaths \\ parsedFilePaths
+    ; whenCheckedIO (fmap sequenceA $ mapM (parseSingleADL opts) filePathsToParse) $ \ctxtNewFilePathss ->
+       do { let (ctxts, newFilessToParse) = unzip ctxtNewFilePathss
+          ; whenCheckedIO (parseADLs opts (parsedFilePaths ++ filePaths) $ concat newFilessToParse) $ \ctxts' ->
+              return $ Checked $ ctxts ++ ctxts'
+          }
+    }
+
+-- Parse an Ampersand file, but not its includes (which are simply returned as a list)
+parseSingleADL :: Options -> FilePath -> IO (Guarded (P_Context, [FilePath]))
+parseSingleADL opts filePath =
+ do { verboseLn opts $ "Reading file " ++ filePath
+    ; mFileContents <- readUTF8File filePath
+    ; case mFileContents of
+        Left err -> error $ "ERROR reading file " ++ filePath ++ ":\n" ++ err 
+                    -- TODO: would like to return an Errors value here, but this datatype currently only accommodates UUParsing Messages 
+        Right fileContents ->
+         do { whenCheckedIO (return $ runParser pContext filePath fileContents) $ \(ctxts,relativePaths) -> 
+               do { filePaths <- mapM normalizePath relativePaths
+                  ; return $ Checked (ctxts, filePaths)
+                  }
+             }
+    }
+ where normalizePath relativePath = canonicalizePath $ takeDirectory filePath </> relativePath 
+
+runParser :: AmpParser res -> String -> String -> Guarded res
+runParser parser filename input =
+  let scanner = scan keywordstxt keywordsops specialchars opchars filename initPos
+      steps = parse parser (scanner input)
+  in  case  getMsgs steps of
+         []    -> let Pair res _ = evalSteps steps
+                  in  Checked res
+         msg:_ -> Errors [PE msg]
+
+runParser' :: forall res . Parser Token res -> String -> String -> Either ParseError res
+runParser' parser filename input =
+  let scanner = scan keywordstxt keywordsops specialchars opchars filename initPos
+      steps = parse parser (scanner input)
+  in  case  getMsgs steps of
+         []    -> let Pair res _ = evalSteps steps
+                  in  Right res
+         msg:_ -> Left msg
+
+
+
+
+type ParseError = Message Token (Maybe Token)
+
+-- In order to read derivation rules, we use the Ampersand parser.
+-- Since it is applied on static code only, error messagea may be produced as fatals.
+parseRule :: String -> Term TermPrim
+parseRule str
+   = case  runParser' pRule "inside Haskell code" str of
+       Right result -> result
+       Left  msg    -> fatal 274 ("Parse errors in "++str++":\n   "++show msg)
+ 
+-- | Parse isolated ADL1 expression strings
+parseADL1pExpr :: String -> String -> Either String (Term TermPrim)
+parseADL1pExpr pexprstr fn = parseExpr pexprstr fn
+
+-- | Parse isolated ADL1 expression strings
+parseExpr :: String            -- ^ The string to be parsed
+          -> String            -- ^ The name of the file (used for error messages)
+          -> Either String (Term TermPrim)  -- ^ The result: Either an error message,  or a good result
+parseExpr str fn =
+  case runParser' pTerm fn str of
+      Right result -> Right result
+      Left  msg    -> Left $ "Parse errors:\n"++show msg
+     
+parseCtx :: String -> String -> Guarded (P_Context, [String])
+parseCtx = runParser pContext
+ src/Database/Design/Ampersand/Misc.hs view
@@ -0,0 +1,13 @@+module Database.Design.Ampersand.Misc
+   ( module Database.Design.Ampersand.Misc.Languages
+   , module Database.Design.Ampersand.Misc.Options
+   , module Database.Design.Ampersand.Misc.Explain
+   ) where
+import Database.Design.Ampersand.Misc.Languages
+       (Lang(..), plural, allLangs)
+import Database.Design.Ampersand.Misc.Options
+       (getOptions, Options(..),
+        verboseLn, verbose, DocTheme(..), FSpecFormat(..),
+        FileFormat(..), helpNVersionTexts)
+import Database.Design.Ampersand.Misc.Explain
+       (string2Blocks, blocks2String, PandocFormat(..))

+ src/Database/Design/Ampersand/Misc/Explain.hs view
@@ -0,0 +1,58 @@+module Database.Design.Ampersand.Misc.Explain
+    ( string2Blocks
+    , blocks2String
+    , PandocFormat(..)
+    )
+where
+
+import Text.Pandoc
+import Data.List (isPrefixOf)
+import Database.Design.Ampersand.Core.ParseTree      (PandocFormat(..))
+
+-- | use a suitable format to read generated strings. if you have just normal text, ReST is fine.
+-- | defaultPandocReader getOpts should be used on user-defined strings.
+string2Blocks :: PandocFormat -> String -> [Block]
+string2Blocks defaultformat str
+ = case blocks of             -- WHY (SJ, dec 7th, 2011): What is the point of changing Para into Plain?
+    [Para is] -> [Plain is]   -- BECAUSE (SJ, dec 7th, 2011): The table of relations in the LaTeX output of ChapterDataAnalysis gives errors when LaTeX is run, because Para generates a newline that LaTeX cannot cope with.
+    _         -> blocks       --                              However, this Para is generated by Pandoc, so I'm wondering whether the mistake is in Pandoc? Anyway, this solution is a dirty fix, which I don't like.
+   where
+     Pandoc _ blocks = thePandocParser (removeCRs str')  --TODO: catch errors. (See ticket #460 Wrong error message in FSPEC generator when parsing )
+     removeCRs :: String -> String
+     removeCRs [] = []
+     removeCRs ('\r' :'\n' : xs) = '\n' : removeCRs xs
+     removeCRs (c:xs) = c:removeCRs xs
+     (thePandocParser,str') = whatParser2UseOnWhatString
+     whatParser2UseOnWhatString :: (String -> Pandoc,String)
+     whatParser2UseOnWhatString -- = (readRST, str)
+        | markDownPrefix `isPrefixOf` str = (readMarkdown def, drop (length markDownPrefix) str)
+        | reSTPrefix     `isPrefixOf` str = (readRST      def, drop (length reSTPrefix)     str)
+        | hTMLPrefix     `isPrefixOf` str = (readHtml     def, drop (length hTMLPrefix)     str)
+         --stateParseRaw=True e.g. such that "\ref{something}" is not read as "\{something\}". with parse raw it's read as inline latex
+         --maybe html should be parsed raw too...
+        | laTeXPrefix    `isPrefixOf` str = (readLaTeX    def, drop (length laTeXPrefix)    str)
+        | otherwise   = case defaultformat of
+                               Markdown  -> (readMarkdown def, str)
+                               ReST      -> (readRST      def, str)
+                               HTML      -> (readHtml     def, str)
+                               LaTeX     -> (readLaTeX    def, str)
+       where markDownPrefix = makePrefix Markdown
+             reSTPrefix     = makePrefix ReST
+             hTMLPrefix     = makePrefix HTML
+             laTeXPrefix    = makePrefix LaTeX
+
+makePrefix :: PandocFormat -> String
+makePrefix format = ":"++show format++":"
+
+-- | write [Block] as String in a certain format using defaultWriterOptions
+blocks2String :: PandocFormat -> Bool -> [Block] -> String
+blocks2String format writeprefix ec
+ = [c | c<-makePrefix format,writeprefix]
+   --you cannot unwords lines for all writers, because white lines have a meaning in LaTeX i.e. \par
+   --if your application of blocks2String may not have line breaks, then unwords lines there
+   ++ {- unwords -} ( {-lines $ -} writer def (Pandoc nullMeta ec))
+   where writer = case format of
+            Markdown  -> writeMarkdown
+            ReST      -> writeRST
+            HTML      -> writeHtmlString
+            LaTeX     -> writeLaTeX

+ src/Database/Design/Ampersand/Misc/Languages.hs view
@@ -0,0 +1,52 @@+-- | This module does some string manipulation based on natural languages
+module Database.Design.Ampersand.Misc.Languages
+         ( Lang(English,Dutch)
+         , allLangs
+         , plural
+         ) where
+              
+import Data.Char (toLower)
+import Data.List (isSuffixOf)
+import Database.Design.Ampersand.Core.ParseTree      (Lang(..))
+
+allLangs :: [Lang]
+allLangs = [Dutch,English] -- All supported natural languages in Ampersand
+
+-- | Returns the plural of a given word based on a specific language
+plural :: Lang -> String -> String
+plural English str
+  | null str = str
+  | last str=='y' = init str++"ies"
+  | last str=='s' = str++"es"
+  | last str=='x' = str++"es"
+  | last str=='f' = init str++"ves"
+  | otherwise     = head ([p |(s,p)<-exceptions, s==str]++[str++"s"])
+  where exceptions = [("child","children"),("Child","Children"),("mouse","mice"),("Mouse","Mice"),("sheep","sheep"),("Sheep","Sheep")]
+plural Dutch str
+  | null str = str
+  | not (null matches)    = head matches
+  | take 3 (reverse str)== reverse "ium" = (reverse.drop 3.reverse) str++"ia"
+  | take 2 (reverse str) `elem` map reverse ["el", "em", "en", "er", "um", "ie"] = str++"s"
+  | "ij" `isSuffixOf` str = str++"en"
+  | "io" `isSuffixOf` str = str++"'s"
+  | klinker (last str)    = str++"s"
+  | (take 2.drop 1.reverse) str `elem` ["aa","oo","ee","uu"] = (reverse.drop 2.reverse) str++mede (drop (length str-1) str)++"en"
+  | otherwise                  = str++"en"
+  where mede "f" = "v"
+        mede "s" = "z"
+        mede x = x
+        klinker c = c `elem` "aeiou"
+        matches = [(reverse.drop (length s).reverse) str++p |(s,p) <-exceptions, (map toLower.reverse.take (length s).reverse) str==s]
+        exceptions = [ ("aanbod", "aanbiedingen")
+                     , ("beleg", "belegeringen")
+                     , ("dank", "dankbetuigingen")
+                     , ("gedrag", "gedragingen")
+                     , ("genot", "genietingen")
+                     , ("lof", "loftuitingen")
+                     , ("lende", "lendenen")
+                     , ("onderzoek", "onderzoekingen")
+                     , ("archiefstuk", "archiefbescheiden")
+                     , ("titel", "titels")
+                     , ("plan", "plannen")
+                     , ("kind", "kinderen")
+                     ]

+ src/Database/Design/Ampersand/Misc/Options.hs view
@@ -0,0 +1,555 @@+{-# LANGUAGE PatternGuards #-}
+module Database.Design.Ampersand.Misc.Options
+        (Options(..),getOptions,usageInfo'
+        ,verboseLn,verbose,FSpecFormat(..),FileFormat(..)
+        ,DocTheme(..),helpNVersionTexts)
+where
+import System.Environment    (getArgs, getProgName,getEnvironment,getExecutablePath )
+import Database.Design.Ampersand.Misc.Languages (Lang(..))
+import System.Console.GetOpt
+import System.FilePath
+import System.Directory
+import Data.Time.Clock
+import Data.Time.LocalTime
+import Control.Monad
+import Data.Maybe
+import Database.Design.Ampersand.Basics
+import Paths_ampersand (getDataDir)
+import Prelude hiding (writeFile,readFile,getContents,putStr,putStrLn)
+import Data.List
+import Data.Char
+
+fatal :: Int -> String -> a
+fatal = fatalMsg "Misc.Options"
+
+-- | This data constructor is able to hold all kind of information that is useful to
+--   express what the user would like Ampersand to do.
+data Options = Options { showVersion :: Bool
+                       , preVersion :: String
+                       , postVersion :: String  --built in to aid DOS scripting... 8-(( Bummer.
+                       , showHelp :: Bool
+                       , verboseP :: Bool
+                       , development :: Bool
+                       , validateSQL :: Bool
+                       , validateEdit :: Maybe String -- Nothing means no edit validation
+                       , genPrototype :: Bool
+                       , dirPrototype :: String  -- the directory to generate the prototype in.
+                       , allInterfaces :: Bool
+                       , dbName :: String
+                       , genAtlas :: Bool
+                       , namespace :: String
+                       , autoRefresh :: Maybe Int
+                       , testRule :: Maybe String
+                       , customCssFile :: Maybe FilePath
+                       , importfile :: FilePath --a file with content to populate some (Populated a)
+                                                   --class Populated a where populate::a->b->a
+                       , fileformat :: Maybe FileFormat --file format e.g. of importfile or export2adl
+                       , theme :: DocTheme --the theme of some generated output. (style, content differentiation etc.)
+                       , genXML :: Bool
+                       , genFSpec :: Bool   -- if True, generate a functional specification
+                       , diag :: Bool   -- if True, generate a diagnosis only
+                       , fspecFormat :: FSpecFormat -- the format of the generated (pandoc) document(s)
+                       , genGraphics :: Bool   -- if True, graphics will be generated for use in Ampersand products like the Atlas or Functional Spec
+                       , genEcaDoc :: Bool   -- if True, generate ECA rules in the Functional Spec
+                       , proofs :: Bool
+                       , haskell :: Bool   -- if True, generate the F-structure as a Haskell source file
+                       , dirOutput :: String -- the directory to generate the output in.
+                       , outputfile :: String -- the file to generate the output in.
+                       , crowfoot :: Bool   -- if True, generate conceptual models and data models in crowfoot notation
+                       , blackWhite :: Bool   -- only use black/white in graphics
+                       , doubleEdges :: Bool   -- Graphics are generated with hinge nodes on edges.
+                       , showPredExpr :: Bool   -- for generated output, show predicate logic?
+                       , noDiagnosis :: Bool   -- omit the diagnosis chapter from the functional specification document
+                       , diagnosisOnly :: Bool   -- give a diagnosis only (by omitting the rest of the functional specification document)
+                       , genLegalRefs :: Bool   -- Generate a table of legal references in Natural Language chapter
+                       , genUML :: Bool   -- Generate a UML 2.0 data model
+                       , genFPAChap :: Bool   -- Generate Function Point Analysis chapter
+                       , genFPAExcel :: Bool   -- Generate an Excel workbook containing Function Point Analysis
+                       , genStaticFiles :: Bool-- Generate the static files into the prototype
+                       , genBericht :: Bool
+                       , language :: Maybe Lang  -- The language in which the user wants the documentation to be printed.
+                       , dirExec :: String --the base for relative paths to input files
+                       , ampersandDataDir :: FilePath -- the directory where Ampersand data files are.
+                       , progrName :: String --The name of the adl executable
+                       , fileName :: FilePath --the file with the Ampersand context
+                       , baseName :: String
+                       , logName :: FilePath
+                       , genTime :: LocalTime
+                       , export2adl :: Bool
+                       , test :: Bool
+                       , genASTTables :: Bool -- When set, generate the meta-tables of AST into the prototype
+                       , genASTFile :: Bool  -- When set, the standard RAP is 'merged' into the generated prototype.(experimental)
+                       , genGenericsFile :: Bool  -- Generate the meta-population in generics format and output it to an .adl file
+                       , genGenericTables :: Bool -- When set, generate the meta-tables of generics into the prototype
+                       , metaTablesHaveUnderscore :: Bool -- Separate the extra tables used with ASTTables or GenericTables by letting them have underscores
+                       , pangoFont :: String  -- use specified font in PanDoc. May be used to avoid pango-warnings.
+                       , sqlHost ::  String  -- do database queries to the specified host
+                       , sqlLogin :: String  -- pass login name to the database server
+                       , sqlPwd :: String  -- pass password on to the database server
+                       , oldNormalizer :: Bool
+                       , newFrontend :: Bool
+                       }
+
+getOptions :: IO Options
+getOptions =
+   do args     <- getArgs
+      progName <- getProgName
+      exePath  <- getExecutablePath -- findExecutable progName
+      dataPath <- getDataDir
+      let haskellInstallationDirectory = dataPath </> "AmpersandData"
+      existshaskellInstallationDirectory <- doesDirectoryExist  haskellInstallationDirectory
+--      putStrLn  $ "haskellInstallationDirectory: "  ++haskellInstallationDirectory
+
+      let ampersandInstallationDirectory = takeDirectory exePath </> ".." </> "AmpersandData"
+      existsampersandInstallationDirectory <- doesDirectoryExist  ampersandInstallationDirectory
+--      putStrLn  $ "ampersandInstallationDirectory: "++ampersandInstallationDirectory
+
+      let dataDir
+            | existshaskellInstallationDirectory   = haskellInstallationDirectory
+            | existsampersandInstallationDirectory = ampersandInstallationDirectory
+            | otherwise                            = exePath
+      localTime <-  do utcTime <- getCurrentTime
+                       timeZone <- getCurrentTimeZone
+                       return (utcToLocalTime timeZone utcTime)
+      env <- getEnvironment
+      let usage = "\nType '"++ progName++" --help' for usage info."
+      let (actions, fNames, errors) = getOpt Permute (map fst options) args
+      when ((not.null) errors) (error $ concat errors ++ usage)
+      let fName = case fNames of
+                   []  -> error ("Please supply the name of an ampersand file" ++ usage)
+                   [x] -> x
+                   _   -> error ("too many files: "++ intercalate ", " fNames  ++ usage)
+
+      let startOptions =
+               Options {genTime       = localTime
+                      , dirOutput     = fromMaybe "."       (lookup envdirOutput    env)
+                      , outputfile    = fatal 83 "No monadic options available."
+                      , dirPrototype  = fromMaybe ("." </> (addExtension (takeBaseName fName) ".proto"))
+                                                  (lookup envdirPrototype env) </> (addExtension (takeBaseName fName) ".proto")
+                      , dbName        = map toLower $ fromMaybe ("ampersand_"++takeBaseName fName) (lookup envdbName env)
+                      , logName       = fromMaybe "Ampersand.log" (lookup envlogName      env)
+                      , dirExec       = takeDirectory exePath
+                      , ampersandDataDir = dataDir
+                      , preVersion    = fromMaybe ""        (lookup "CCPreVersion"  env)
+                      , postVersion   = fromMaybe ""        (lookup "CCPostVersion" env)
+                      , theme         = DefaultTheme
+                      , showVersion   = False
+                      , showHelp      = False
+                      , verboseP      = False
+                      , development   = False
+                      , validateSQL   = False
+                      , validateEdit  = Nothing
+                      , genPrototype  = False
+                      , allInterfaces = False
+                      , genAtlas      = False
+                      , namespace     = []
+                      , autoRefresh   = Nothing
+                      , testRule      = Nothing
+                      , customCssFile = Nothing
+                      , importfile    = []
+                      , fileformat    = Nothing
+                      , genXML        = False
+                      , genFSpec      = False
+                      , diag          = False
+                      , fspecFormat   = fatal 105 $ "Unknown fspec format. Currently supported formats are "++allFSpecFormats++"."
+                      , genGraphics   = True
+                      , genEcaDoc     = False
+                      , proofs        = False
+                      , haskell       = False
+                      , crowfoot      = False
+                      , blackWhite    = False
+                      , doubleEdges   = False
+                      , showPredExpr  = False
+                      , noDiagnosis   = False
+                      , diagnosisOnly = False
+                      , genLegalRefs  = False
+                      , genUML        = False
+                      , genFPAChap    = False
+                      , genFPAExcel   = False
+                      , genStaticFiles= True
+                      , genBericht    = False
+                      , language      = Nothing
+                      , progrName     = progName
+                      , fileName      = if hasExtension fName
+                                        then fName
+                                        else addExtension fName "adl"
+                      , baseName      = takeBaseName fName
+                      , export2adl    = False
+                      , test          = False
+                      , genGenericTables = False
+                      , genGenericsFile       = False
+                      , genASTTables     = False
+                      , genASTFile    = False
+                      , metaTablesHaveUnderscore = False
+                      , pangoFont     = "Sans"
+                      , sqlHost       = "localhost"
+                      , sqlLogin      = "ampersand"
+                      , sqlPwd        = "ampersand"
+                      , oldNormalizer = True -- The new normalizer still has a few bugs, so until it is fixed we use the old one as the default
+                      , newFrontend   = False
+                      }
+      -- Here we thread startOptions through all supplied option actions
+      opts <- foldl (>>=) (return startOptions) actions
+      -- Now we do some checks on the options:
+      when (development opts && validateSQL opts)
+           (error "--dev and --validate must not be used at the same time.") --(Reason: see ticket #378))
+      createDirectoryIfMissing True (takeDirectory (logName opts))
+      createDirectoryIfMissing True (dirOutput opts)
+      when (genPrototype opts)
+           (createDirectoryIfMissing True (dirPrototype opts))
+      return opts
+
+data DisplayMode = Public | Hidden deriving Eq
+
+data FSpecFormat = FPandoc| Fasciidoc| Fcontext| Fdocbook| Fhtml| FLatex| Fman| Fmarkdown| Fmediawiki| Fopendocument| Forg| Fplain| Frst| Frtf| Ftexinfo| Ftextile deriving (Show, Eq)
+allFSpecFormats :: String
+allFSpecFormats = "["++intercalate ", " 
+    ((sort . map f) [FPandoc, Fasciidoc, Fcontext, Fdocbook, Fhtml, 
+                FLatex, Fman, Fmarkdown, Fmediawiki, Fopendocument
+                , Forg, Fplain, Frst, Frtf, Ftexinfo, Ftextile]) ++"]"
+    where f:: Show a => a -> String
+          f fmt = case show fmt of
+                    _:h:t -> toUpper h : map toLower t
+                    x     -> x 
+
+data FileFormat = Adl1Format | Adl1PopFormat  deriving (Show, Eq) --file format that can be parsed to some b to populate some Populated a
+data DocTheme = DefaultTheme   -- Just the functional specification
+              | ProofTheme     -- A document with type inference proofs
+              | StudentTheme   -- Output for normal students of the business rules course
+              | StudentDesignerTheme   -- Output for advanced students of the business rules course
+              | DesignerTheme   -- Output for non-students
+                 deriving (Show, Eq)
+
+
+type OptionDef = OptDescr (Options -> IO Options)
+options :: [(OptionDef, DisplayMode) ]
+options = [ (Option ['v']   ["version"]
+               (NoArg (\opts -> return opts{showVersion = True}))
+               "show version and exit."
+            , Public)
+          , (Option ['h','?'] ["help"]
+               (NoArg (\opts -> return opts{showHelp = True}))
+               "get (this) usage information."
+            , Public)
+          , (Option ['V']   ["verbose"]
+               (NoArg (\opts -> return opts{verboseP = True}))
+               "verbose error message format."
+            , Public)
+          , (Option []      ["dev"]
+               (NoArg (\opts -> return opts{development = True}))
+               "Report and generate extra development information"
+            , Hidden)
+          , (Option []      ["validate"]
+               (NoArg (\opts -> return opts{validateSQL = True}))
+               "Compare results of rule evaluation in Haskell and SQL (requires command line php with MySQL support)"
+            , Hidden)
+          , (Option []  ["validateEdit"]
+               (ReqArg (\nm opts -> return opts{validateEdit = Just nm}
+                       ) "NAME")
+               ("Compare results of applying edit operations in NAME.scr to population in NAME.before with population in NAME.after")
+            , Hidden)
+          , (Option ['p']     ["proto"]
+               (OptArg (\nm opts -> return opts {dirPrototype = fromMaybe (dirPrototype opts) nm
+                                                  ,genPrototype = True}
+                       ) "DIRECTORY")
+               ("generate a functional prototype (overwrites environment variable "++ envdirPrototype ++ ").")
+            , Public)
+          , (Option ['d']  ["dbName"]
+               (ReqArg (\nm opts -> return opts{dbName = if nm == ""
+                                                         then dbName opts
+                                                         else map toLower nm}
+                       ) "NAME")
+               ("database name (overwrites environment variable "++ envdbName ++ ", defaults to filename)")
+            , Public)
+          , (Option []      ["theme"]
+               (ReqArg (\t opts -> return opts{theme = case map toUpper t of
+                                                          "STUDENT"  -> StudentTheme
+                                                          "STUDENTDESIGNER" -> StudentDesignerTheme
+                                                          "DESIGNER" -> DesignerTheme
+                                                          "PROOF"    -> ProofTheme
+                                                          _          -> DefaultTheme}
+                        ) "THEME")
+               "differentiate between certain outputs e.g. student"
+            , Public)
+          , (Option ['x']     ["interfaces"]
+               (NoArg (\opts -> return opts{allInterfaces  = True}))
+               "generate interfaces."
+            , Public)
+          , (Option ['e']     ["export"]
+               (OptArg (\mbnm opts -> return opts{export2adl = True
+                                                   ,outputfile = fromMaybe "Export.adl" mbnm}) "file")
+               "export as plain Ampersand script."
+            , Public)
+          , (Option ['o']     ["outputDir"]
+               (ReqArg (\nm opts -> return opts{dirOutput = nm}
+                       ) "DIR")
+               ("output directory (dir overwrites environment variable "++ envdirOutput ++ ").")
+            , Public)
+          , (Option []      ["log"]
+               (ReqArg (\nm opts -> return opts{logName = nm}
+                       ) "NAME")
+               ("log file name (name overwrites environment variable "++ envlogName  ++ ").")
+            , Hidden)
+          , (Option []      ["import"]
+               (ReqArg (\nm opts -> return opts{importfile = nm}
+                       ) "FILE")
+               "import this file as the population of the context."
+            , Public)
+          , (Option []      ["fileformat"]
+               (ReqArg (\f opts -> return
+                             opts{fileformat = case map toUpper f of
+                                                 "ADL" -> Just Adl1Format
+                                                 "ADL1"-> Just Adl1Format
+                                                 "POP" -> Just Adl1PopFormat
+                                                 "POP1"-> Just Adl1PopFormat
+                                                 _     -> fileformat opts
+                                  }
+                       ) "FORMAT")
+               ("format of import file (FORMAT=ADL (.adl), ADL1 (.adl), POP (.pop), POP1 (.pop)).")
+            , Public)
+          , (Option []      ["namespace"]
+               (ReqArg (\nm opts -> return opts{namespace = nm}
+                       ) "NAMESPACE")
+               "places the population in this namespace within the context."
+            , Public)
+          , (Option ['f']   ["fspec"]
+               (ReqArg (\w opts -> return opts
+                                { genFSpec=True
+                                , fspecFormat= case map toUpper w of
+                                    ('A': _ )             -> Fasciidoc
+                                    ('C': _ )             -> Fcontext
+                                    ('D': _ )             -> Fdocbook
+                                    ('H': _ )             -> Fhtml
+                                    ('L': _ )             -> FLatex
+                                    ('M':'A':'N': _ )     -> Fman
+                                    ('M':'A': _ )         -> Fmarkdown
+                                    ('M':'E': _ )         -> Fmediawiki
+                                    ('O':'P': _ )         -> Fopendocument
+                                    ('O':'R': _ )         -> Forg
+                                    ('P':'A': _ )         -> FPandoc
+                                    ('P':'L': _ )         -> Fplain
+                                    ('R':'S': _ )         -> Frst
+                                    ('R':'T': _ )         -> Frtf
+                                    ('T':'E':'X':'I': _ ) -> Ftexinfo
+                                    ('T':'E':'X':'T': _ ) -> Ftextile
+                                    _                     -> fspecFormat opts}
+                       ) "FORMAT")
+               ("generate a functional specification document in specified format (FORMAT="++allFSpecFormats++").")
+            , Public)
+          , (Option []        ["refresh"]
+               (OptArg (\r opts -> return
+                            opts{autoRefresh = Just (case r of
+                                                       Just str | [(i,"")] <- reads str -> i
+                                                       _                                -> 5
+                                                     )}
+                       ) "INTERVAL")
+               "Experimental auto-refresh feature"
+            , Hidden)
+          , (Option []        ["testRule"]
+               (ReqArg (\ruleName opts -> return opts{ testRule = Just ruleName }
+                       ) "RULE")
+               "Show contents and violations of specified rule."
+            , Hidden)
+          , (Option []        ["css"]
+               (ReqArg (\pth opts -> return opts{ customCssFile = Just pth }) "file")
+               "Custom.css file to customize the style of the prototype."
+            , Public)
+          , (Option []        ["noGraphics"]
+               (NoArg (\opts -> return opts{genGraphics = False}))
+               "save compilation time by not generating any graphics."
+            , Public)
+          , (Option []        ["ECA"]
+               (NoArg (\opts -> return opts{genEcaDoc = True}))
+               "generate documentation with ECA rules."
+            , Public)
+          , (Option []        ["proofs"]
+               (NoArg (\opts -> return opts{proofs = True}))
+               "generate derivations."
+            , Public)
+          , (Option []        ["XML"]
+               (NoArg (\opts -> return opts{genXML = True}))
+               "generate internal data structure, written in XML (for debugging)."
+            , Public)
+          , (Option []        ["haskell"]
+               (NoArg (\opts -> return opts{haskell = True}))
+               "generate internal data structure, written in Haskell (for debugging)."
+            , Public)
+          , (Option []        ["crowfoot"]
+               (NoArg (\opts -> return opts{crowfoot = True}))
+               "generate crowfoot notation in graphics."
+            , Public)
+          , (Option []        ["blackWhite"]
+               (NoArg (\opts -> return opts{blackWhite = True}))
+               "do not use colours in generated graphics"
+            , Public)
+          , (Option []        ["doubleEdges"]
+               (NoArg (\opts -> return opts{doubleEdges = not (doubleEdges opts)}))
+               "generate graphics in an alternate way. (you may experiment with this option to see the differences for yourself)"
+            , Public)
+          , (Option []        ["predLogic"]
+               (NoArg (\opts -> return opts{showPredExpr = True}))
+               "show logical expressions in the form of predicate logic."
+            , Public)
+          , (Option []        ["noDiagnosis"]
+               (NoArg (\opts -> return opts{noDiagnosis = True}))
+               "omit the diagnosis chapter from the functional specification document."
+            , Public)
+          , (Option []        ["diagnosis"]
+               (NoArg (\opts -> return opts{diagnosisOnly = True}))
+               "diagnose your Ampersand script (generates a .pdf file)."
+            , Public)
+          , (Option []        ["legalrefs"]
+               (NoArg (\opts -> return opts{genLegalRefs = True}))
+               "generate a table of legal references in Natural Language chapter."
+            , Public)
+          , (Option []        ["uml"]
+               (NoArg (\opts -> return opts{genUML = True}))
+               "Generate a UML 2.0 data model."
+            , Hidden)
+          , (Option []        ["fpa"]
+               (NoArg (\opts -> return opts{genFPAChap = True}))
+               "Generate Function Point Analysis chapter."
+            , Hidden)
+          , (Option []        ["excel"]
+               (NoArg (\opts -> return opts{genFPAExcel = True}))
+               "Generate an Excel workbook (FPA_<filename>.xml)."
+            , Hidden)
+          , (Option []        ["bericht"]
+               (NoArg (\opts -> return opts{genBericht = True}))
+               "Generate definitions for 'berichten' (specific to INDOORS project)."
+            , Hidden)
+          , (Option []        ["language"]
+               (ReqArg (\l opts-> return opts{language = case map toUpper l of
+                                                       "NL"  -> Just Dutch
+                                                       "UK"  -> Just English
+                                                       "US"  -> Just English
+                                                       "EN"  -> Just English
+                                                       _     -> Nothing}
+                       ) "LANG")
+               "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."
+            , Public)
+          , (Option []        ["test"]
+               (NoArg (\opts -> return opts{test = True}))
+               "Used for test purposes only."
+            , Hidden)
+          , (Option []        ["ast-tables"]
+               (NoArg (\opts -> return opts{genASTTables = True}))
+               "When set, generate the meta-tables of AST into the prototype"
+            , Hidden)
+          , (Option []        ["ast-file"]
+               (NoArg (\opts -> return opts{genASTFile = True}))
+               "Generate the meta-population in AST format and output it to an .adl file"
+            , Hidden)
+          , (Option []        ["generic-tables"]
+               (NoArg (\opts -> return opts{genGenericTables = True}))
+               "Generate the meta-tables of generics into the prototype"
+            , Hidden)
+          , (Option []        ["generic-file"]
+               (NoArg (\opts -> return opts{genGenericsFile = True}))
+               "Generate the meta-population in Generics format and output it to an .adl file"
+            , Hidden)
+          , (Option []        ["meta-tables-have-underscore"]
+               (NoArg (\opts -> return opts{metaTablesHaveUnderscore = True}))
+               "Separate the extra tables used with ast-tables or generic-tables by letting them have underscores"
+            , Hidden)
+          , (Option []        ["pango"]
+               (ReqArg (\nm opts -> return opts{pangoFont = nm}
+                       ) "FONTNAME")
+               "specify font name for Pango in graphics."
+            , Hidden)
+          , (Option []   ["no-static-files"]
+               (NoArg  (\opts -> return opts{genStaticFiles = False}))
+               "Do not generate static files into the prototype directory"
+            , Public)
+          , (Option []        ["sqlHost"]
+               (ReqArg (\nm opts -> return opts{sqlHost = nm}
+                       ) "HOSTNAME")
+               "specify database host name."
+            , Hidden)
+          , (Option []        ["sqlLogin"]
+               (ReqArg (\nm opts -> return opts{sqlLogin = nm}
+                       ) "NAME")
+               "specify database login name."
+            , Hidden)
+          , (Option []        ["sqlPwd"]
+               (ReqArg (\nm opts -> return opts{sqlPwd = nm}
+                       ) "STR")
+               "specify database password."
+            , Hidden)
+          , (Option []        ["oldNormalizer"]
+               (NoArg (\opts -> return opts{oldNormalizer = True}))
+               "use the old normalizer at your own risk."
+            , Hidden)
+          , (Option []        ["newNormalizer"]
+               (NoArg (\opts -> return opts{oldNormalizer = False}))
+               "use the new normalizer at your own risk." -- :-)
+            , Hidden)
+          , (Option []        ["newFrontend"]
+               (NoArg (\opts -> return opts{newFrontend = True}))
+               "Use the new frontend."
+            , Hidden)
+          ]
+
+usageInfo' :: Options -> String
+-- When the user asks --help, then the public options are listed. However, if also --verbose is requested, the hidden ones are listed too.
+usageInfo' opts = 
+  infoHeader (progrName opts) ++"\n"++
+    (concat . sort . map publishOption) [od | (od,x) <- options, verboseP opts || x == Public] 
+
+infoHeader :: String -> String
+infoHeader progName = "\nUsage info:\n " ++ progName ++ " options file ...\n\nList of options:"
+
+
+publishOption:: OptDescr a -> String
+publishOption (Option shorts longs args expl) 
+  = unlines (
+    [ "  "++intercalate ", " ["--"++l | l <-longs] 
+      ++case args of
+         NoArg _      -> "" 
+         ReqArg _ str -> "="++str
+         OptArg _ str -> "[="++str++"]"
+      ++case intercalate ", " [ "-"++[c] | c <- shorts] of
+          []  -> []
+          xs  -> " ("++xs++")"
+    ] 
+    ) ++unlines (map (replicate 10 ' '++) (lines (limit 65 expl)))
+  where
+   limit :: Int -> String -> String
+   limit i = intercalate "\n" . map (singleLine i . words) . lines
+   singleLine :: Int -> [String] -> String 
+   singleLine i wrds = 
+     case fillUpto i "" wrds of
+       (str, []) -> str
+       (str, rest) -> str ++ "\n"++ singleLine i rest
+   fillUpto :: Int -> String -> [String] -> (String, [String])
+   fillUpto i "" (w:ws) = fillUpto i w ws
+   fillUpto _ str [] = (str, [])
+   fillUpto i str (w:ws) = let nstr = str++" "++w
+                           in if length nstr > i 
+                           then (str, w:ws)
+                           else fillUpto i nstr ws 
+     
+envdirPrototype :: String
+envdirPrototype = "CCdirPrototype"
+envdirOutput :: String
+envdirOutput="CCdirOutput"
+envdbName :: String
+envdbName="CCdbName"
+envlogName :: String
+envlogName="CClogName"
+
+verbose :: Options -> String -> IO ()
+verbose opts x
+   | verboseP opts = putStr x
+   | otherwise     = return ()
+
+verboseLn :: Options -> String -> IO ()
+verboseLn opts x
+   | verboseP opts = -- each line is handled separately, so the buffer will be flushed in time. (see ticket #179)
+                     mapM_ putStrLn (lines x)
+   | otherwise     = return ()
+helpNVersionTexts :: String -> Options -> [String]
+helpNVersionTexts vs opts = ["Executable: "++show (dirExec opts)++"\n"   | test opts       ]++
+                            [preVersion opts++vs++postVersion opts++"\n" | showVersion opts]++
+                            [usageInfo' opts                             | showHelp    opts]
+

+ src/Database/Design/Ampersand/Misc/TinyXML.hs view
@@ -0,0 +1,45 @@+module Database.Design.Ampersand.Misc.TinyXML where
+
+   -----------------some new data types for simple XML structures--------
+   data XTree = Elem { etag :: XTag
+                     , etrees :: [XTree]
+                     }
+              | Node { ntag :: XTag  -- WHY? is Node nodig? Immers een Elem met een lege etrees doet precies hetzelfde...
+                                      -- BECAUSE! De show van een Node laat maar één tag zien. Een Elem showt een begin- en end-tag.
+                     }
+              | PlainText {ptstr :: String}
+   data XTag =  Tag  { tName :: String
+                     , tAtts :: [XAtt]
+                     }
+   data XAtt = Att { attName :: String
+                   , attValue :: String
+                   }
+
+   showXTree :: XTree -> String
+   showXTree tree = case tree of
+                        Elem{} -> showStart tag
+                               ++ concatMap showXTree (etrees tree)
+                               ++ showEnd tag
+                                   where tag = etag tree
+                        Node{} -> showNode (ntag tree)
+                        PlainText{} -> show (ptstr tree)
+   showStart :: XTag -> String
+   showStart a = "<" ++ tName a ++ showAtts (tAtts a) ++ ">"
+
+   showAtts :: [XAtt] -> String
+   showAtts = concatMap showAtt
+      where showAtt :: XAtt -> String
+            showAtt a= " "++attName a++"="++show (attValue a)
+
+   showEnd :: XTag -> String
+   showEnd a = "</" ++ tName a ++ ">"
+
+   showNode :: XTag -> String
+   showNode a = "<" ++ tName a ++ showAtts (tAtts a) ++ "/>"
+
+   mkAttr :: String -> String -> XAtt
+   mkAttr  = Att
+
+   simpleTag :: String -> XTag
+   simpleTag nm = Tag nm []
+

+ src/Database/Design/Ampersand/Output.hs view
@@ -0,0 +1,9 @@+module Database.Design.Ampersand.Output
+    ( module Database.Design.Ampersand.Output.FSpec2Pandoc
+    , module Database.Design.Ampersand.Output.PandocAux
+    , module Database.Design.Ampersand.Output.FSpec2Excel
+    ) where
+import Database.Design.Ampersand.Output.FSpec2Pandoc
+       (fSpec2Pandoc)
+import Database.Design.Ampersand.Output.PandocAux (writepandoc)
+import Database.Design.Ampersand.Output.FSpec2Excel
+ src/Database/Design/Ampersand/Output/FSpec2Excel.hs view
@@ -0,0 +1,152 @@+module Database.Design.Ampersand.Output.FSpec2Excel (fspec2Workbook,showSpreadsheet)
+where
+import Text.XML.SpreadsheetML.Builder
+import Text.XML.SpreadsheetML.Types
+import Text.XML.SpreadsheetML.Writer (showSpreadsheet)
+import Database.Design.Ampersand.Misc
+import Database.Design.Ampersand.FSpec
+import Database.Design.Ampersand.Core.AbstractSyntaxTree
+import Database.Design.Ampersand.FSpec.FPA
+import Database.Design.Ampersand.Basics
+import Data.Maybe
+
+-- NOTE: this code was refactored to support the new FPA module, but has not been tested yet.
+
+fspec2Workbook :: FSpec -> Workbook
+fspec2Workbook fSpec =
+   Workbook
+      { workbookDocumentProperties = Just
+          DocumentProperties { documentPropertiesTitle = Just $ "FunctiePuntAnalyse van "++baseName (getOpts fSpec)
+                             , documentPropertiesSubject = Nothing
+                             , documentPropertiesKeywords  = Nothing
+                             , documentPropertiesDescription = Just $ "Dit document is gegenereerd dmv. "++ampersandVersionStr++"."
+                             , documentPropertiesRevision = Nothing
+                             , documentPropertiesAppName = Just "Ampersand"
+                             , documentPropertiesCreated = Just $ show (genTime (getOpts fSpec))
+                             }
+      , workbookWorksheets = [pimpWs wsResume,pimpWs wsDatasets,pimpWs wsFunctions]
+      }
+  where
+    fpa = fpAnalyze fSpec -- TODO: Also count the PHP plugs
+    (_,totaalFPgegevensverzamelingen) = dataModelFPA fpa
+    (_,totaalFPgebruikerstransacties) = userTransactionFPA fpa
+    lang = fsLang fSpec
+    wsResume =
+      Worksheet { worksheetName =
+                            Name $ case lang of
+                                    English -> "Resume"
+                                    Dutch   -> "Overzicht"
+                , worksheetTable = Just $ emptyTable
+                    { tableRows =
+                          [ mkRow [string $ case lang of
+                                               English -> "Detailed function point count (according to NESMA 2.1) of the application "
+                                               Dutch   -> "Gedetailleerde functiepunentelling (volgens NESMA 2.2) van het systeem "
+                                             ++ baseName (getOpts fSpec)
+                                  ]
+                          , emptyRow
+                          , mkRow [string totalen]
+                          , mkRow [string gegevensverzamelingen,(number.fromIntegral) totaalFPgegevensverzamelingen]
+                          , mkRow [string gebruikerstransacties,(number.fromIntegral) totaalFPgebruikerstransacties]
+                          , mkRow [string grandTotaal,(number.fromIntegral) (totaalFPgegevensverzamelingen + totaalFPgebruikerstransacties)]
+                          , emptyRow
+                          , mkRow [string $ case lang of
+                                    English -> "For this function point count it is assumed that:"
+                                    Dutch   -> "Voor deze telling is aangenomen dat:"
+                                  ]
+                          , mkRow [string $ case lang of
+                                    English -> "- the application is built from scratch."
+                                    Dutch   -> "- het een nieuw informatiesyteem betreft."
+                                  ]
+                          , mkRow [string $ case lang of
+                                    English -> "- all persistent information will be stored internally"
+                                    Dutch   -> "- alle informatie wordt intern opgeslagen"
+                                  ]
+                          ]
+                    }
+                }
+    wsDatasets =
+      Worksheet { worksheetName = Name $ gegevensverzamelingen
+                , worksheetTable = Just $ emptyTable
+                    { tableRows =
+                          [ mkRow [string gegevensverzamelingen, (number.fromIntegral.length.plugInfos) fSpec]
+                          ] ++
+                          (map mkRow $ mapMaybe showDetailsOfPlug $ plugInfos fSpec)
+                       ++ map mkRow [replicate 3 emptyCell ++ [string totaal, (number.fromIntegral) totaalFPgegevensverzamelingen]]
+                    }
+                }
+    wsFunctions =
+      Worksheet { worksheetName  = Name $ gebruikerstransacties
+                , worksheetTable = Just $ emptyTable
+                    { tableRows =
+                          [ mkRow [string $ gebruikerstransacties, (number.fromIntegral.length.interfaceS) fSpec]
+                          ]
+                          ++ map (mkRow.showDetailsOfFunction) (interfaceS fSpec)
+                          ++ map mkRow [replicate 4 emptyCell ++ [string totaal, (number.fromIntegral.sum.(map $ fpVal . fpaInterface)) (interfaceS fSpec)]]
+                          ++ map mkRow [[string "Gegenereerde interfaces" , (number.fromIntegral.length.interfaceG) fSpec]]
+                          ++ map (mkRow.showDetailsOfFunction) (interfaceG fSpec)
+                          ++ map mkRow [replicate 4 emptyCell ++ [string totaal, (number.fromIntegral.sum.(map $ fpVal . fpaInterface)) (interfaceG fSpec)]]
+                          ++ map mkRow [replicate 5 emptyCell ++ [string grandTotaal, (number.fromIntegral) totaalFPgebruikerstransacties ]]
+                    }
+                }
+    gegevensverzamelingen :: String
+    gegevensverzamelingen = case lang of
+       Dutch   -> "Gegevensverzamelingen"
+       English -> "Data function types"
+
+    gebruikerstransacties :: String
+    gebruikerstransacties = case lang of
+       Dutch   -> "Gebruikerstransacties"
+       English -> "Transactional function types"
+    totalen :: String
+    totalen = case lang of
+       Dutch   -> "Totalen:"
+       English -> "Totals:"
+    totaal :: String
+    totaal = case lang of
+       Dutch   -> "Totaal:"
+       English -> "Total:"
+    grandTotaal :: String
+    grandTotaal = case lang of
+       Dutch   -> "Grandtotaal:"
+       English -> "Grand total:"
+
+-- TODO: rewrite: either remove external, BinSQL and ScalarSQL cases or don't filter based on fpaPlugInfo (which only yields TblSql plugs)
+    showDetailsOfPlug :: PlugInfo -> Maybe [Cell]
+    showDetailsOfPlug plug | Just fpaplgInfo <- fpaPlugInfo plug = Just
+       [ emptyCell
+       , (string.name) plug
+       , string (case plug of
+                  InternalPlug _ -> showLang lang fpaplgInfo 
+                  ExternalPlug _ -> "???"
+                )
+       , number . fromIntegral $ fpVal fpaplgInfo 
+       , string ( case (lang,plug) of
+                   (English, ExternalPlug _)             -> "PHP plugs are not (yet) taken into account!"
+                   (Dutch  , ExternalPlug _)             -> "PHP plugs worden (nog) niet meegerekend!"
+                   (English, InternalPlug p@TblSQL{})    -> "Table with "++(show.length.fields) p++" attributes."
+                   (Dutch  , InternalPlug p@TblSQL{})    -> "Tabel met "++(show.length.fields) p++" attributen."
+                   (English, InternalPlug   BinSQL{})    -> "Link table"
+                   (Dutch  , InternalPlug   BinSQL{})    -> "Koppel tabel"
+                   (English, InternalPlug   ScalarSQL{}) -> "Enumeration tabel"
+                   (Dutch  , InternalPlug   ScalarSQL{}) -> "Toegestane waarden tabel"
+                )
+       ]
+    showDetailsOfPlug _ = Nothing
+    showDetailsOfFunction :: Interface -> [Cell]
+    showDetailsOfFunction ifc =
+       [ emptyCell
+       , (string.name.ifcObj) ifc
+       , string $ showLang lang $ fpaInterface ifc
+       , (number . fromIntegral . fpVal . fpaInterface) ifc
+       ]
+
+pimpWs :: Worksheet -> Worksheet
+pimpWs ws = ws{worksheetTable = fmap pimpWsT (worksheetTable ws)
+              }
+pimpWsT :: Table -> Table
+pimpWsT t = t{tableColumns = map (\c -> c{columnAutoFitWidth = Just AutoFitWidth})
+                              (tableColumns t ++ replicate (maximum (map (length.rowCells) (tableRows t))) emptyColumn)
+             ,tableRows = map pimpRow (tableRows t)
+             }
+pimpRow :: Row -> Row
+pimpRow r = r{rowAutoFitHeight = Just AutoFitHeight}

+ src/Database/Design/Ampersand/Output/FSpec2Pandoc.hs view
@@ -0,0 +1,106 @@+{-# LANGUAGE ScopedTypeVariables #-}
+module Database.Design.Ampersand.Output.FSpec2Pandoc (fSpec2Pandoc)
+where
+import Database.Design.Ampersand.Output.ToPandoc.SharedAmongChapters
+import Database.Design.Ampersand.Output.ToPandoc.ChapterInterfaces            (chpInterfacesBlocks, chpInterfacesPics)
+import Database.Design.Ampersand.Output.ToPandoc.ChapterIntroduction          (chpIntroduction)
+import Database.Design.Ampersand.Output.ToPandoc.ChapterNatLangReqs           (chpNatLangReqs)
+import Database.Design.Ampersand.Output.ToPandoc.ChapterDiagnosis             (chpDiagnosis)
+import Database.Design.Ampersand.Output.ToPandoc.ChapterConceptualAnalysis    (chpConceptualAnalysis)
+import Database.Design.Ampersand.Output.ToPandoc.ChapterProcessAnalysis       (chpProcessAnalysis)
+import Database.Design.Ampersand.Output.ToPandoc.ChapterECArules              (chpECArules)
+import Database.Design.Ampersand.Output.ToPandoc.ChapterDataAnalysis          (chpDataAnalysis)
+import Database.Design.Ampersand.Output.ToPandoc.ChapterSoftwareMetrics       (fpAnalysis)
+import Database.Design.Ampersand.Output.ToPandoc.ChapterFunctionPointAnalysis (chpFunctionPointAnalysis)
+import Database.Design.Ampersand.Output.ToPandoc.ChapterGlossary              (chpGlossary)
+import Data.Time.Format (formatTime)
+import Data.List (nub)
+--import Debug.Trace
+--DESCR ->
+--The functional specification starts with an introduction
+--The second chapter defines the functionality of the system for stakeholders.
+--Because we assume these stakeholders to speak the language of the primary process without any technical knowledge,
+--the second chapter contains natural language only.
+--The third chapter is intended for the analyst. It contains all the rules mentioned in
+--natural language in the second chapter. It presents the trace from natural language
+--to the formal rule.
+--The fourth chapter presents a datamodel together with all the multiplicity rules.
+-- by datasets and rules.
+--Datasets are specified through PLUGS in Ampersand. The dataset is build around one concept,
+--also called the theme. Functionalities defined on the theme by one or more plugs are
+--described together with the rules that apply to the dataset. Rules not described by
+--the dataset are described in the last section of chapter 2.
+--The following chapters each present one INTERFACE
+--The specification end with a glossary.
+
+--TODO: Invent a syntax for meta information that is included in the source file...
+
+--The following general requirements apply to the functional specification document:
+--Descriptive title, number, identifier, etc. of the specification
+--Date of last effective revision and revision designation
+--A logo (trademark recommended) to declare the document copyright, ownership and origin
+--Table of Contents
+--Person, office, or agency responsible for questions on the specification, updates, and deviations.
+--The significance, scope or importance of the specification and its intended use.
+--Terminology, definitions and abbreviations to clarify the meanings of the specification
+--Test methods for measuring all specified characteristics
+--Material requirements: physical, mechanical, electrical, chemical, etc. Targets and tolerances.
+--Performance testing requirements. Targets and tolerances.
+--Drawings, photographs, or technical illustrations
+--Workmanship
+--Certifications required.
+--Safety considerations and requirements
+--Environmental considerations and requirements
+--Quality control requirements, Sampling (statistics), inspections, acceptance criteria
+--Person, office, or agency responsible for enforcement of the specification.
+--Completion and delivery.
+--Provisions for rejection, reinspection, rehearing, corrective measures
+--References and citations for which any instructions in the content maybe required to fulfill the traceability and clarity of the document
+--Signatures of approval, if necessary
+--Change record to summarize the chronological development, revision and completion if the document is to be circulated internally
+--Annexes and Appendices that are expand details, add clarification, or offer options.
+
+fSpec2Pandoc :: FSpec -> (Pandoc, [Picture])
+fSpec2Pandoc fSpec = ( myDoc , concat picturesByChapter )
+  where
+    myDoc =
+      ( (setTitle
+           (case metaValues "title" fSpec of
+                [] -> text (case (fsLang fSpec, diagnosisOnly (getOpts fSpec)) of
+                                 (Dutch  , False) -> "Functionele Specificatie van "
+                                 (English, False) -> "Functional Specification of "
+                                 (Dutch  ,  True) -> "Diagnose van "
+                                 (English,  True) -> "Diagnosis of "
+                           ) <> (singleQuoted.text.name) fSpec
+                titles -> (text.concat.nub) titles --reduce doubles, for when multiple script files are included, this could cause titles to be mentioned several times.
+           )
+        )
+      . (setAuthors $ 
+           case metaValues "authors" fSpec of
+             [] -> case fsLang fSpec of
+                     Dutch   -> [text "Specificeer auteurs in Ampersand met: META \"authors\" \"<auteursnamen>\""]
+                     English -> [text "Specify authors in Ampersand with: META \"authors\" \"<author names>\""]
+             xs -> map text $ nub xs  --reduce doubles, for when multiple script files are included, this could cause authors to be mentioned several times.
+           ++  [ subscript . text $ "(Generated with "++ampersandVersionStr++")" | development (getOpts fSpec) ]
+
+        )
+      . (setDate (text (formatTime (lclForLang (fsLang fSpec)) "%-d %B %Y" (genTime (getOpts fSpec)))))
+      )
+      (doc (foldr (<>) mempty docContents))
+    docContents :: [Blocks]
+    picturesByChapter :: [[Picture]]
+    (docContents, picturesByChapter) = unzip [fspec2Blocks chp | chp<-chaptersInDoc (getOpts fSpec)]
+
+    fspec2Blocks :: Chapter -> (Blocks, [Picture])
+    fspec2Blocks Intro                 = (chpIntroduction           fSpec, [])
+    fspec2Blocks SharedLang            = (chpNatLangReqs          0 fSpec, [])
+    fspec2Blocks Diagnosis             = chpDiagnosis               fSpec
+    fspec2Blocks ConceptualAnalysis    = chpConceptualAnalysis    0 fSpec
+    fspec2Blocks ProcessAnalysis       = chpProcessAnalysis       0 fSpec
+    fspec2Blocks DataAnalysis          = chpDataAnalysis            fSpec
+    fspec2Blocks SoftwareMetrics       = (fpAnalysis                fSpec, [])
+    fspec2Blocks EcaRules              = (chpECArules               fSpec, [])
+    fspec2Blocks Interfaces            = (chpInterfacesBlocks     0 fSpec, chpInterfacesPics fSpec)
+    fspec2Blocks FunctionPointAnalysis = chpFunctionPointAnalysis   fSpec
+    fspec2Blocks Glossary              = (chpGlossary             0 fSpec, [])
+

+ src/Database/Design/Ampersand/Output/PandocAux.hs view
@@ -0,0 +1,726 @@+{-# LANGUAGE OverloadedStrings #-}
+module Database.Design.Ampersand.Output.PandocAux
+      ( writepandoc
+      , XRefObj(..) , xRefTo, xRefToLatexRefString
+      , headerWithLabel
+      , definitionListItemLabel
+      , pandocEqnArray
+      , pandocEqnArrayWithLabels
+      , pandocEqnArrayWithLabel
+      , pandocEquation
+      , pandocEquationWithLabel
+      , uniquecds
+      , count
+      , ShowMath(..)
+      , latexEscShw, escapeNonAlphaNum
+      , xrefCitation
+      , texOnly_Id
+      , texOnly_fun
+      , texOnly_rel
+      )
+where
+import Database.Design.Ampersand.ADL1
+import Database.Design.Ampersand.FSpec
+import Data.Char hiding    (Space)
+import Text.Pandoc
+import Text.Pandoc.Builder
+import Database.Design.Ampersand.Core.AbstractSyntaxTree
+import Database.Design.Ampersand.Basics hiding (hPutStrLn)
+import Prelude hiding      (writeFile,readFile,getContents,putStr,putStrLn)
+import Database.Design.Ampersand.Misc
+import System.Process      (system)
+import System.Exit         (ExitCode(ExitSuccess,ExitFailure))
+import System.FilePath  -- (combine,addExtension,replaceExtension)
+import System.Directory
+import System.Info         (os)
+import Data.Monoid
+import Data.List
+import Control.Monad
+import Data.Maybe
+
+fatal :: Int -> String -> a
+fatal = fatalMsg "Output.PandocAux"
+
+-- | Default key-value pairs for use with the Pandoc template
+defaultWriterVariables :: FSpec -> [(String , String)]
+defaultWriterVariables fSpec
+  = [ ("title", (case (fsLang fSpec, diagnosisOnly (getOpts fSpec)) of
+                        (Dutch  , False) -> "Functionele Specificatie van "
+                        (English, False) -> "Functional Specification of "
+                        (Dutch  ,  True) -> "Diagnose van "
+                        (English,  True) -> "Diagnosis of "
+                )++name fSpec)
+ --   , ("mainfont",
+ --   , ("sansfont",
+ --   , ("monofont",
+ --   , ("mathfont",
+    , ("fontsize", "10pt,a4paper")   --can be overridden by geometry package (see below)
+    , ("lang"    , case fsLang fSpec of
+                       Dutch   -> "dutch"
+                       English -> "english")
+    , ("mainlang", case fsLang fSpec of
+                       Dutch   -> "dutch"
+                       English -> "english")
+    , ("documentclass","report")
+    ] ++
+    [ ("toc" , "<<TheTableOfContentsShouldGoHere>>") | not (diagnosisOnly (getOpts fSpec))]++
+    [ ("header-includes", unlines
+         [ "% ============Ampersand specific Begin================="
+         , "% First a couple of LaTeX packages are included:"
+         , ""
+         , "% The glossaries package supports acronyms and multiple glossaries"
+         , "\\usepackage[toc]{glossaries}    % Add the glossaries to the table of contents"
+         , "\\makeglossaries"
+         , ""
+         , "% geometry provides a flexible and easy interface to page dimentions"
+         , "\\usepackage[ top=1.5cm, bottom=1.5cm, outer=5cm, inner=2cm"
+         , "            , heightrounded, footskip=.5cm"
+         , "            , marginparwidth=2.5cm, marginparsep=0.5cm]{geometry}"
+         , ""
+         , "% breqn – Automatic line breaking of displayed equations"
+         , "\\usepackage{breqn}"
+         , ""
+         , "% colonequals – Colon equals symbols"
+         , "\\usepackage{colonequals}"
+         , ""
+         , ""
+         , "\\usepackage{textcomp}"
+         , "% == [all]{hypcap} after {hyperref} shows the ref'd picture i.o. the caption @ click =="
+         , ""
+         , "\\usepackage[all]{hypcap}"
+         , ""
+
+         , "% hack1) For the purpose of clear references in Latex. See also https://github.com/AmpersandTarski/ampersand/issues/31"
+         , "\\makeatletter"
+         , "\\let\\orgdescriptionlabel\\descriptionlabel"
+         , "\\renewcommand*{\\descriptionlabel}[1]{%"
+         , "  \\let\\orglabel\\label"
+         , "  \\let\\label\\@gobble"
+         , "  \\phantomsection"
+         , "  \\edef\\@currentlabel{#1}%"
+         , "  %\\edef\\@currentlabelname{#1}%"
+         , "  \\let\\label\\orglabel"
+         , "  \\orgdescriptionlabel{#1}%"
+         , "}"
+         , "\\makeatother"
+         , "% End-hack1"
+         , ""
+
+         , "% hack2) The LaTeX commands \\[ and \\], are redefined in the amsmath package, making sure that ecuations are"
+         , "% not numbered. This is undesireable behaviour. this is fixed with the following hack, inspired on a note"
+         , "% found at http://tex.stackexchange.com/questions/40492/what-are-the-differences-between-align-equation-and-displaymath"
+         , "\\DeclareRobustCommand{\\[}{\\begin{equation}}"
+         , "\\DeclareRobustCommand{\\]}{\\end{equation}}"
+         , "% End-hack2"
+         , ""
+         , ""
+         , "\\def\\id#1{\\mbox{\\em #1\\/}}"
+         , "\\newcommand{\\marge}[1]{\\marginpar{\\begin{minipage}[t]{3cm}{\\noindent\\small\\em #1}\\end{minipage}}}"
+         , "\\def\\define#1{\\label{dfn:#1}\\index{#1}{\\em #1}}"
+         , "\\def\\defmar#1{\\label{dfn:#1}\\index{#1}\\marge{#1}{\\em #1}}"
+         , "\\newcommand{\\iden}{\\mathbb{I}}"
+         , "\\newcommand{\\ident}[1]{\\mathbb{I}_{#1}}"
+         , "\\newcommand{\\full}{\\mathbb{V}}"
+         , "\\newcommand{\\fullt}[1]{\\mathbb{V}_{[#1]}}"
+         , "\\newcommand{\\flip}[1]{{#1}^\\smallsmile} %formerly:  {#1}^\\backsim"
+         , "\\newcommand{\\kleeneplus}[1]{{#1}^{+}}"
+         , "\\newcommand{\\kleenestar}[1]{{#1}^{*}}"
+         , "\\newcommand{\\asterisk}{*}"
+         , "\\newcommand{\\cmpl}[1]{\\overline{#1}}"
+         , "\\newcommand{\\subs}{\\vdash}"
+         , "\\newcommand{\\rel}{\\times}"
+         , "\\newcommand{\\fun}{\\rightarrow}"
+         , "\\newcommand{\\isa}{\\sqsubseteq}"
+         , "\\newcommand{\\N}{\\mbox{\\msb N}}"
+         , "\\newcommand{\\disjn}[1]{\\id{disjoint}(#1)}"
+         , "\\newcommand{\\fsignat}[3]{\\id{#1}:\\id{#2}\\fun\\id{#3}}"
+         , "\\newcommand{\\signat}[3]{\\id{#1}:\\id{#2}\\rel\\id{#3}}"
+         , "\\newcommand{\\signt}[2]{\\mbox{\\({#1}_{[{#2}]}\\)}}"
+         , "\\newcommand{\\declare}[3]{\\id{#1}:\\ \\id{#2}\\rel\\id{#3}}"
+         , "\\newcommand{\\fdeclare}[3]{\\id{#1}:\\ \\id{#2}\\fun\\id{#3}}"
+         , "% ============Ampersand specific End==================="
+         ])
+    | fspecFormat (getOpts fSpec) == FLatex ]
+
+--DESCR -> functions to write the pandoc
+--         String = the name of the outputfile
+--         The first IO() is a Pandoc output format
+--         The second IO(): If the output format is latex, then this IO() generates a .pdf from the .tex
+writepandoc :: FSpec -> Pandoc -> (String,IO(),IO())
+writepandoc fSpec thePandoc = (outputFile,makeOutput,postProcessMonad)
+         where
+         outputFile = addExtension (combine (dirOutput (getOpts fSpec)) (baseName (getOpts fSpec)))
+                                       (case fspecFormat (getOpts fSpec) of
+                                                 Fasciidoc     -> ".txt"
+                                                 Fcontext      -> ".context"
+                                                 Fdocbook      -> ".docbook"
+                                                 Fman          -> ".man"
+                                                 Fmarkdown     -> ".md"
+                                                 Fmediawiki    -> ".mediawiki"
+                                                 Forg          -> ".org"
+                                                 Fplain        -> ".plain"
+                                                 Frst          -> ".rst"
+                                                 FPandoc       -> ".pandoc"
+                                                 Frtf          -> ".rtf"
+                                                 FLatex        -> ".tex"
+                                                 Fhtml         -> ".html"
+                                                 Fopendocument -> ".odt"
+                                                 Ftexinfo      -> ".texinfo"
+                                                 Ftextile      -> ".textile"
+                                       )
+         makeOutput
+            =  do template <- readDefaultTemplate fSpecFormatString
+                  verboseLn (getOpts fSpec) ("Generating "++fSpecFormatString++" to : "++outputFile)
+                  --verboseLn (getOpts fSpec) "Variables to set in the template:"
+                  --verboseLn (getOpts fSpec) (intercalate "\n   " (map show (writerVariables (writerOptions template))))
+                  writeFile outputFile (pandocWriter (writerOptions template) thePandoc)
+                  verboseLn (getOpts fSpec) "... done."
+           where
+              pandocWriter :: WriterOptions -> Pandoc -> String
+              pandocWriter =
+                case fspecFormat (getOpts fSpec) of
+                  Fasciidoc -> fatal 145 "No current support for asciidoc"
+                  FPandoc   -> writeNative
+                  Fcontext  -> writeConTeXt
+                  Fdocbook  -> writeDocbook
+                  Fhtml     -> writeHtmlString
+                  FLatex    -> writeLaTeX
+                  Fman      -> writeMan
+                  Fmarkdown -> writeMarkdown
+                  Fmediawiki -> writeMediaWiki
+                  Fopendocument -> writeOpenDocument
+                  Forg -> writeOrg
+                  Fplain -> writePlain
+                  Frst -> writeRST
+                  Frtf -> writeRTF
+                  Ftexinfo -> writeTexinfo
+                  Ftextile -> writeTextile
+              fSpecFormatString :: String
+              fSpecFormatString =
+                case fspecFormat (getOpts fSpec) of
+                  FPandoc   -> "pandoc"
+                  Fasciidoc -> "asciidoc"
+                  Fcontext  -> "context"
+                  Fdocbook  -> "docbook"
+                  Fhtml     -> "html"
+                  FLatex    -> "latex"
+                  Fman      -> "man"
+                  Fmarkdown -> "markdown"
+                  Fmediawiki -> "mediawiki"
+                  Fopendocument -> "opendocument"
+                  Forg -> "org"
+                  Fplain -> "plain"
+                  Frst -> "rst"
+                  Frtf -> "rtf"
+                  Ftexinfo -> "texinfo"
+                  Ftextile -> "textile"
+              readDefaultTemplate :: String -> IO(Maybe String)
+              readDefaultTemplate  s =
+                do { let fp = ampersandDataDir (getOpts fSpec) </> ".." </> "outputTemplates" </> "default."++s
+                   ; exists <- doesFileExist fp
+                   ; (if exists
+                      then do verboseLn (getOpts fSpec) $ "Using Template: "++fp
+                              contents <- readFile fp
+                              return $ Just contents
+                      else do putStrLn ""
+                              putStrLn  "***WARNING: ***"
+                              putStrLn ("Template file does not exist: "++fp)
+                              putStrLn  "It was part of the installation of Ampersand."
+                              putStrLn  "...trying without template, but that isn't likely going to work..."
+                              putStrLn  "    (reinstalling Ampersand should fix this problem...)"
+                              putStrLn  "***************"
+                              return Nothing
+                     )
+                   }
+              writerOptions :: Maybe String -> WriterOptions
+              writerOptions template = case theme (getOpts fSpec) of
+                          ProofTheme -> ampersandDefaultWriterOptions
+                                           { writerTableOfContents=False
+                                           , writerNumberSections=False
+                                           }
+                          _          -> ampersandDefaultWriterOptions
+                     where
+                       ampersandDefaultWriterOptions =
+                         def
+                            { writerStandalone=isJust template
+                            , writerTableOfContents=True
+                            , writerNumberSections=True
+                            , writerTemplate=fromMaybe "" template
+                            , writerVariables=defaultWriterVariables fSpec}
+         postProcessMonad :: IO()
+         postProcessMonad =
+           case fspecFormat (getOpts fSpec) of
+               FLatex  -> do
+                          (ready,nrOfRounds) <- doRestOfPdfLatex (False, 0)  -- initialize with: (<NotReady>, <0 rounds so far>)
+                          verboseLn (getOpts fSpec) ("PdfLatex was called "++
+                                          (if nrOfRounds>1 then show nrOfRounds++" times" else "once")++
+                                          if ready then "."
+                                                   else ", but did not solve all references!")
+                             where
+                                doRestOfPdfLatex :: (Bool,Int) -> IO (Bool,Int)
+                                doRestOfPdfLatex (ready, roundsSoFar)
+                                  = if ready || roundsSoFar > 4    -- Make sure we will not hit a loop when something is wrong with call to pdfLatex ...
+                                    then return (ready, roundsSoFar)
+                                    else do result <- callPdfLatexOnce
+                                            let logFileName = replaceExtension outputFile ("log"++show roundsSoFar)
+                                            renameFile (replaceExtension outputFile "log") logFileName
+                                            logFileLines <- fmap lines $ readFile logFileName
+                                            {- Old comment: The log file should be renamed before reading, because readFile opens the file
+                                               for lazy IO. In a next run, pdfLatex will try to write to the log file again. If it
+                                               was read using readFile, it will fail because the file is still open. 8-((
+                                            -}
+                                            
+                                            case result of
+                                              ExitSuccess   -> verboseLn (getOpts fSpec) "PDF file created."
+                                              ExitFailure _ ->
+                                               do { let nrOfErrLines = 15
+                                                  ; putStrLn "----------- LaTeX error-----------"
+                                                  
+                                                  -- get rid of latex memory info and take required nr of lines
+                                                  ; let reverseErrLines = take nrOfErrLines . drop 2 
+                                                                        . dropWhile (not . ("Here is how much of TeX's memory you used:" `isPrefixOf`)) 
+                                                                        . reverse $ logFileLines
+                                                  ; putStrLn $ unlines . reverse $ reverseErrLines   
+                                                  ; putStrLn "----------------------------------\n"
+                                                  ; putStrLn $ "ERROR: Latex execution failed."
+                                                  ; putStrLn $ "For more information, run pdflatex on: "++texFilename
+                                                  ; putStrLn $ "Or consult the log file:\n"++logFileName
+                                                  }
+
+                                            -- We need to rerun latex if any of the log lines start with a rerunPrefix
+                                            let notReady = result == ExitSuccess &&
+                                                           or [ rerunPrefix `isPrefixOf` line
+                                                              | line <- logFileLines
+                                                              , rerunPrefix <- [ "LaTeX Warning: Label(s) may have changed. Rerun to get cross-references right."
+                                                                               , "Package longtable Warning: Table widths have changed. Rerun LaTeX."
+                                                                               ]
+                                                              ]
+                                            when notReady (verboseLn (getOpts fSpec) "Another round of pdfLatex is required. Hang on...")
+                                          --  when notReady (dump "log")  -- Need to dump the last log file, otherwise pdfLatex cannot write its log.
+                                            doRestOfPdfLatex (not notReady, roundsSoFar +1)
+
+                                texFilename = addExtension (baseName (getOpts fSpec)) ".tex"
+
+                                callPdfLatexOnce :: IO ExitCode
+                                callPdfLatexOnce =
+                                   do if os `elem` ["mingw32","mingw64","cygwin","windows"] --REMARK: not a clear enum to check for windows OS
+                                      then do { res <- system ( pdfLatexCommand++"> "++combine (dirOutput (getOpts fSpec)) "pdflog" )
+                                              ; if res /= ExitSuccess then return res else 
+                                                  system  makeIndexCommand -- TODO: failure of makeindex is not reported correctly (requires refactoring command execution)
+                                              }
+                                      --REMARK: MikTex is windows; Tex-live does not have the flag -include-directory.
+                                      else system ( "cd "++dirOutput (getOpts fSpec)++
+                                                    " && pdflatex "++commonFlags++
+                                                    texFilename ++ "> "++addExtension(baseName (getOpts fSpec)) ".pdflog" )
+                                           -- >> system makeIndexCommand
+                                           -- disabled makeIndexCommand on non-windows, since it will always fail when absolute paths are used
+                                           -- For some weird Latex reason this can only be avoided by setting an environment variable.
+                                      where
+                                      pdfLatexCommand = "pdflatex "++commonFlags++pdfgetOpts++ outputFile
+                                      --makeIndexCommand = "makeglossaries "++replaceExtension outputFile "glo"
+                                      --makeindex uses the error stream for verbose stuff...
+                                      makeIndexCommand = "makeindex -s "++replaceExtension outputFile "ist"++" -t "++replaceExtension outputFile "glg"++" -o "++replaceExtension outputFile "gls"++" "++replaceExtension outputFile "glo 2> "++combine (dirOutput (getOpts fSpec)) "glossaries.log"
+                                      pdfgetOpts = " -include-directory="++dirOutput (getOpts fSpec)++ " -output-directory="++dirOutput (getOpts fSpec)++" "
+                                      commonFlags = "--halt-on-error --interaction=nonstopmode " -- MacTex options are normally with one '-', but '--interaction' is accepted
+                                      -- we don't do --disable-installer on Windows, so the install dialog will pop up, even when we are in nonstopmode 
+               _  -> return()
+
+-----Linguistic goodies--------------------------------------
+
+count :: Lang -> Int -> String -> String
+count    lang    n      x
+ = case (lang, n) of
+      (Dutch  , 0) -> "geen "++plural Dutch x
+      (Dutch  , 1) -> "één "++x
+      (Dutch  , 2) -> "twee "++plural Dutch x
+      (Dutch  , 3) -> "drie "++plural Dutch x
+      (Dutch  , 4) -> "vier "++plural Dutch x
+      (Dutch  , 5) -> "vijf "++plural Dutch x
+      (Dutch  , 6) -> "zes "++plural Dutch x
+      (Dutch  , _) -> show n++" "++plural Dutch x
+      (English, 0) -> "no "++plural English x
+      (English, 1) -> "one "++x
+      (English, 2) -> "two "++plural English x
+      (English, 3) -> "three "++plural English x
+      (English, 4) -> "four "++plural English x
+      (English, 5) -> "five "++plural English x
+      (English, 6) -> "six "++plural English x
+      (English, _) -> show n++" "++plural English x
+
+------ Symbolic referencing ---------------------------------
+data XRefObj = XRefNaturalLanguageDeclaration Declaration
+             | XRefPredicateXpression Rule
+             | XRefNaturalLanguageConcept A_Concept
+             | XRefDataAnalRule Rule
+             | XRefNaturalLanguageRule Rule
+             | XRefProcessAnalysis Pattern
+             | XRefProcessAnalysisDeclaration Declaration
+             | XRefConceptualAnalysisPattern Pattern
+             | XRefConceptualAnalysisDeclaration Declaration
+             | XRefConceptualAnalysisRule Rule
+             | XRefInterfacesInterface Interface
+             | XRefNaturalLanguageTheme (Maybe Pattern) 
+xRefTo :: XRefObj -> Inlines
+xRefTo x = rawInline "latex"  $ xRefToLatexRefString x
+xRefToLatexRefString :: XRefObj -> String
+xRefToLatexRefString x = "\\ref{"++xRefRawLabel x++"}"
+xRefRawLabel :: XRefObj -> String
+xRefRawLabel x
+ = case x of
+     XRefNaturalLanguageDeclaration d -> "natLangDcl:"++(escapeNonAlphaNum.fullName) d
+     XRefPredicateXpression r     -> "pex:"++(escapeNonAlphaNum.name) r
+     XRefNaturalLanguageConcept c -> "natLangCpt:"++(escapeNonAlphaNum.name) c
+     XRefDataAnalRule r           -> "dataAnalRule:"++(escapeNonAlphaNum.name) r
+     XRefNaturalLanguageRule r    -> "natLangRule:"++(escapeNonAlphaNum.name) r
+     XRefProcessAnalysis p        -> "prcAnal:"++(escapeNonAlphaNum.name) p
+     XRefProcessAnalysisDeclaration d 
+                                  -> "prcAnalDcl:"++(escapeNonAlphaNum.fullName) d
+     XRefConceptualAnalysisPattern p 
+                                  -> "cptAnalPat:"++(escapeNonAlphaNum.name) p
+     XRefConceptualAnalysisDeclaration d 
+                                  -> "cptAnalDcl:"++(escapeNonAlphaNum.fullName) d
+     XRefConceptualAnalysisRule r -> "cptAnalRule:"++(escapeNonAlphaNum.name) r
+     XRefInterfacesInterface i    -> "interface:"++(escapeNonAlphaNum.name) i
+     XRefNaturalLanguageTheme (Just t)
+                                  -> "theme:"++(escapeNonAlphaNum.name) t
+     XRefNaturalLanguageTheme Nothing 
+                                  -> ":losseEindjes"
+    where
+      fullName d = name d++"*"++(name.source) d++"*"++(name.target) d                              
+
+headerWithLabel :: XRefObj -> Int -> Inlines -> Blocks
+headerWithLabel x = headerWith (xRefRawLabel x, [],[])
+
+definitionListItemLabel :: XRefObj -> String -> Inlines
+definitionListItemLabel x prefix
+  = str prefix <> rawInline "latex" ("\\label{"++xRefRawLabel x++"}")
+
+
+xrefCitation :: String -> Inline    -- uitbreidbaar voor andere rendering dan LaTeX
+xrefCitation myLabel = RawInline (Text.Pandoc.Builder.Format "latex") ("\\cite{"++escapeNonAlphaNum myLabel++"}")
+
+pandocEqnArray :: [[String]] -> [Block]
+pandocEqnArray [] = []
+pandocEqnArray xs
+ = (toList . para . displayMath) 
+       ( "\\begin{aligned}\n"
+         ++ intercalate "\\\\\n   " [ intercalate "&" row  | row <-xs ]
+         ++"\n\\end{aligned}"
+       )
+    
+pandocEqnArrayWithLabels :: [(XRefObj,[String])] -> Blocks 
+pandocEqnArrayWithLabels [] = mempty
+pandocEqnArrayWithLabels rows
+ = (para .displayMath) 
+       ( "\\begin{aligned}\n"
+         ++ intercalate "\\\\\n   " [ intercalate "&" row ++ "\\label{"++xRefRawLabel x++"}" | (x,row)<-rows ]
+         ++"\n\\end{aligned}"
+       )
+
+pandocEqnArrayWithLabel :: XRefObj -> [[String]] -> Blocks
+pandocEqnArrayWithLabel _ [] = mempty
+pandocEqnArrayWithLabel xref rows
+ = (para . displayMath)  
+       ( "\\label{"++xRefRawLabel xref++"}\\begin{aligned}\\\\\n"
+         ++ intercalate "\\\\\n   " [ intercalate "&" row | row <- rows ]
+         ++"\n\\end{aligned}"
+       )
+                                
+pandocEquation :: String -> [Block]
+pandocEquation x = toList . para . displayMath $ x
+
+pandocEquationWithLabel :: XRefObj -> String -> Blocks
+pandocEquationWithLabel xref x = 
+   para . displayMath $
+        ( "\\begin{aligned}\\label{"++xRefRawLabel xref++"}\\\\\n"
+           ++x
+           ++"\n\\end{aligned}"
+        )
+
+
+--DESCR -> pandoc print functions for Ampersand data structures
+---------------------------------------
+-- LaTeX math markup
+---------------------------------------
+
+class ShowMath a where
+ showMath :: a -> String
+
+instance ShowMath A_Concept where
+ showMath c = texOnly_Id (name c)
+
+instance ShowMath A_Gen where
+ showMath g@Isa{} = showMath (genspc g)++"\\ \\le\\ "++showMath (gengen g)
+ showMath g@IsE{} = showMath (genspc g)++"\\ =\\ "++intercalate "\\cap" (map showMath (genrhs g))
+
+instance ShowMath Rule where
+ showMath r = showMath (rrexp r)
+
+instance ShowMath Sign where
+ showMath (Sign s t) = showMath s++"\\rel"++showMath t
+
+instance ShowMath Expression where
+ showMath = showExpr . insParentheses
+   where  showExpr (EEqu (l,r)) = showExpr l++texOnly_equals++showExpr r
+          showExpr (EImp (l,r)) = showExpr l++texOnly_subs++showExpr r
+          showExpr (EIsc (l,r)) = showExpr l++texOnly_inter++showExpr r
+          showExpr (EUni (l,r)) = showExpr l++texOnly_union++showExpr r
+          showExpr (EDif (l,r)) = showExpr l++texOnly_bx ++showExpr r
+          showExpr (ELrs (l,r)) = showExpr l++texOnly_lRes++showExpr r
+          showExpr (ERrs (l,r)) = showExpr l++texOnly_rRes++showExpr r
+          showExpr (EDia (l,r)) = showExpr l++texOnly_dia++showExpr r
+          showExpr (ECps (EEps i sgn,r)) | i==source sgn||i==target sgn = showExpr  r
+                                         | otherwise                    = showExpr (ECps (EDcI i,r))
+          showExpr (ECps (l,EEps i sgn)) | i==source sgn||i==target sgn = showExpr  l
+                                         | otherwise                    = showExpr (ECps (l,EDcI i))
+          showExpr (ECps (l,r)) = showExpr l++texOnly_compose++showExpr r
+          showExpr (ERad (l,r)) = showExpr l++texOnly_relAdd++showExpr r
+          showExpr (EPrd (l,r)) = showExpr l++texOnly_crtPrd++showExpr r
+          showExpr (EKl0 e)     = showExpr (addParensToSuper e)++"^{"++texOnly_star++"}"
+          showExpr (EKl1 e)     = showExpr (addParensToSuper e)++"^{"++texOnly_plus++"}"
+          showExpr (EFlp e)     = showExpr (addParensToSuper e)++"^{"++texOnly_flip++"}"
+          showExpr (ECpl e)     = "\\cmpl{"++showExpr e++"}"
+          showExpr (EBrk e)     = "("++showExpr e++")"
+          showExpr (EDcD d)     = "\\id{"++name d++"}"
+          showExpr (EDcI c)     = "I_{\\id{"++name c++"}}"
+          showExpr  EEps{}      = "" -- fatal 417 "EEps may occur only in combination with composition (semicolon)."  -- SJ 2014-03-11: Are we sure about this? Let's see if it ever occurs...
+          showExpr (EDcV sgn)   = "V_{\\id{"++show (source sgn)++"}\\times\\id{"++show (target sgn)++"}}"
+          showExpr (EMp1 a _)   = "'{\\tt "++a++"}'"
+
+-- add extra parentheses to consecutive superscripts, since latex cannot handle these
+-- (this is not implemented in insParentheses because it is a latex-specific issue)
+addParensToSuper :: Expression -> Expression
+addParensToSuper e@EKl0{} = EBrk e
+addParensToSuper e@EKl1{} = EBrk e
+addParensToSuper e@EFlp{} = EBrk e
+addParensToSuper e        = e
+
+instance ShowMath Declaration where
+ showMath decl@(Sgn{})
+  = "\\declare{"++latexEscShw(name decl)++"}{"++latexEscShw(name (source decl))++"}{"++latexEscShw(name (target decl))++"}"
+ showMath Isn{}
+  = "\\mathbb{I}"
+ showMath Vs{}
+  = "\\full"
+
+-- | latexEscShw escapes to LaTeX encoding. It is intended to be used in LaTeX text mode.
+--   For more elaborate info on LaTeX encoding, consult the The Comprehensive LATEX Symbol List
+--   on:    http://ftp.snt.utwente.nl/pub/software/tex/info/symbols/comprehensive/symbols-a4.pdf
+latexEscShw :: String -> String
+latexEscShw ""           = ""
+latexEscShw ('\"':c:cs) | isAlphaNum c = "``"++latexEscShw (c:cs)
+                        | otherwise    = "''"++latexEscShw (c:cs)
+latexEscShw "\""        = "''"
+latexEscShw (c:cs)      | isAlphaNum c && isAscii c = c:latexEscShw cs
+                        | otherwise    = f c++latexEscShw cs
+ where
+  f '"' = "\\textquotedbl "
+  f '#' = "\\#"
+  f '$' = "\\$"
+  f '%' = "\\%"
+  f '&' = "\\&"
+  f '\\'= "\\textbackslash "
+  f '^' = "\\^{}"
+  f '_' = "\\_"
+  f '{' = "\\{"
+  f '|' = "\\textbar "
+  f '}' = "\\}"
+  f '~' = "\\~{}"
+  f '¦' = "\\textbrokenbar "
+  f '¨' = "\\textasciidieresis "
+  f '¯' = "\\textasciimacron "
+  f '´' = "\\textasciiacute "
+  f '¢' = "\\textcent "
+  f '£' = "\\textpound "
+  f '¤' = "\\textcurrency "
+  f '¥' = "\\textyen "
+  f '€' = "\\texteuro "
+  f '<' = "\\textless "
+  f '>' = "\\textgreater "
+  f '±' = "\\textpm "
+  f '«' = "\\guillemotleft "
+  f '»' = "\\guillemotright "
+  f '×' = "\\texttimes "
+  f '÷' = "\\textdiv "
+  f '§' = "\\S "
+  f '©' = "\\textcopyright "
+  f '¬' = "\\textlnot "
+  f '®' = "\\textregistered "
+  f '°' = "\\textdegree "
+  f 'µ' = "\\textmu "
+  f '¶' = "\\P "
+  f '·' = "\\textperiodcentered "
+  f '¼' = "\\textonequarter "
+  f '½' = "\\textonehalf "
+  f '¾' = "\\textthreequarters "
+  f '¹' = "\\textonesuperior "
+  f '²' = "\\texttwosuperior "
+  f '³' = "\\textthreesuperior "
+  f '∞' = "\\hbipropto "
+  f 'ä' = "\\\"{a}"        --  umlaut or dieresis
+  f 'Ä' = "\\\"{A}"        --  umlaut or dieresis
+  f 'â' = "\\^{a}"         --  circumflex
+  f 'Â' = "\\^{A}"         --  circumflex
+  f 'à' = "\\`{a}"         --  grave accent
+  f 'À' = "\\`{A}"         --  grave accent
+  f 'á' = "\\'{a}"         --  acute accent
+  f 'Á' = "\\'{A}"         --  acute accent
+  f 'ã' = "\\~{a}"         --  tilde
+  f 'Ã' = "\\~{A}"         --  tilde
+  f 'å' = "\\aa "
+--  f 'å' = "\\r{a}"       --  alternatively: ring over the letter
+  f 'Å' = "\\AA "
+--  f 'Å' = "\\r{A}"       --  alternatively: ring over the letter
+  f 'ą' = "\\k{a}"         --  ogonek
+  f 'Ą' = "\\k{A}"         --  ogonek
+  f 'ª' = "\\textordfeminine "
+  f 'æ' = "\\ae "
+  f 'Æ' = "\\AE "
+  f 'ç' = "\\c{c}"         --  cedilla
+  f 'Ç' = "\\c{C}"         --  cedilla
+  f 'Ð' = "\\DH "
+  f 'ð' = "\\dh "
+  f 'ë' = "\\\"{e}"        --  umlaut or dieresis
+  f 'Ë' = "\\\"{E}"        --  umlaut or dieresis
+  f 'ê' = "\\^{e}"         --  circumflex
+  f 'Ê' = "\\^{E}"         --  circumflex
+  f 'è' = "\\`{e}"         --  grave accent
+  f 'È' = "\\`{E}"         --  grave accent
+  f 'é' = "\\'{e}"         --  acute accent
+  f 'É' = "\\'{E}"         --  acute accent
+  f 'ï' = "\\\"{\\i}"      --  umlaut or dieresis
+  f 'Ï' = "\\\"{I}"        --  umlaut or dieresis
+  f 'î' = "\\^{\\i}"       --  circumflex
+  f 'Î' = "\\^{I}"         --  circumflex
+  f 'ì' = "\\`{\\i}"       --  grave accent
+  f 'Ì' = "\\`{I}"         --  grave accent
+  f 'í' = "\\'{\\i}"       --  acute accent
+  f 'Í' = "\\'{I}"         --  acute accent
+  f 'ł' = "\\l "           --  l with stroke
+  f 'Ł' = "\\L "           --  l with stroke
+  f 'n' = "\\~{n}"         --  tilde
+  f 'Ñ' = "\\~{N}"         --  tilde
+  f 'Ȯ' = "\\.{O}"         --  dot over the letter
+  f 'ȯ' = "\\.{o}"         --  dot over the letter
+  f 'ö' = "\\\"{o}"        --  umlaut or dieresis
+  f 'Ö' = "\\\"{O}"        --  umlaut or dieresis
+  f 'ô' = "\\^{o}"         --  circumflex
+  f 'Ô' = "\\^{O}"         --  circumflex
+  f 'ò' = "\\`{o}"         --  grave accent
+  f 'Ò' = "\\`{O}"         --  grave accent
+  f 'ó' = "\\'{o}"         --  acute accent
+  f 'Ó' = "\\'{O}"         --  acute accent
+  f 'õ' = "\\~{o}"         --  tilde
+  f 'Õ' = "\\~{O}"         --  tilde
+  f 'ō' = "\\={o}"         --  macron accent a bar over the letter)
+  f 'Ō' = "\\={O}"         --  macron accent a bar over the letter)
+  f 'ő' = "\\H{o}"         --  long Hungarian umlaut double acute)
+  f 'Ő' = "\\H{O}"         --  long Hungarian umlaut double acute)
+  f 'Ø' = "\\O "
+  f 'ø' = "\\o "
+  f 'º' = "\\textordmasculine "
+  f 'ŏ' = "\\u{o}"         --  breve over the letter
+  f 'Ŏ' = "\\u{O}"         --  breve over the letter
+  f 'œ' = "\\oe "
+  f 'Œ' = "\\OE "
+  f 'š' = "\\v{s}"         --  caron/hacek "v") over the letter
+  f 'Š' = "\\v{S}"         --  caron/hacek "v") over the letter
+  f 'ß' = "\\ss "
+  f 'Þ' = "\\TH "
+  f 'þ' = "\\th "
+  f '™' = "\\texttrademark "
+  f 'ü' = "\\\"{u}"        --  umlaut or dieresis
+  f 'Ü' = "\\\"{U}"        --  umlaut or dieresis
+  f 'û' = "\\^{u}"         --  circumflex
+  f 'Û' = "\\^{U}"         --  circumflex
+  f 'ù' = "\\`{u}"         --  grave accent
+  f 'Ù' = "\\`{U}"         --  grave accent
+  f 'ú' = "\\'{u}"         --  acute accent
+  f 'Ú' = "\\'{U}"         --  acute accent
+  f 'ý' = "\\'{y}"         --  acute accent
+  f 'Ý' = "\\'{Y}"         --  acute accent
+  f _   = [c] -- let us think if this should be:    fatal 661 ("Symbol "++show x++" (character "++show (ord c)++") is not supported")
+
+--posixFilePath :: FilePath -> String
+-- tex uses posix file notation, however when on a windows machine, we have windows conventions for file paths...
+-- To set the graphicspath, we want something like: \graphicspath{{"c:/data/Ampersand/output/"}}
+--posixFilePath fp = "/"++System.FilePath.Posix.addTrailingPathSeparator (System.FilePath.Posix.joinPath   (tail  (splitDirectories fp)))
+
+uniquecds :: FSpec -> A_Concept -> [(String,ConceptDef)]
+uniquecds fSpec c
+ = [ (if length cDefs==1 then cdcpt cd else cdcpt cd++show i , cd)
+   | let cDefs=concDefs fSpec c
+   , (i,cd)<-zip [(1::Integer)..] cDefs ]
+-- was: [(if length(cptdf c)==1 then cdcpt cd else cdcpt cd++show i , cd) | (i,cd)<-zip [(1::Integer)..] (cptdf c)]
+
+--makeDefinition :: Options -> Int -> String -> String -> String -> String -> [Block]
+--makeDefinition opts i nm lbl defin ref =
+--  case fspecFormat opts of
+--    FLatex ->  [ Para ( [ RawInline (Text.Pandoc.Builder.Format "latex") $ "\\newglossaryentry{"++escapeNonAlphaNum nm ++"}{name={"++latexEscShw nm ++"}, description={"++latexEscShw defin++"}}\n"] ++
+--                        [ RawInline (Text.Pandoc.Builder.Format "latex") $ lbl ++ "\n" | i == 0] ++
+--                        [ RawInline (Text.Pandoc.Builder.Format "latex") $ insertAfterFirstWord refStr defStr] ++
+--                        [ RawInline (Text.Pandoc.Builder.Format "latex") (latexEscShw (" ["++ref++"]")) | not (null ref) ]
+--                      )
+--               ]
+--    _      ->  [ Para ( Str defin : [ Str (" ["++ref++"]") | not (null ref) ] )
+--               ]
+-- where refStr = "\\marge{\\gls{"++escapeNonAlphaNum nm++"}}"
+--       defStr = latexEscShw defin
+--       -- by putting the ref after the first word of the definition, it aligns nicely with the definition
+--       insertAfterFirstWord s wordsStr = let (fstWord, rest) = break (==' ') wordsStr
+--                                         in  fstWord ++ s ++ rest
+
+---------------------------
+--- LaTeX related stuff ---
+---------------------------
+
+texOnly_Id :: String -> String
+texOnly_Id s = "\\id{"++latexEscShw s++"} "
+
+texOnly_fun :: String
+texOnly_fun = "\\rightarrow "
+
+texOnly_rel :: String
+texOnly_rel = "\\times "
+
+texOnly_compose :: String
+texOnly_compose = ";"
+
+texOnly_relAdd :: String
+texOnly_relAdd = "\\dagger "
+
+texOnly_crtPrd :: String
+texOnly_crtPrd = "\\asterisk "
+
+texOnly_inter :: String
+texOnly_inter = "\\cap "
+
+texOnly_union :: String
+texOnly_union = "\\cup "
+
+texOnly_subs :: String
+texOnly_subs = "\\vdash "
+
+texOnly_equals :: String
+texOnly_equals = "="
+
+texOnly_star :: String
+texOnly_star = "^* "
+
+texOnly_plus :: String
+texOnly_plus = "^+ "
+
+texOnly_bx :: String
+texOnly_bx = " - "
+
+texOnly_lRes :: String
+texOnly_lRes = " / "
+
+texOnly_rRes :: String
+texOnly_rRes = " \\backslash "
+
+texOnly_dia :: String
+texOnly_dia = " \\Diamond "
+
+texOnly_flip :: String
+texOnly_flip = "\\smallsmile "

+ src/Database/Design/Ampersand/Output/PredLogic.hs view
@@ -0,0 +1,519 @@+module Database.Design.Ampersand.Output.PredLogic
+         ( PredLogicShow(..), showLatex, showRtf, mkVar
+         ) where
+
+import Data.List
+import Database.Design.Ampersand.Basics
+import Database.Design.Ampersand.ADL1
+import Database.Design.Ampersand.Classes
+import Database.Design.Ampersand.Misc
+import Database.Design.Ampersand.FSpec.ShowADL
+import Data.Char
+import Database.Design.Ampersand.Output.PandocAux (latexEscShw,texOnly_Id)
+
+fatal :: Int -> String -> a
+fatal = fatalMsg "Output.PredLogic"
+
+--  data PredVar = PV String     -- TODO Bedoeld om predicaten inzichtelijk te maken. Er bestaan namelijk nu verschillende manieren om hier mee om te gaan (zie ook Motivations. HJO.
+data PredLogic
+ = Forall [Var] PredLogic            |
+   Exists [Var] PredLogic            |
+   Implies PredLogic PredLogic       |
+   Equiv PredLogic PredLogic         |
+   Conj [PredLogic]                  |
+   Disj [PredLogic]                  |
+   Not PredLogic                     |
+   Pred String String                |  -- Pred nm v, with v::type   is equiv. to Rel nm Nowhere [] (type,type) True (Sgn (showADL e) type type [] "" "" "" [Asy,Sym] Nowhere 0 False)
+   PlK0 PredLogic                    |
+   PlK1 PredLogic                    |
+   R PredLogic Declaration PredLogic |
+   Atom String                       |
+   Funs String [Declaration]         |
+   Dom Expression Var                |
+   Cod Expression Var                deriving Eq
+
+data Notation = Flr | Frl | Rn | Wrap deriving Eq   -- yields notations y=r(x)  |  x=r(y)  |  x r y  | exists ... respectively.
+
+--   predKeyWords l =
+--     case l of
+--        English  ->
+
+class PredLogicShow a where
+  showPredLogic :: Lang -> a -> String
+  showPredLogic l r =
+    predLshow (natLangOps l) (toPredLogic r) -- predLshow produces raw LaTeX
+  toPredLogic :: a -> PredLogic
+
+instance PredLogicShow Rule where
+  toPredLogic ru = assemble (rrexp ru)
+
+instance PredLogicShow Expression where
+  toPredLogic = assemble
+
+-- showLatex ought to produce PandDoc mathematics instead of LaTeX source code.
+-- PanDoc, however, does not support mathematics sufficiently, as to date. For this reason we have showLatex.
+-- It circumvents the PanDoc structure and goes straight to LaTeX source code.
+-- TODO when PanDoc is up to the job.
+showLatex :: PredLogic -> [[String]]
+showLatex x 
+ = chop (predLshow ("\\forall", "\\exists", implies, "\\Leftrightarrow", "\\vee", "\\ \\wedge\t", "^{\\asterisk}", "^{+}", "\\neg", rel, fun, mathVars, "", " ", apply, "\\in") x)
+   where rel r lhs rhs  -- TODO: the stuff below is very sloppy. This ought to be derived from the stucture, instead of by this naming convention.
+           = if isIdent r then lhs++"\\ =\\ "++rhs else
+             case name r of
+              "lt"     -> lhs++"\\ <\\ "++rhs
+              "gt"     -> lhs++"\\ >\\ "++rhs
+              "le"     -> lhs++"\\ \\leq\\ "++rhs
+              "leq"    -> lhs++"\\ \\leq\\ "++rhs
+              "ge"     -> lhs++"\\ \\geq\\ "++rhs
+              "geq"    -> lhs++"\\ \\geq\\ "++rhs
+              _        -> lhs++"\\ \\id{"++latexEscShw (name r)++"}\\ "++rhs
+         fun r e = "\\id{"++latexEscShw (name r)++"}("++e++")"
+         implies antc cons = antc++" \\Rightarrow "++cons
+         apply :: Declaration -> String -> String -> String    --TODO language afhankelijk maken.
+         apply decl d c =
+            case decl of
+              Sgn{}     -> d++"\\ \\id{"++latexEscShw (name decl)++"}\\ "++c
+              Isn{}     -> d++"\\ =\\ "++c
+              Vs{}      -> "V"
+         mathVars :: String -> [Var] -> String
+         mathVars q vs
+          = if null vs then "" else
+            q++" "++intercalate "; " [intercalate ", " var++"\\coloncolon\\id{"++latexEscShw dType++"}" | (var,dType)<-vss]++":\n"
+            where
+             vss = [(map fst varCl,show(snd (head varCl))) |varCl<-eqCl snd vs]
+         chop :: String -> [[String]]
+         chop str = (map chops.lins) str
+          where
+            lins ""        = []
+            lins ('\n':cs) = "": lins cs
+            lins (c:cs)    = (c:r):rs where r:rs = case lins cs of  [] -> [""] ; e -> e
+            chops cs = let [a,b,c] = take 3 (tabs cs) in [a,b,c]
+            tabs "" = ["","","",""]
+            tabs ('\t':cs) = "": tabs cs
+            tabs (c:cs) = (c:r):rs where r:rs = tabs cs
+
+showRtf :: PredLogic -> String
+showRtf  p = predLshow (forallP, existsP, impliesP, equivP, orP, andP, k0P, k1P, notP, relP, funP, showVarsP, breakP, spaceP, apply, el)
+               p
+  where unicodeSym :: Int -> Char -> Char -> String
+        unicodeSym fs sym altChar = "{\\fs"++show fs++" \\u"++show (ord sym)++[altChar]++"}"
+        forallP = unicodeSym 32 '∀' 'A' --"{\\fs36 \\u8704A}"
+        existsP = unicodeSym 32 '∃' 'E'
+        impliesP antc cons = antc++" "++unicodeSym 26 '⇒' '?'++" "++cons
+        equivP = unicodeSym 26 '⇔' '='
+        orP = unicodeSym 30 '∨' 'v'
+        andP = unicodeSym 30 '∧' '^'
+        k0P = "{\\super "++unicodeSym 30 '∗' '*'++"}"
+        k1P = "{\\super +}"
+        notP = unicodeSym 26 '¬' '!'
+        el = unicodeSym 30 '∈' '?' 
+        relP r lhs rhs  -- TODO: sloppy code, copied from showLatex
+         = if isIdent r then lhs++"\\ =\\ "++rhs else
+           case name r of
+            "lt"     -> lhs++" < "++rhs
+            "gt"     -> lhs++" > "++rhs
+            "le"     -> lhs++" "++unicodeSym 28 '≤' '?'++" "++rhs
+            "leq"    -> lhs++" "++unicodeSym 28 '≤' '?'++" "++rhs
+            "ge"     -> lhs++" "++unicodeSym 28 '≥' '?'++" "++rhs
+            "geq"    -> lhs++" "++unicodeSym 28 '≥' '?'++" "++rhs
+            _        -> lhs++" "++name r++" "++rhs
+        funP r e = name r++"("++e++")"
+        
+        apply :: Declaration -> String -> String -> String
+        apply decl d c =
+           case decl of
+             Sgn{}     -> d++" "++name decl++" "++c
+             Isn{}     -> d++" = "++c
+             Vs{}      -> "V"
+        showVarsP :: String -> [Var] -> String
+        showVarsP q vs
+         = if null vs then "" else
+           q++intercalate "; " [intercalate ", " var++" "++unicodeSym 28 '∷' '?'++" "++dType | (var,dType)<-vss]++":\\par\n"
+           where
+            vss = [(map fst varCl,show(snd (head varCl))) |varCl<-eqCl snd vs]
+        breakP = ""
+        spaceP = " "
+
+-- natLangOps exists for the purpose of translating a predicate logic expression to natural language.
+-- It yields a vector of mostly strings, which are used to assemble a natural language text in one of the natural languages supported by Ampersand.
+natLangOps :: Named a => Lang -> (String,
+                                       String,
+                                       String -> String -> String,
+                                       String,
+                                       String,
+                                       String,
+                                       String,
+                                       String,
+                                       String,
+                                       Declaration -> String -> String -> String,
+                                       a -> String -> String,
+                                       String -> [(String, A_Concept)] -> String,
+                                       String,
+                                       String,
+                                       Declaration -> String -> String -> String,
+                                       String)
+natLangOps l
+         = case l of
+-- parameternamen:         (forallP,     existsP,        impliesP, equivP,             orP,  andP,  k0P, k1P, notP,  relP, funP, showVarsP, breakP, spaceP)
+             English -> ("For each",  "There exists", implies, "is equivalent to",  "or", "and", "*", "+", "not",  rel, fun,  langVars , "\n  ", " ", apply, "is element of")
+             Dutch   -> ("Voor elke", "Er is een",    implies, "is equivalent met", "of", "en",  "*", "+", "niet", rel, fun,  langVars , "\n  ", " ", apply, "is element van")
+            where
+               rel r = apply r
+               fun r x' = texOnly_Id(name r)++"("++x'++")"
+               implies antc cons = case l of
+                                     English  -> "If "++antc++", then "++cons
+                                     Dutch    -> "Als "++antc++", dan "++cons
+               apply decl d c =
+                  case decl of
+                    Sgn{}     -> if null (prL++prM++prR)
+                                   then "$"++d++"$ "++name decl++" $"++c++"$"
+                                   else prL++" $"++d++"$ "++prM++" $"++c++"$ "++prR
+                       where prL = decprL decl
+                             prM = decprM decl
+                             prR = decprR decl
+                    Isn{}     -> case l of
+                                     English  -> "$"++d++"$ equals $"++c++"$"
+                                     Dutch    -> "$"++d++"$ is gelijk aan $"++c++"$"
+                    Vs{}      -> case l of
+                                     English  -> show True
+                                     Dutch    -> "Waar"
+               langVars :: String -> [(String, A_Concept)] -> String
+               langVars q vs
+                   = case l of
+                      English | null vs     -> ""
+                              | q=="Exists" ->
+                                  intercalate " and "
+                                  ["there exist"
+                                   ++(if length vs'==1 then "s a "++dType else ' ':plural English dType)
+                                   ++" called "
+                                   ++intercalate ", " ['$':v'++"$" | v'<-vs'] | (vs',dType)<-vss]
+                              | otherwise   -> "If "++langVars "Exists" vs++", "
+                      Dutch   | null vs     -> ""
+                              | q=="Er is"  ->
+                                  intercalate " en "
+                                  ["er "
+                                    ++(if length vs'==1 then "is een "++dType else "zijn "++plural Dutch dType)
+                                    ++" genaamd "
+                                    ++intercalate ", " ['$':v'++"$" | v'<-vs'] | (vs',dType)<-vss]
+                              | otherwise   -> "Als "++langVars "Er is" vs++", "
+                    where
+                     vss = [(map fst vs',show(snd (head vs'))) |vs'<-eqCl snd vs]
+
+-- predLshow exists for the purpose of translating a predicate logic expression to natural language.
+-- It uses a vector of operators (mostly strings) in order to produce text. This vector can be produced by, for example, natLangOps.
+-- example:  'predLshow (natLangOps l) e' translates expression 'e'
+-- into a string that contains a natural language representation of 'e'.
+predLshow :: ( String                                    -- forallP
+             , String                                    -- existsP
+             , String -> String -> String                -- impliesP
+             , String                                    -- equivP
+             , String                                    -- orP
+             , String                                    -- andP
+             , String                                    -- kleene *
+             , String                                    -- kleene +
+             , String                                    -- notP
+             , Declaration -> String -> String -> String    -- relP
+             , Declaration -> String -> String              -- funP
+             , String -> [(String, A_Concept)] -> String -- showVarsP
+             , String                                    -- breakP
+             , String                                    -- spaceP
+             , Declaration -> String -> String -> String -- apply
+             , String                                    -- set element
+             ) -> PredLogic -> String
+predLshow (forallP, existsP, impliesP, equivP, orP, andP, k0P, k1P, notP, relP, funP, showVarsP, breakP, spaceP, apply, el)
+ = charshow 0
+     where
+      wrap i j str = if i<=j then str else "("++str++")"
+      charshow :: Integer -> PredLogic -> String
+      charshow i predexpr
+       = case predexpr of
+               Forall vars restr   -> wrap i 1 (showVarsP forallP vars ++ charshow 1 restr)
+               Exists vars restr   -> wrap i 1 (showVarsP existsP vars  ++ charshow 1 restr)
+               Implies antc conseq -> wrap i 2 (breakP++impliesP (charshow 2 antc) (charshow 2 conseq))
+               Equiv lhs rhs       -> wrap i 2 (breakP++charshow 2 lhs++spaceP++equivP++spaceP++ charshow 2 rhs)
+               Disj rs             -> if null rs
+                                      then ""
+                                      else wrap i 3 (intercalate (spaceP++orP ++spaceP) (map (charshow 3) rs))
+               Conj rs             -> if null rs
+                                      then ""
+                                      else wrap i 4 (intercalate (spaceP++andP++spaceP) (map (charshow 4) rs))
+               Funs x ls           -> case ls of
+                                         []    -> x
+                                         r:ms  -> if isIdent r then charshow i (Funs x ms) else charshow i (Funs (funP r x) ms)
+               Dom expr (x,_)      -> x++el++funP (makeRel "dom") (showADL expr)
+               Cod expr (x,_)      -> x++el++funP (makeRel "cod") (showADL expr)
+               R pexpr dec pexpr'  -> case (pexpr,pexpr') of
+                                         (Funs l [] , Funs r [])  -> wrap i 5 (apply dec l r)
+{-
+                                            (Funs l [f], Funs r [])  -> wrap i 5 (if isIdent rel
+                                                                                  then apply (makeDeclaration f) l r
+                                                                                  else apply (makeDeclaration rel) (funP f l) r)
+                                            (Funs l [] , Funs r [f]) -> wrap i 5 (if isIdent rel
+                                                                                  then apply (makeDeclaration f) l r
+                                                                                  else apply (makeDeclaration rel) l (funP f r))
+-}
+                                         (lhs,rhs)                -> wrap i 5 (relP dec (charshow 5 lhs) (charshow 5 rhs))
+               Atom atom           -> "'"++atom++"'"
+               PlK0 rs             -> wrap i 6 (charshow 6 rs++k0P)
+               PlK1 rs             -> wrap i 7 (charshow 7 rs++k1P)
+               Not rs              -> wrap i 8 (spaceP++notP++charshow 8 rs)
+               Pred nm v'          -> nm++"{"++v'++"}"
+      makeRel :: String -> Declaration -- This function exists solely for the purpose of dom and cod
+      makeRel str
+          =    Sgn { decnm   = str
+                   , decsgn  = fatal 217 "Do not refer to decsgn of this dummy relation"
+                   , decprps = [Uni,Tot]
+                   , decprps_calc = Nothing
+                   , decprL  = ""
+                   , decprM  = ""
+                   , decprR  = ""
+                   , decMean = fatal 223 "Do not refer to decMean of this dummy relation"
+                   , decfpos = OriginUnknown
+                   , deciss  = fatal 226 "Do not refer to deciss of this dummy relation"
+                   , decusr  = False
+                   , decpat  = fatal 228 "Do not refer to decpat of this dummy relation"
+                   , decplug = fatal 229 "Do not refer to decplug of this dummy relation"
+                   }
+
+--objOrShow :: Lang -> PredLogic -> String
+--objOrShow l = predLshow ("For all", "Exists", implies, " = ", " = ", "<>", "OR", "AND", "*", "+", "NOT", rel, fun, langVars l, "\n", " ")
+--               where rel r lhs rhs = applyM (makeDeclaration r) lhs rhs
+--                     fun r x = x++"."++name r
+--                     implies antc cons = "IF "++antc++" THEN "++cons
+
+-- The function 'assemble' translates a rule to predicate logic.
+-- In order to remain independent of any representation, it transforms the Haskell data structure Rule
+-- into the data structure PredLogic, rather than manipulate with texts.
+type Var = (String,A_Concept)
+assemble :: Expression -> PredLogic
+assemble expr
+ = case (source expr, target expr) of
+        (ONE, ONE) -> rc
+        (_  , ONE) -> Forall [s] rc
+        (ONE, _)   -> Forall [t] rc
+        (_  , _)   -> Forall [s,t] rc
+  where
+   [s,t] = mkVar [] [source expr, target expr]
+   rc = f [s,t] expr (s,t)
+   f :: [Var] -> Expression -> (Var,Var) -> PredLogic
+   f exclVars (EEqu (l,r)) (a,b)  = Equiv (f exclVars l (a,b)) (f exclVars r (a,b))
+   f exclVars (EImp (l,r)) (a,b)  = Implies (f exclVars l (a,b)) (f exclVars r (a,b))
+   f exclVars e@EIsc{}     (a,b)  = Conj [f exclVars e' (a,b) | e'<-exprIsc2list e]
+   f exclVars e@EUni{}     (a,b)  = Disj [f exclVars e' (a,b) | e'<-exprUni2list e]
+   f exclVars (EDif (l,r)) (a,b)  = Conj [f exclVars l (a,b), Not (f exclVars r (a,b))]
+   f exclVars (ELrs (l,r)) (a,b)  = Forall [c] (Implies (f eVars r (b,c)) (f eVars l (a,c)))
+                                    where [c]   = mkVar exclVars [target l]
+                                          eVars = exclVars++[c]
+   f exclVars (ERrs (l,r)) (a,b)  = Forall [c] (Implies (f eVars l (c,a)) (f eVars r (c,b)))
+                                    where [c]   = mkVar exclVars [source l]
+                                          eVars = exclVars++[c]
+   f exclVars (EDia (l,r)) (a,b)  = Forall [c] (Equiv (f eVars r (b,c)) (f eVars l (a,c)))
+                                    where [c]   = mkVar exclVars [target l]
+                                          eVars = exclVars++[c]
+   f exclVars e@ECps{}     (a,b)  = fECps exclVars e (a,b)  -- special treatment, see below
+   f exclVars e@ERad{}     (a,b)  = fERad exclVars e (a,b)  -- special treatment, see below
+   f _        (EPrd (l,r)) (a,b)  = Conj [Dom l a, Cod r b]
+   f exclVars (EKl0 e)     (a,b)  = PlK0 (f exclVars e (a,b))
+   f exclVars (EKl1 e)     (a,b)  = PlK1 (f exclVars e (a,b))
+   f exclVars (ECpl e)     (a,b)  = Not (f exclVars e (a,b))
+   f exclVars (EBrk e)     (a,b)  = f exclVars e (a,b)
+   f _ e@(EDcD dcl) ((a,sv),(b,tv)) = res
+    where
+     res = case denote e of
+            Flr  -> R (Funs a [dcl]) (Isn tv) (Funs b [])
+            Frl  -> R (Funs a []) (Isn sv) (Funs b [dcl])
+            Rn   -> R (Funs a []) (dcl) (Funs b [])
+            Wrap -> fatal 246 "function res not defined when denote e == Wrap. "
+   f _ e@(EFlp (EDcD dcl)) ((a,sv),(b,tv)) = res
+    where
+     res = case denote e of
+            Flr  -> R (Funs a [dcl]) (Isn tv) (Funs b [])
+            Frl  -> R (Funs a []) (Isn sv) (Funs b [dcl])
+            Rn   -> R (Funs b []) (dcl) (Funs a [])
+            Wrap -> fatal 253 "function res not defined when denote e == Wrap. "
+   f exclVars (EFlp e)       (a,b) = f exclVars e (b,a)
+   f _ (EMp1 atom _) _             = Atom atom
+   f _ (EDcI _) ((a,_),(b,tv))     = R (Funs a []) (Isn tv) (Funs b [])
+   f _ (EDcV _) _                  = Atom "True"
+   f _ e _ = fatal 298 ("Non-exhaustive pattern in subexpression "++showADL e++" of assemble (<"++showADL expr++">)")
+
+-- fECps treats the case of a composition.  It works as follows:
+--       An expression, e.g. r;s;t , is translated to Exists (zip ivs ics) (Conj (frels s t)),
+--       in which ivs is a list of variables that are used inside the resulting expression,
+--       ics contains their types, and frels s t the subexpressions that
+--       are used in the resulting conjuct (at the right of the quantifier).
+   fECps :: [Var] -> Expression -> (Var,Var) -> PredLogic
+   fECps exclVars    e             (a,b)
+                            --   f :: [Var] -> Expression -> (Var,Var) -> PredLogic
+     | and [isCpl e' | e'<-es] = f exclVars (deMorganECps e) (a,b)
+     | otherwise               = Exists ivs (Conj (frels a b))
+     where
+      es :: [Expression]
+      es   = [ x | x<-exprCps2list e, not (isEpsilon x) ]
+     -- Step 1: split in fragments at those points where an exists-quantifier is needed.
+     --         Each fragment represents a subexpression with variables
+     --         at the outside only. Fragments will be reconstructed in a conjunct.
+      res :: [(Var -> Var -> PredLogic, A_Concept, A_Concept)]
+      res = pars3 (exclVars++ivs) (split es)  -- yields triples (r,s,t): the fragment, its source and target.
+     -- Step 2: assemble the intermediate variables from at the right spot in each fragment.
+      frels :: Var -> Var -> [PredLogic]
+      frels src trg = [r v w | ((r,_,_),v,w)<-zip3 res' (src: ivs) (ivs++[trg]) ]
+     -- Step 3: compute the intermediate variables and their types
+      res' :: [(Var -> Var -> PredLogic, A_Concept, A_Concept)]
+      res' = [triple | triple<-res, not (atomic triple)]
+      ivs ::  [Var]
+      ivs  = mkvar exclVars ics
+      ics ::  [ Either PredLogic A_Concept ] -- each element is either an atom or a concept
+      ics  = concat
+             [ case (v',w) of
+                 (Left _,    Left _   ) -> []
+                 (Left atom, Right  _ ) -> [ Left atom ]
+                 (Right  _ , Left atom) -> [ Left atom ]
+                 (Right trg, Right  _ ) -> [ Right trg ] -- SJ 20131117, was: (if trg==src then [ Right trg ] else [ Right (trg `meet` src) ])
+                                                         -- This code assumes no ISA's in the A-structure. This works due to the introduction of EEps expressions.
+             | (v',w)<-zip [ case l ("",src) ("",trg) of
+                              atom@Atom{} -> Left atom
+                              _           -> Right trg
+                           | (l,src,trg)<-init res]
+                           [ case r ("",src) ("",trg) of
+                              atom@Atom{} -> Left atom
+                              _           -> Right src
+                           | (r,src,trg)<-tail res]
+             ]
+   atomic :: (Var -> Var -> PredLogic, A_Concept, A_Concept) -> Bool
+   atomic (r,a,b) = case r ("",a) ("",b) of
+                     Atom{} -> True
+                     _      -> False
+   mkvar :: [Var] -> [ Either PredLogic A_Concept ] -> [Var]
+   mkvar exclVars (Right z: ics) = let vz = head (mkVar exclVars [z]) in vz: mkvar (exclVars++[vz]) ics
+   mkvar exclVars (Left  _: ics) = mkvar exclVars ics
+   mkvar _ [] = []
+
+   fERad :: [Var] -> Expression -> (Var,Var) -> PredLogic
+   fERad exclVars e (a,b)
+     | and[isCpl e' |e'<-es] = f exclVars (deMorganERad e) (a,b)                      -- e.g.  -r!-s!-t
+     | isCpl (head es)       = f exclVars (foldr1 (.:.) antr .\. foldr1 (.!.) conr) (a,b)  -- e.g.  -r!-s! t  antr cannot be empty, because isCpl (head es) is True; conr cannot be empty, because es has an element that is not isCpl.
+     | isCpl (last es)       = f exclVars (foldr1 (.!.) conl ./. foldr1 (.:.) antl) (a,b)  -- e.g.   r!-s!-t  antl cannot be empty, because isCpl (head es) is True; conl cannot be empty, because es has an element that is not isCpl.
+     | otherwise             = Forall ivs (Disj (frels a b))                               -- e.g.   r!-s! t  the condition or [isCpl e' |e'<-es] is true.
+{- was:
+        | otherwise             = Forall ivs (Disj alls)
+                                  where alls = [f (exclVars++ivs) e' (sv,tv) | (e',(sv,tv))<-zip es (zip (a:ivs) (ivs++[b]))]
+-}
+     where
+      es   = [ x | x<-exprRad2list e, not (isEpsilon x) ] -- The definition of exprRad2list guarantees that length es>=2
+      res  = pars3 (exclVars++ivs) (split es)  -- yields triples (r,s,t): the fragment, its source and target.
+      conr = dropWhile isCpl es -- There is at least one positive term, because conr is used in the second alternative (and the first alternative deals with absence of positive terms).
+                                -- So conr is not empty.
+      antr = let x = (map notCpl.map flp.reverse.takeWhile isCpl) es in
+             if null x then fatal 367 ("Entering in an empty foldr1") else x
+      conl = let x = (reverse.dropWhile isCpl.reverse) es in
+             if null x then fatal 369 ("Entering in an empty foldr1") else x
+      antl = let x = (map notCpl.map flp.takeWhile isCpl.reverse) es in
+             if null x then fatal 371 ("Entering in an empty foldr1") else x
+     -- Step 2: assemble the intermediate variables from at the right spot in each fragment.
+      frels :: Var -> Var -> [PredLogic]
+      frels src trg = [r v w | ((r,_,_),v,w)<-zip3 res' (src: ivs) (ivs++[trg]) ]
+     -- Step 3: compute the intermediate variables and their types
+      res' :: [(Var -> Var -> PredLogic, A_Concept, A_Concept)]
+      res' = [triple | triple<-res, not (atomic triple)]
+      ivs ::  [Var]
+      ivs  = mkvar exclVars ics
+      ics ::  [ Either PredLogic A_Concept ] -- each element is either an atom or a concept
+      ics  = concat
+             [ case (v',w) of
+                 (Left _,    Left _   ) -> []
+                 (Left atom, Right  _ ) -> [ Left atom ]
+                 (Right  _ , Left atom) -> [ Left atom ]
+                 (Right trg, Right  _ ) -> [ Right trg ] -- SJ 20131117, was: (if trg==src then [ Right trg ] else [ Right (trg `meet` src) ])
+                                                         -- This code assumes no ISA's in the A-structure. This works due to the introduction of EEps expressions.
+             | (v',w)<-zip [ case l ("",src) ("",trg) of
+                              atom@Atom{} -> Left atom
+                              _           -> Right trg
+                           | (l,src,trg)<-init res]
+                           [ case r ("",src) ("",trg) of
+                              atom@Atom{} -> Left atom
+                              _           -> Right src
+                           | (r,src,trg)<-tail res]
+             ]
+
+   relFun :: [Var] -> [Expression] -> Expression -> [Expression] -> Var->Var->PredLogic
+   relFun exclVars lhs e rhs
+     = case e of
+         EDcD dcl        -> \sv tv->R (Funs (fst sv) [r | t'<-        lhs, r<-relsMentionedIn t']) dcl (Funs (fst tv) [r | t'<-reverse rhs, r<-relsMentionedIn t'])
+         EFlp (EDcD dcl) -> \sv tv->R (Funs (fst tv) [r | t'<-reverse rhs, r<-relsMentionedIn t']) dcl (Funs (fst sv) [r | t'<-        lhs, r<-relsMentionedIn t'])
+         EMp1 atom _     -> \_ _->Atom atom
+         EFlp EMp1{}     -> relFun exclVars lhs e rhs
+         _               -> \sv tv->f (exclVars++[sv,tv]) e (sv,tv)
+
+   pars3 :: [Var] -> [[Expression]] -> [(Var -> Var -> PredLogic, A_Concept, A_Concept)]
+   pars3 exclVars (lhs: [e]: rhs: ts)
+    | denotes lhs==Flr && denote e==Rn && denotes rhs==Frl
+       = ( relFun exclVars lhs e rhs, source (head lhs), target (last rhs)): pars3 exclVars ts
+    | otherwise = pars2 exclVars (lhs:[e]:rhs:ts)
+   pars3 exclVars ts = pars2 exclVars ts -- for lists shorter than 3
+
+   pars2 :: [Var] -> [[Expression]]-> [(Var -> Var -> PredLogic, A_Concept, A_Concept)]
+   pars2 exclVars (lhs: [e]: ts)
+    | denotes lhs==Flr && denote e==Rn
+                = (relFun exclVars lhs e [], source (head lhs), target e): pars3 exclVars ts
+    | denotes lhs==Flr && denote e==Frl
+                = (relFun exclVars lhs (EDcI (source e)) [e], source (head lhs), target e): pars3 exclVars ts
+    | otherwise = pars1 exclVars (lhs:[e]:ts)
+   pars2 exclVars ([e]: rhs: ts)
+    | denotes rhs==Frl && denote e==Rn
+                = (relFun exclVars [] e rhs, source e, target (last rhs)): pars3 exclVars ts
+    | denote e==Flr && denotes rhs==Frl
+                = (relFun exclVars [e] (EDcI (source e)) rhs, source e, target (last rhs)): pars3 exclVars ts
+    | otherwise = pars1 exclVars ([e]:rhs:ts)
+   pars2 exclVars (lhs: rhs: ts)
+    | denotes lhs==Flr && denotes rhs==Frl
+                = (relFun exclVars lhs (EDcI (source (head rhs))) rhs, source (head lhs), target (last rhs)): pars3 exclVars ts
+    | otherwise = pars1 exclVars (lhs:rhs:ts)
+   pars2 exclVars ts = pars1 exclVars ts -- for lists shorter than 2
+
+   pars1 :: [Var] -> [[Expression]] -> [(Var -> Var -> PredLogic, A_Concept, A_Concept)]
+   pars1 exclVars expressions
+     = case expressions of
+         []        -> []
+         (lhs: ts) -> (pars0 exclVars lhs, source (head lhs), target (last lhs)): pars3 exclVars ts
+
+   pars0 :: [Var] -> [Expression] -> Var -> Var -> PredLogic
+   pars0 exclVars lhs
+    | denotes lhs==Flr = relFun exclVars lhs (EDcI (source (last lhs))) []
+    | denotes lhs==Frl = relFun exclVars []  (EDcI (target (last lhs))) lhs
+    | otherwise        = relFun exclVars [] (let [r]=lhs in r) []
+
+   denote :: Expression -> Notation
+   denote e = case e of
+      (EDcD d)
+        | null([Uni,Inj,Tot,Sur] >- multiplicities d)  -> Rn
+        | isUni d && isTot d                           -> Flr
+        | isInj d && isSur d                           -> Frl
+        | otherwise                                    -> Rn
+      _                                                -> Rn
+   denotes :: [Expression] -> Notation
+   denotes = denote . head
+
+   split :: [Expression] -> [[Expression]]
+   split []  = []
+   split [e] = [[e]]
+   split (e:e':es)
+    = --if denote e `eq` Wrap      then (e:spl):spls else
+      if denote e `eq` denote e' then (e:spl):spls else
+                                      [e]:spl:spls
+      where
+        spl:spls = split (e':es)
+        Flr `eq` Flr = True
+        Frl `eq` Frl = True
+        _ `eq` _     = False
+
+-- mkVar is bedoeld om nieuwe variabelen te genereren, gegeven een set (ex) van reeds vergeven variabelen.
+-- mkVar garandeert dat het resultaat niet in ex voorkomt, dus postconditie:   not (mkVar ex cs `elem` ex)
+-- Dat gebeurt door het toevoegen van apostrofes.
+mkVar :: [Var] -> [A_Concept] -> [Var]
+mkVar ex cs = mknew (map fst ex) [([(toLower.head.(++"x").name) c],c) |c<-cs]
+ where
+  mknew _ [] = []
+  mknew ex' ((x,c):xs) = if x `elem` ex'
+                         then mknew ex' ((x++"'",c):xs)
+                         else (x,c): mknew (ex'++[x]) xs

+ src/Database/Design/Ampersand/Output/Statistics.hs view
@@ -0,0 +1,52 @@+module Database.Design.Ampersand.Output.Statistics (Statistics(..)) where
+
+import Database.Design.Ampersand.Core.AbstractSyntaxTree
+import Database.Design.Ampersand.FSpec.FSpec
+import Database.Design.Ampersand.FSpec.FPA
+import Database.Design.Ampersand.Basics (fatalMsg)
+
+fatal :: Int -> String -> a
+fatal = fatalMsg "Output.Statistics"
+
+-- TODO Deze module moet nog verder worden ingekleurd...
+
+class Statistics a where
+  nInterfaces :: a -> Int      -- ^ The number of interfaces in a
+  nPatterns :: a -> Int      -- ^ The number of patterns in a
+  nFpoints :: a -> Int      -- ^ The number of function points in a
+
+instance Statistics a => Statistics [a] where
+  nInterfaces xs = sum (map nInterfaces xs)
+  nPatterns   xs = sum (map nPatterns xs)
+  nFpoints    xs = sum (map nFpoints xs)
+
+instance Statistics FSpec where
+  nInterfaces fSpec = length (fActivities fSpec) --TODO -> check correctness
+  nPatterns   fSpec = nPatterns (vpatterns fSpec)
+  nFpoints    fSpec = sum [nFpoints ifc | ifc <- (interfaceS fSpec++interfaceG fSpec)]
+                --       + sum [fPoints (fpa plug) | InternalPlug plug <- plugInfos fSpec]
+-- TODO Deze module moet nog verder worden ingekleurd...
+
+instance Statistics Pattern where
+  nInterfaces _ = 0 --TODO -> check correctness
+  nPatterns   _ = 1
+  nFpoints   _  = fatal 43 "function points are not defined for patterns at all."
+
+--   instance Statistics Activity where
+--    nInterfaces _ = 1
+--    nPatterns   _ = 0
+--    nFpoints act  = fPoints (actFPA act) --TODO -> implement correct FPA qualification
+
+-- \***********************************************************************
+-- \*** Properties with respect to: Dataset                       ***
+-- \*** TODO: both datasets and interfaces are represented as ObjectDef. This does actually make a difference for the function point count, so we have work....
+instance Statistics Interface where
+  nInterfaces _ = 1
+  nPatterns   _ = 0
+  nFpoints ifc  = fpVal $ fpaInterface ifc
+
+--   instance Statistics ObjectDef where
+--    nInterfaces (Obj{objmsub=Nothing}) = 2 -- this is an association, i.e. a binary relation --TODO -> check correctness
+--    nInterfaces _ = 4 -- this is an entity with one or more attributes. --TODO -> check correctness
+--    nPatterns   _ = 0
+--    nFpoints    _ = fatal 60 "function points are not defined for ObjectDefs at all."

+ src/Database/Design/Ampersand/Output/ToPandoc/ChapterConceptualAnalysis.hs view
@@ -0,0 +1,193 @@+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE OverloadedStrings #-}
+module Database.Design.Ampersand.Output.ToPandoc.ChapterConceptualAnalysis
+where
+import Database.Design.Ampersand.Output.ToPandoc.SharedAmongChapters
+import Database.Design.Ampersand.Output.PredLogic        (PredLogicShow(..), showLatex)
+import Database.Design.Ampersand.Classes
+import Database.Design.Ampersand.Output.PandocAux
+import Data.List (intersperse )
+
+fatal :: Int -> String -> a
+fatal = fatalMsg "Output.ToPandoc.ChapterConceptualAnalysis"
+
+chpConceptualAnalysis :: Int -> FSpec -> (Blocks,[Picture])
+chpConceptualAnalysis lev fSpec = (
+      --  *** Header ***
+   chptHeader (fsLang fSpec) ConceptualAnalysis
+   <> --  *** Intro  ***
+   caIntro
+   <> --  *** For all themes, a section containing the conceptual analysis for that theme  ***
+   caBlocks, pictures)
+  where
+  -- shorthand for easy localizing    
+  l :: LocalizedStr -> String
+  l lstr = localize (fsLang fSpec) lstr
+  caIntro :: Blocks
+  caIntro
+   = (case fsLang fSpec of
+        Dutch   -> para
+                    (  "Dit hoofdstuk beschrijft een formele taal, waarin functionele eisen ten behoeve van "
+                    <> (singleQuoted.str.name) fSpec
+                    <> " kunnen worden besproken en uitgedrukt. "
+                    <> "De formalisering dient om een bouwbare specificatie te verkrijgen. "
+                    <> "Een derde met voldoende deskundigheid kan op basis van dit hoofdstuk toetsen of de gemaakte afspraken "
+                    <> "overeenkomen met de formele regels en definities. "
+                    )
+        English -> para
+                    (  "This chapter defines the formal language, in which functional requirements of "
+                    <> (singleQuoted.str.name) fSpec
+                    <> " can be analysed and expressed."
+                    <> "The purpose of this formalisation is to obtain a buildable specification. "
+                    <> "This chapter allows an independent professional with sufficient background to check whether the agreements made "
+                    <> "correspond to the formal rules and definitions. "
+                    )
+     )<> purposes2Blocks (getOpts fSpec) (purposesDefinedIn fSpec (fsLang fSpec) fSpec) -- This explains the purpose of this context.
+
+  caBlocks = mconcat (map caSection (vpatterns fSpec))
+  pictures = concatMap patPicts (vpatterns fSpec)
+  -----------------------------------------------------
+  -- the Picture that represents this pattern's conceptual graph
+  patPicts :: Pattern -> [Picture]
+  patPicts pat = pictOfPat pat :
+                (map pictOfRule (invariants fSpec `isc` udefrules pat))
+  pictOfPat  :: Pattern ->  Picture
+  pictOfPat  = makePicture fSpec . PTRelsUsedInPat
+  pictOfRule :: Rule -> Picture
+  pictOfRule = makePicture fSpec . PTSingleRule
+  caSection :: Pattern -> Blocks
+  caSection pat
+   =    -- new section to explain this pattern
+        headerWithLabel (XRefConceptualAnalysisPattern pat) (lev+2) ((text.name) pat)
+        -- The section starts with the reason why this pattern exists
+     <> (purposes2Blocks (getOpts fSpec) (purposesDefinedIn fSpec (fsLang fSpec) pat))
+        -- followed by a conceptual model for this pattern
+     <> ( case (genGraphics (getOpts fSpec), fsLang fSpec) of
+               (True,Dutch  ) -> -- announce the conceptual diagram
+                                 para ("Figuur " <> xRefReference (getOpts fSpec) (pictOfPat pat) <> " geeft een conceptueel diagram van dit pattern.")
+                                 -- draw the conceptual diagram
+                               <>((plain . showImage (getOpts fSpec) . pictOfPat) pat)
+               (True,English) -> para ("Figure " <> xRefReference (getOpts fSpec) (pictOfPat pat) <> " shows a conceptual diagram of this pattern.")
+                               <>((plain . showImage (getOpts fSpec) . pictOfPat) pat)
+               _              -> mempty
+        ) <>
+    (
+        -- now provide the text of this pattern.
+        (case fsLang fSpec of
+           Dutch   -> para "De definities van concepten zijn te vinden in de index."
+                   <> header (lev+3) "Gedeclareerde relaties"
+                   <> para "Deze paragraaf geeft een opsomming van de gedeclareerde relaties met eigenschappen en betekenis."
+           English -> para "The definitions of concepts can be found in the glossary."
+                   <> header (lev+3) "Declared relations"
+                   <> para "This section itemizes the declared relations with properties and purpose."
+        )
+     <> definitionList (map caRelation [d | d@Sgn{}<-relsDefdIn pat `uni` relsMentionedIn pat])
+     <> case map caRule (invariants fSpec `isc` udefrules pat) of
+         []     -> mempty
+         blocks -> (case fsLang fSpec of
+                      Dutch   -> header (lev+3) "Regels"
+                              <> plain "Deze paragraaf geeft een opsomming van de regels met een verwijzing naar de gemeenschappelijke taal van de belanghebbenden ten behoeve van de traceerbaarheid."
+                      English -> header (lev+3) "Rules"
+                              <> plain "This section itemizes the rules with a reference to the shared language of stakeholders for the sake of traceability."
+                   )
+                   <> definitionList blocks
+    )
+  caRelation :: Declaration -> (Inlines, [Blocks])
+  caRelation d
+        = let purp =  (purposes2Blocks (getOpts fSpec) [p | p<-purposesDefinedIn fSpec (fsLang fSpec) d])
+          in (mempty
+             ,[   -- First the reason why the relation exists, if any, with its properties as fundamental parts of its being..
+                ( case ( isNull purp, fsLang fSpec) of
+                   (True , Dutch)   -> plain ("De volgende " <> str(nladjs d) <> " is gedefinieerd ")
+                   (True , English) -> plain ("The following " <> str(ukadjs d) <> " has been defined ")
+                   (False, Dutch)   -> purp <> plain ("Voor dat doel is de volgende " <> str(nladjs d) <> " gedefinieerd ")
+                   (False, English) -> purp <> plain ("For this purpose, the following " <> str(ukadjs d) <> " has been defined ")
+                )
+                  -- Then the declaration of the relation with its properties and its intended meaning
+               <> pandocEqnArrayWithLabel (XRefConceptualAnalysisDeclaration d)
+                     [ [ texOnly_Id(name d)
+                       , ":"
+                       , texOnly_Id(name (source d))++(if isFunction d then texOnly_fun else texOnly_rel)++texOnly_Id(name(target d)) 
+                       ]  
+                     ]
+               <> case meaning2Blocks (fsLang fSpec) d of
+                    [] -> case fsLang fSpec of
+                           Dutch   -> case commaNL  "en"  [ show (amLang markup) | markup<-ameaMrk (decMean d), amLang markup/=fsLang fSpec] of
+                                       []    -> plain "(Geen betekenis gespecificeerd)"
+                                       langs -> plain (str ("(Geen betekenis gespecificeerd, maar wel in het "++langs++")"))
+                           English -> case commaEng "and" [ show (amLang markup) | markup<-ameaMrk (decMean d), amLang markup/=fsLang fSpec] of
+                                       []    -> plain "(No meaning has been specified)"
+                                       langs -> plain (str ("(No meaning has been specified, except in "++langs++")"))
+                    ms -> fromList ms
+              ])
+  ukadjs d  = case [Uni,Tot]>-multiplicities d of
+               [] -> commaEng "and" (map ukadj (multiplicities d>-[Uni,Tot]))++" function"
+               _  -> commaEng "and" (map ukadj (multiplicities d))++" relation"
+   where
+    ukadj Uni = "univalent"
+    ukadj Inj = "injective"
+    ukadj Sur = "surjective"
+    ukadj Tot = "total"
+    ukadj Sym = "symmetric"
+    ukadj Asy = "antisymmetric"
+    ukadj Trn = "transitive"
+    ukadj Rfx = "reflexive"
+    ukadj Irf = "irreflexive"
+    ukadj Aut = "automatically computed"    
+  nladjs d = case [Uni,Tot]>-multiplicities d of
+               [] -> commaNL "en" (map nladj (multiplicities d>-[Uni,Tot]))++" functie"
+               _  -> commaNL "en" (map nladj (multiplicities d))++" relatie"
+   where
+    nladj Uni = "univalente"
+    nladj Inj = "injectieve"
+    nladj Sur = "surjectieve"
+    nladj Tot = "totale"
+    nladj Sym = "symmetrische"
+    nladj Asy = "antisymmetrische"
+    nladj Trn = "transitieve"
+    nladj Rfx = "reflexieve"
+    nladj Irf = "irreflexieve"
+    nladj Aut = "automatisch berekende"  
+  caRule :: Rule -> (Inlines, [Blocks])
+  caRule r
+        = let purp = (purposes2Blocks (getOpts fSpec) (purposesDefinedIn fSpec (fsLang fSpec) r))
+          in ( mempty
+             , [  -- First the reason why the rule exists, if any..
+                  purp
+                  -- Then the rule as a requirement
+               <> plain 
+                   ( if isNull purp
+                     then (xRefTo . XRefNaturalLanguageRule) r 
+                       <> str (l (NL " is gemaakt :" ,EN " has been made:"))
+                     else str (l (NL "Daarom bestaat ", EN "Therefore "))
+                       <> (xRefTo . XRefNaturalLanguageRule) r
+                       <> str (l (NL ":", EN " exists:"))
+                   )
+               <> fromList (meaning2Blocks  (fsLang fSpec) r)
+                  -- then the formal rule
+               <> plain 
+                   (  str (l (NL "Dit is - gebruikmakend van relaties "
+                             ,EN "Using relations "  ))
+                    <>(mconcat (intersperse  (str ", ") 
+                          [   xRefTo (XRefConceptualAnalysisDeclaration d) 
+                           <> text (" ("++name d++")")
+                          | d@Sgn{}<-relsMentionedIn r]))  
+                    <> str (l (NL " - geformaliseerd als "
+                              ,EN ", this is formalized as "))    
+                   )
+               <> (if showPredExpr (getOpts fSpec)
+                   then pandocEqnArrayWithLabel (XRefConceptualAnalysisRule r) ((showLatex.toPredLogic) r)
+                   else pandocEquationWithLabel (XRefConceptualAnalysisRule r) (showMath r)
+                  )
+               -- followed by a conceptual model for this rule
+               <> if genGraphics (getOpts fSpec)
+                  then para
+                         (   str (l (NL "Figuur ", EN "Figure "))
+                          <> xRefReference (getOpts fSpec) (pictOfRule r)
+                          <> str (l (NL " geeft een conceptueel diagram van deze regel."
+                                    ,EN " shows a conceptual diagram of this rule."))
+                         )
+                     <>plain (showImage (getOpts fSpec) (pictOfRule r))
+                  else mempty
+               ]
+             )

+ src/Database/Design/Ampersand/Output/ToPandoc/ChapterDataAnalysis.hs view
@@ -0,0 +1,734 @@+{-# LANGUAGE OverloadedStrings #-}
+module Database.Design.Ampersand.Output.ToPandoc.ChapterDataAnalysis (chpDataAnalysis) where
+
+import Database.Design.Ampersand.ADL1 hiding (Association)
+import Database.Design.Ampersand.Output.ToPandoc.SharedAmongChapters hiding (Association)
+import Database.Design.Ampersand.Output.PandocAux
+import Database.Design.Ampersand.FSpec.Crud
+import Database.Design.Ampersand.FSpec.Graphic.ClassDiagram --(Class(..),CdAttribute(..))
+import Database.Design.Ampersand.Output.PredLogic
+import Data.Char
+import Data.List
+import Data.Function (on)
+import qualified Text.Pandoc.Builder
+
+fatal :: Int -> String -> a
+fatal = fatalMsg "Output.ToPandoc.ChapterDataAnalysis"
+
+------------------------------------------------------------
+--DESCR -> the data analysis contains a section for each class diagram in the fSpec
+--         the class diagram and multiplicity rules are printed
+chpDataAnalysis :: FSpec -> (Blocks,[Picture])
+chpDataAnalysis fSpec = (theBlocks, thePictures)
+ where
+  theBlocks
+    =  chptHeader (fsLang fSpec) DataAnalysis  -- The header
+    <> (case fsLang fSpec of
+             Dutch   -> para ( "Dit hoofdstuk bevat het resultaat van de gegevensanalyse. "
+                            <> "De opbouw is als volgt:"
+                             )
+                     <> para ( if summaryOnly
+                               then  "We beginnen met "
+                               else  "We beginnen met het classificatiemodel, gevolgd door "
+                            <>  "een overzicht van alle relaties, die samen de basis vormen van de rest van deze analyse. "
+                            <>  "Ten slotte volgen achtereenvolgend het logische- en technische gegevensmodel."
+                             )
+             English -> para (  "This chapter contains the result of the data analysis. "
+                            <>  "It is structured as follows:"
+                             )
+                     <> para ( if summaryOnly
+                               then  "We start with "
+                               else  "We start with the classification model, followed by "
+                            <>  "a list of all relations, that are the foundation of the rest of the analysis. "
+                            <>  "Finally, the logical and technical data model are discussed."
+                             )
+       )
+    <> if summaryOnly then mempty else classificationBlocks
+    <> daRulesBlocks
+    <> logicalDataModelBlocks
+    <> technicalDataModelBlocks
+    <> crudMatrixSection sectionLevel fSpec
+  thePictures
+    =  (if not summaryOnly then maybe [] (\p->[p]) mClassificationPicture else [])
+    ++ logicalDataModelPictures ++ technicalDataModelPictures
+
+  daRulesBlocks                                          = daRulesSection            sectionLevel fSpec
+  (classificationBlocks    , mClassificationPicture    ) = classificationSection     sectionLevel fSpec
+  (logicalDataModelBlocks  , logicalDataModelPictures  ) = logicalDataModelSection   sectionLevel fSpec
+  (technicalDataModelBlocks, technicalDataModelPictures) = technicalDataModelSection sectionLevel fSpec
+  sectionLevel = 2
+
+  -- | In some cases, only a summary of the data analysis is required as output.
+  summaryOnly :: Bool
+  summaryOnly = theme (getOpts fSpec) `elem` [StudentTheme]
+
+classificationSection :: Int -> FSpec -> (Blocks, Maybe Picture)
+classificationSection _   fSpec | null (classes $ clAnalysis fSpec) = (mempty,    Nothing)
+classificationSection lev fSpec | otherwise                         = (theBlocks, Just pict)
+ where
+  theBlocks =
+       header lev (case fsLang fSpec of
+                    Dutch   ->  "Classificaties"
+                    English ->  "Classifications"
+                  )
+    <> para (case fsLang fSpec of
+              Dutch   ->  "Een aantal concepten zit in een classificatiestructuur. "
+                       <> (if canXRefer (getOpts fSpec)
+                           then  "Deze is in figuur " <> xRefReference (getOpts fSpec) pict <> "weergegeven."
+                           else "Deze is in onderstaand figuur weergegeven."
+                          )
+              English -> "A number of concepts is organized in a classification structure. "
+                       <> (if canXRefer (getOpts fSpec)
+                           then "This is shown in figure " <> xRefReference (getOpts fSpec) pict <> "."
+                           else "This is shown in the figure below."
+                          )
+            )
+         <> para (showImage (getOpts fSpec) pict)
+
+  pict :: Picture
+  pict = makePicture fSpec PTClassDiagram
+
+logicalDataModelSection :: Int -> FSpec -> (Blocks,[Picture])
+logicalDataModelSection lev fSpec = (theBlocks, [pict])
+ where
+  theBlocks =
+       header lev (case fsLang fSpec of
+                    Dutch   -> text "Logisch gegevensmodel"
+                    English -> text "Logical data model"
+                )
+    <> para (case fsLang fSpec of
+               Dutch   -> (text "De afspraken zijn vertaald naar een gegevensmodel. "
+                         <> ( if canXRefer (getOpts fSpec)
+                              then text "Dit gegevensmodel is in figuur " <> xRefReference (getOpts fSpec) pict <> text " weergegeven."
+                              else text "Dit gegevensmodel is in onderstaand figuur weergegeven. "
+                          ) )
+               English -> (text "The functional requirements have been translated into a data model. "
+                         <> ( if canXRefer (getOpts fSpec)
+                              then text "This model is shown by figure " <> xRefReference (getOpts fSpec) pict <> text "."
+                              else text "This model is shown by the figure below. "
+                          ) )
+            )
+     <> para (showImage (getOpts fSpec) pict)
+     <> let nrOfClasses = length (classes oocd)
+        in case fsLang fSpec of
+             Dutch   -> para (case nrOfClasses of
+                                0 -> text "Er zijn geen gegevensverzamelingen."
+                                1 -> text "Er is één gegevensverzameling, die in de volgende paragraaf in detail is beschreven:"
+                                _ -> text ("Er zijn "++count Dutch nrOfClasses "gegevensverzameling"++". ")
+                                  <> text "De details van elk van deze gegevensverzameling worden, op alfabetische volgorde, in de nu volgende paragrafen beschreven:"
+                             )
+             English -> para (case nrOfClasses of
+                                0 -> text "There are no entity types."
+                                1 -> text "There is only one entity type:"
+                                _ -> text ("There are "++count English nrOfClasses "entity type" ++".")
+                                  <> text "The details of each entity type are described (in alphabetical order) in the following paragraphs:"
+                             )
+     <> conceptTable
+     <> mconcat (map detailsOfClass (sortBy (compare `on` name) (classes oocd)))
+
+
+  -- shorthand for easy localizing    
+  l :: LocalizedStr -> String
+  l lstr = localize (fsLang fSpec) lstr
+
+  pict :: Picture
+  pict = makePicture fSpec PTLogicalDM
+
+  oocd :: ClassDiag
+  oocd = cdAnalysis fSpec
+
+  conceptTable :: Blocks
+  conceptTable = table mempty
+                 [(AlignLeft,1/6),(AlignCenter,4/6),(AlignLeft,1/6)]
+                 [ (plain.text.l) (NL "Type"          , EN "Type")
+                 , (plain.text.l) (NL "Betekenis"     , EN "Meaning")
+                 , (plain.text.l) (NL "Technisch type", EN "Technical type") 
+                 ] 
+                 [ [ (plain.text.name) c
+                   , fromList $ maybe mempty (concatMap $ amPandoc . explMarkup) $ purposeOf fSpec (fsLang fSpec) c
+                   , if c `elem` ooCpts oocd then plainText $ l (NL "Sleutel", EN "Primary Key") else mempty
+                   ]
+                 | c <- allConcepts fSpec
+                 ]
+
+  detailsOfClass :: Class -> Blocks
+  detailsOfClass cl =
+       (   header (lev+1) 
+                  (((text.l) (NL "Gegevensverzameling: ", EN "Entity type: ") <> (emph.strong.text.name) cl))
+        <> case clcpt cl of
+             Nothing -> mempty
+             Just (_, purposes)  -> purposes2Blocks (getOpts fSpec) purposes
+        <> (para . text . l) ( NL "Deze gegevensverzameling bevat de volgende attributen: "
+                             , EN "This entity type has the following attributes: "
+                             )
+        <> simpleTable [(plain.text.l) (NL "Attribuut", EN "Attribute")
+                       ,(plain.text.l) (NL "Type"     , EN "Type")
+                       ,mempty
+                       ]
+                       ( [[ (plain.text) "Id"
+                          , (plain.text.name) cl
+                          , (plain.text.l) (NL "Sleutel" , EN "Primary key")
+                         ]] 
+                         <>
+                         [[ (plain.text.name) attr
+                          , (plain.text.attTyp) attr
+                          , (plain.text.l) (if attOptional attr 
+                                            then (NL "Optioneel", EN "Optional")
+                                            else (NL "Verplicht", EN "Mandatory")
+                                           )] | attr <- clAtts cl]
+                       )
+        <> let attrNames = map name (clAtts cl)
+               asscs = [ assoc | assoc <- assocs oocd, assSrc assoc == clName cl || assTgt assoc == clName cl
+                       , not $ assrhr assoc `elem` attrNames ] 
+           in  case asscs of
+                 [] -> para ( text (name cl) <> text (l (NL " heeft geen associaties.", EN " has no associations.")))
+                 [assoc] -> purposeAndMeaningOfAssoc assoc
+                 _       ->
+                   para ( text (name cl) <> text (l (NL " heeft de volgende associaties: ", EN " has the following associations: ")))
+                   <> orderedList (map assocToRow asscs) 
+       )
+    where
+     purposeAndMeaningOfAssoc :: Association -> Blocks
+     purposeAndMeaningOfAssoc assoc =
+        purposes2Blocks (getOpts fSpec) (asspurp assoc) <>
+        (case assmean assoc of Just markup -> fromList (amPandoc markup); Nothing -> mempty )
+        
+     assocToRow :: Database.Design.Ampersand.FSpec.Graphic.ClassDiagram.Association -> Blocks
+     assocToRow assoc  =
+        (para.text.assrhr) assoc <>
+        purposeAndMeaningOfAssoc assoc
+     {- <>
+        if (null.assrhr) assoc
+        then fatal 192 "Shouldn't happen: flip the relation for the right direction!"
+        else para $ case fsLang fSpec of
+           Dutch   ->   case assrhm assoc of
+                              Mult MinZero MaxOne  -> "Ieder(e) " <> (emph.text.assSrc) assoc <> " heeft hooguit één "   <> (emph.text.assTgt) assoc <> "."
+                              Mult MinZero MaxMany -> mempty
+                              Mult MinOne  MaxOne  -> "Ieder(e) " <> (emph.text.assSrc) assoc <> " heeft precies één "    <> (emph.text.assTgt) assoc <> "."
+                              Mult MinOne  MaxMany -> "Ieder(e) " <> (emph.text.assSrc) assoc <> " heeft ten minste één " <> (emph.text.assTgt) assoc <> "."
+                      <> case asslhm assoc of
+                              Mult MinZero MaxOne  -> " Ieder(e) " <> (emph.text.assTgt) assoc <> " kan hooguit één "      <> (emph.text.assSrc) assoc <> " hebben."
+                              Mult MinZero MaxMany -> mempty
+                              Mult MinOne  MaxOne  -> " Ieder(e) " <> (emph.text.assTgt) assoc <> " kan precies één " <> (emph.text.assSrc) assoc <>       " hebben."
+                              Mult MinOne  MaxMany -> " Ieder(e) " <> (emph.text.assTgt) assoc <> " kan ten minste één "    <> (emph.text.assSrc) assoc <> " hebben."
+                      
+           English ->    case assrhm assoc of
+                              Mult MinZero MaxOne  -> "Every " <> (emph.text.assSrc) assoc <>" has at most one "  <> (emph.text.assTgt) assoc <>  "."
+                              Mult MinZero MaxMany -> mempty
+                              Mult MinOne  MaxOne  -> "Every " <> (emph.text.assSrc) assoc <>" has exactly one "  <> (emph.text.assTgt) assoc <>  "."
+                              Mult MinOne  MaxMany -> "Every " <> (emph.text.assSrc) assoc <>" has at least one " <> (emph.text.assTgt) assoc <>  "."
+                      <> case asslhm assoc of
+                              Mult MinZero MaxOne  -> " For this association each " <> (emph.text.assTgt) assoc <> " has at most one "  <> (emph.text.assSrc) assoc <> "."
+                              Mult MinZero MaxMany -> mempty
+                              Mult MinOne  MaxOne  -> " For this association each " <> (emph.text.assTgt) assoc <> " has exactly one "  <> (emph.text.assSrc) assoc <> "."
+                              Mult MinOne  MaxMany -> " For this association each " <> (emph.text.assTgt) assoc <> " has at least one " <> (emph.text.assSrc) assoc <> "."
+     -}
+
+crudMatrixSection :: Int -> FSpec -> Blocks
+crudMatrixSection lev fSpec =
+     header lev (text "Logical data model")
+  <> mconcat
+      [ simpleTable [ plainText "Concept", plainText "C", plainText "R", plainText "U", plainText "D" ] $
+          [ [ plainText $ name cncpt
+            , mconcat $ map (plainText . name) ifcsC
+            , mconcat $ map (plainText . name) ifcsR
+            , mconcat $ map (plainText . name) ifcsU
+            , mconcat $ map (plainText . name) ifcsD ]
+          | (cncpt, (ifcsC, ifcsR, ifcsU, ifcsD)) <- crudObjsPerConcept (crudInfo fSpec)
+          ]
+      ]
+  
+
+technicalDataModelSection :: Int -> FSpec -> (Blocks,[Picture])
+technicalDataModelSection lev fSpec = (theBlocks,[pict])
+ where
+   theBlocks =
+       header lev (case fsLang fSpec of
+                    Dutch   ->  "Technisch datamodel"
+                    English ->  "Technical datamodel"
+                      )
+    <> para (case fsLang fSpec of
+               Dutch   -> ( "De afspraken zijn vertaald naar een technisch datamodel. "
+                         <> ( if canXRefer (getOpts fSpec)
+                              then "Dit model is in figuur " <> xRefReference (getOpts fSpec) pict <> " weergegeven."
+                              else "Dit model is in onderstaand figuur weergegeven. "
+                          ) )
+               English -> ( "The functional requirements have been translated into a technical data model. "
+                         <> ( if canXRefer (getOpts fSpec)
+                              then "This model is shown by figure " <> xRefReference (getOpts fSpec) pict <> "."
+                              else "This model is shown by the figure below. "
+                          ) )
+            )
+    <> para (showImage (getOpts fSpec) pict)
+    <> para (let nrOfTables = length (filter isTable (plugInfos fSpec))
+             in
+             case fsLang fSpec of
+        Dutch   -> text ("Het technisch datamodel bestaat uit de volgende "++show nrOfTables++" tabellen:")
+        English -> text ("The technical datamodel consists of the following "++show nrOfTables++" tables:")
+            )
+    <> mconcat [detailsOfplug p | p <- sortBy (compare `on` (map toLower . name)) (plugInfos fSpec), isTable p]
+    where
+      isTable :: PlugInfo -> Bool
+      isTable (InternalPlug TblSQL{}) = True
+      isTable (InternalPlug BinSQL{}) = True
+      isTable (InternalPlug ScalarSQL{}) = False
+      isTable ExternalPlug{} = False
+      detailsOfplug :: PlugInfo -> Blocks
+      detailsOfplug p =
+           header 3 (   case (fsLang fSpec, p) of
+                          (Dutch  , InternalPlug{}) ->  "Tabel: "
+                          (Dutch  , ExternalPlug{}) ->  "Dataservice: "
+                          (English, InternalPlug{}) ->  "Table: "
+                          (English, ExternalPlug{}) ->  "Data service: "
+                     <> text (name p)
+                    )
+        <> case p of
+             InternalPlug tbl@TblSQL{}
+               -> (case fsLang fSpec of
+                Dutch
+                   -> para (text $ "Deze tabel heeft de volgende "++(show.length.fields) tbl++" velden:")
+                English
+                   -> para (text $ "This table has the following "++(show.length.fields) tbl++" fields:")
+                  )
+               <> showFields (plugFields tbl)
+             InternalPlug bin@BinSQL{}
+               -> para
+                       (case fsLang fSpec of
+                         Dutch
+                           ->  "Dit is een koppeltabel, die "
+                            <> primExpr2pandocMath (fsLang fSpec) (mLkp bin)
+                            <> " implementeert. De tabel bestaat uit de volgende kolommen:"
+
+                         English
+                           ->  "This is a link-table, implementing "
+                            <> primExpr2pandocMath (fsLang fSpec) (mLkp bin)
+                            <> ". It contains the following columns:"
+                       )
+                     <> showFields (plugFields bin)
+
+             InternalPlug ScalarSQL{}
+                -> mempty
+             ExternalPlug _
+               -> case fsLang fSpec of
+                    Dutch   -> para "De details van deze service zijn in dit document (nog) niet verder uitgewerkt."
+                    English -> para "The details of this dataservice are not available in this document."
+      showFields :: [SqlField] -> Blocks
+      showFields flds = bulletList (map showField flds)
+        where
+          showField fld =
+--FIXME 20140525: Onderstaande code vervangen door afl te leiden van `flduse`. Daar zit deze info al in verwerkt!
+             let isPrimaryKey = case fldexpr fld of
+                                  e@EDcI{} -> e==fldexpr (head flds) -- The first field represents the most general concept
+                                  _        -> False
+                 mForeignKey  = case fldexpr fld of
+                                  EIsc (EDcI c,_) -> Just c
+                                  _               -> Nothing
+             in para (  (strong.text.fldname) fld
+                      <> linebreak
+                      <> (if isPrimaryKey
+                          then case fsLang fSpec of
+                                Dutch   -> "Dit attribuut is de primaire sleutel. "
+                                English -> "This attribute is the primary key. "
+                          else
+                          case mForeignKey of
+                           Just c ->  case fsLang fSpec of
+                                         Dutch   -> "Dit attribuut verwijst naar een voorkomen in de tabel "
+                                         English -> "This attribute is a foreign key to "
+                                     <> (text.name) c
+                           Nothing -- (no foreign key...)
+                             -> --if isBool
+                                --then
+                                --else
+                                  (case fsLang fSpec of
+                                     Dutch   -> "Dit attribuut implementeert "
+                                     English -> "This attribute implements "
+                                  <> primExpr2pandocMath (fsLang fSpec) (fldexpr fld)
+                                  <> "."
+                                  )
+                         )
+                      <> linebreak
+                      <> (code.show.fldtype) fld
+                      <> ", "
+                      <> (case fsLang fSpec of
+                            Dutch
+                              ->  (if fldnull fld then "Optioneel" else "Verplicht")
+                               <> (if flduniq fld then ", Uniek" else "")
+                               <> "."
+                            English
+                              ->  (if fldnull fld then "Optional" else "Mandatory")
+                               <> (if flduniq fld then ", Unique" else "")
+                               <> "."
+                         )
+                     )
+   pict :: Picture
+   pict = makePicture fSpec PTTechnicalDM
+
+daRulesSection :: Int -> FSpec -> Blocks
+daRulesSection lev fSpec = theBlocks
+ where
+  theBlocks = mconcat 
+    [ header lev . text $ l (NL "Regels", EN "Rules")
+    , para . text $ l (NL "TODO: uitleg paragraaf", EN "TODO: explain section")
+    , docRules (NL "Procesregels", EN "Process rules")
+               ( NL "TODO: uitleg procesregels"
+               , EN "TODO: explain process rules")
+               ( NL "Deze specificatie bevat geen procesregels."
+               , EN "This specification does not contain any process rules.")
+               (NL "Procesregel", EN "Process rule")
+               prcssRules
+    , docRules (NL "Invarianten", EN "Invariants")
+               ( NL "TODO: uitleg invarianten"
+               , EN "TODO: explain invariants")
+               ( NL "Deze specificatie bevat geen invarianten."
+               , EN "This specification does not contain any invariants.")
+               (NL "Invariant", EN "Invariant")
+               userInvariants
+    ]
+  (prcssRules, userInvariants) = partition isSignal $ vrules fSpec
+  docRules :: LocalizedStr -> LocalizedStr -> LocalizedStr -> LocalizedStr -> [Rule] -> Blocks
+  docRules _     _     noRules _       []    = para . text $ l noRules
+  docRules title intro _       heading rules = mconcat $
+    [ header (lev+1) . text $ l title 
+    , para . text $ l intro
+    ] ++
+    map (docRule heading) rules
+  
+  docRule :: LocalizedStr -> Rule -> Blocks
+  docRule heading rule = mconcat $
+     [ plain $ strong (text (l heading ++ ": ") <> emph (text (rrnm rule)))
+     , fromList $ maybe mempty (concatMap $ amPandoc . explMarkup) $ purposeOf fSpec (fsLang fSpec) rule
+     , fromList $ meaning2Blocks (fsLang fSpec) rule
+     , if showPredExpr (getOpts fSpec)
+       then let predicate = toPredLogic rule
+            in  if format == Frtf then
+                   plain $ linebreak <> (singleton $ RawInline (Text.Pandoc.Builder.Format "rtf") (showRtf predicate)) 
+                else
+                  pandocEqnArrayWithLabel (XRefDataAnalRule rule) (showLatex predicate)
+       else if format == FLatex
+            then fromList $ pandocEquation (showMath rule)
+            else (plain . text $ l (NL "Ampersand expressie:", EN "Ampersand expression:")) <>
+                 (plain . code $ showADL (rrexp rule))
+     , plain $ singleton $ RawInline (Text.Pandoc.Builder.Format "latex") "\\bigskip" -- also causes a skip in rtf (because of non-empty plain)
+     ]
+    where format = fspecFormat (getOpts fSpec) -- todo: bit hacky to use the output format here, but otherwise we need a major refactoring
+  
+  -- shorthand for easy localizing    
+  l :: LocalizedStr -> String
+  l lstr = localize (fsLang fSpec) lstr
+     
+     -- The properties of various relations are documented in different tables.
+-- First, we document the heterogeneous properties of all relations
+-- Then, the endo-poperties are given, and finally
+-- the signals are documented.
+{-
+  daAssociations :: [Relation] -> [Block]
+  daAssociations rs = heteroMultiplicities ++ endoProperties ++ identityDocumentation ++ viewDocumentation
+   where
+    heteroMultiplicities
+     = case [r | r@Rel{}<-rs, not (isProp r), not (isAttribute r)] of
+        []  -> []
+        [r] -> [ case fsLang fSpec of
+                   Dutch   ->
+                      Para [ Str $ upCap (name fSpec)++" heeft één associatie: "++showADL r++". Deze associatie "++
+                                   case (isTot r, isSur r) of
+                                    (False, False) -> "heeft geen beperkingen ten aanzien van multipliciteit."
+                                    (True,  False) -> "is totaal."
+                                    (False, True ) -> "is surjectief."
+                                    (True,  True ) -> "is totaal en surjectief."
+                           ]
+                   English ->
+                      Para [ Str $ upCap (name fSpec)++" has one association: "++showADL r++". This association "++
+                                   case (isTot r, isSur r) of
+                                    (False, False) -> "has no restrictions with respect to multiplicities. "
+                                    (True,  False) -> "is total."
+                                    (False, True ) -> "is surjective."
+                                    (True,  True ) -> "is total and surjective."
+                           ]]
+        rs' -> case [r | r<-rs', (not.null) ([Tot,Sur] `isc` multiplicities r) ] of
+               []  -> []
+               [r] -> [ case fsLang fSpec of
+                          Dutch   ->
+                             Para [ Str $ upCap (name fSpec)++" heeft "++count Dutch (length rs) "associatie"++". "
+                                  , Str $ " Daarvan is "++showADL r++if isTot r then "totaal" else "surjectief"
+                                  ]
+                          English   ->
+                            Para [ Str $ upCap (name fSpec)++" has "++count English (length rs) "association"++". "
+                                  , Str $ " Association "++showADL r++" is "++if isTot r then "total" else "surjective"
+                                  ]
+                      ]
+               _   -> [ case fsLang fSpec of
+                          Dutch   ->
+                             Para [ Str $ upCap (name fSpec)++" heeft de volgende associaties en multipliciteitsrestricties. "
+                                  ]
+                          English   ->
+                             Para [ Str $ upCap (name fSpec)++" has the following associations and multiplicity constraints. "
+                                  ]
+                      , Table [] [AlignLeft,AlignCenter,AlignCenter] [0.0,0.0,0.0]
+                        ( case fsLang fSpec of
+                          Dutch   ->
+                               [ [Plain [Str "relatie"]]
+                               , [Plain [Str "totaal"]]
+                               , [Plain [Str "surjectief"]]]
+                          English   ->
+                               [ [Plain [Str "relation"]]
+                               , [Plain [Str "total"]]
+                               , [Plain [Str "surjective"]]]
+                        )
+                        [[[Plain [Math InlineMath (showMath r)]] -- r is a relation.
+                         ,[Plain [Math InlineMath "\\surd" | isTot r]]
+                         ,[Plain [Math InlineMath "\\surd" | isSur r]]]
+                        | r<-rs', not (isAttribute r)
+                        ]
+                      ]
+    isAttribute r = (not.null) ([Uni,Inj] `isc` multiplicities r)
+    endoProperties
+     = if null [ m | r<-hMults, m<-multiplicities r, m `elem` [Rfx,Irf,Trn,Sym,Asy]]
+       then []
+       else [ Para (case fsLang fSpec of
+                          Dutch   ->
+                            [Str "Er is één endorelatie, ", Math InlineMath (showMath d), Str " met de volgende eigenschappen: "]
+                          English   ->
+                            [Str "There is one endorelation, ", Math InlineMath (showMath d), Str " with the following properties: "] )
+            | length hMults==1, d<-hMults ]++
+            [ Para [ case fsLang fSpec of
+                          Dutch   ->
+                            Str "In aanvulling daarop hebben de endorelaties de volgende eigenschappen: "
+                          English   ->
+                            Str "Additionally, the endorelations come with the following properties: "]
+            | length hMults>1 ]++
+            [Table [] [AlignLeft,AlignCenter,AlignCenter,AlignCenter,AlignCenter,AlignCenter,AlignCenter] [0.0,0.0,0.0,0.0,0.0,0.0,0.0]
+             [[case fsLang fSpec of
+                          Dutch   -> Plain [Str "relatie"]
+                          English -> Plain [Str "relation"]  ]
+             ,[Plain [Str "Rfx"]]
+             ,[Plain [Str "Irf"]]
+             ,[Plain [Str "Trn"]]
+             ,[Plain [Str "Sym"]]
+             ,[Plain [Str "Asy"]]
+             ,[Plain [Str "Prop"]]]
+             [[[Plain [Math InlineMath (showMath d)]] -- d is a declaration, and therefore typeable. So  showMath d  exists.
+              ,[Plain [Math InlineMath "\\surd" | isRfx d ]]
+              ,[Plain [Math InlineMath "\\surd" | isIrf d ]]
+              ,[Plain [Math InlineMath "\\surd" | isTrn d ]]
+              ,[Plain [Math InlineMath "\\surd" | isSym d ]]
+              ,[Plain [Math InlineMath "\\surd" | isAsy d ]]
+              ,[Plain [Math InlineMath "\\surd" | isAsy d && isSym d ]]]
+             | d<-hMults]
+            | length hMults>0 ]
+       where
+        hMults :: [Declaration]
+        hMults  = [decl | decl@Sgn{}<- relsUsedIn fSpec, isEndo decl
+                        , null (themes fSpec) || decpat decl `elem` themes fSpec]
+    identityDocumentation
+     = case (identities fSpec, fsLang fSpec) of
+        ([], _)              -> []
+        ([k], Dutch)         -> [ Para  [Str "Er is één identiteit: ",Str (name k),Str "."]]
+        ([k], English)       -> [ Para  [Str "There is but one identity: ",Str (name k),Str "." ]]
+        (identities, Dutch)  -> [ Para $ Str "De volgende identiteiten bestaan: ": commaNLPandoc (Str "en") [Str (name i) | i<-identities]]
+        (identities, English)-> [ Para $ Str "The following identities exist: ": commaEngPandoc (Str "and") [Str (name i) | i<-identities]]
+
+    viewDocumentation
+     = case (viewDefs fSpec, fsLang fSpec) of
+        ([], _) -> []
+        ([v], Dutch)   -> [ Para  [Str "Er is één view: ",Str (name v),Str "."]]
+        ([v], English) -> [ Para  [Str "There is but one view: ",Str (name v),Str "." ]]
+        (viewds, Dutch) -> [ Para $ Str "De volgende views bestaan: ": commaNLPandoc (Str "en") [Str (name v) | v<-viewds]]
+        (viewds, English)->[ Para $ Str "The following views exist: ": commaEngPandoc (Str "and") [Str (name v) | v<-viewds]]
+
+-- The properties of various declations are documented in different tables.
+-- First, we document the heterogeneous properties of all relations
+-- Then, the endo-poperties are given, and finally
+-- the process rules are documented.
+
+  daAttributes :: PlugSQL -> [Block]
+  daAttributes p
+   = if length (plugFields p)<=1 then [] else
+     [ case fsLang fSpec of
+               Dutch   ->
+                 Para [ Str $ "De attributen van "++name p++" hebben de volgende multipliciteitsrestricties. "
+                 ]
+               English ->
+                 Para [ Str $ "The attributes in "++name p++" have the following multiplicity constraints. "
+                 ]
+     ,Table [] [AlignLeft,AlignLeft,AlignCenter,AlignCenter] [0.0,0.0,0.0,0.0]
+      ( case fsLang fSpec of
+          Dutch   ->
+             [[Plain [Str "attribuut"]]
+             ,[Plain [Str "type"]]
+             ,[Plain [Str "verplicht"]]
+             ,[Plain [Str "uniek"]]]
+          English ->
+             [[Plain [Str "attribute"]]
+             ,[Plain [Str "type"]]
+             ,[Plain [Str "mandatory"]]
+             ,[Plain [Str "unique"]]] )
+      [ if isProp (fldexpr fld) && fld/=head (plugFields p)
+        then [ [Plain [Str (fldname fld)]]
+             , [Plain [ Str "Bool"]]
+             , [Plain [Math InlineMath "\\surd"]]
+             , []
+             ]
+        else [ [Plain [if fld==head (plugFields p) || null ([Uni,Inj,Sur]>-multiplicities (fldexpr fld))
+                       then Str  "key "
+                       else Str (fldname fld)]]
+             , [Plain [ (Str . latexEscShw.name.target.fldexpr) fld]]
+             , [Plain [Math InlineMath "\\surd" | not (fldnull fld)]]
+             , [Plain [Math InlineMath "\\surd" | flduniq fld]]
+             ]
+      | fld<-plugFields p  -- tail haalt het eerste veld, zijnde I[c], eruit omdat die niet in deze tabel thuishoort.
+      ]
+
+     ]
+-- the endo-properties have already been reported in the general section of this chapter.
+
+  -- daPlugs describes data sets.
+  -- These can be recognized by:
+  --    1. the first field has the "unique" attribute on (otherwise it is a binary association)
+  --    2. there is more than one field (otherwise it is a scalar).
+  -- The text gives all rules that are maintained internally within the data structure,
+  -- because they might very well be implemented as database integrity rules.
+  -- Multiplicity rules are not reported separately, because they are already taken care of in the multiplicity tables.
+  -- Plugs that are associations between data sets and scalars are ignored.
+
+  daPlug :: Options -> PlugSQL -> [Block]
+  daPlug opts p
+   = if null content then [] else plugHeader ++ content
+     where
+       thing2block r = pandocEqnArrayOnelabel (symDefLabel r) ((showLatex.toPredLogic) r)
+       plugHeader = toList $ labeledThing opts (lev+1) ("sct:Plug "++escapeNonAlphaNum (name p)) (name p)
+       content = daAttributes p ++ plugRules ++ plugSignals ++ plugIdentities ++ iRules
+       plugRules
+        = case fsLang fSpec of
+           English -> case [r | r<-invariants fSpec, null [d | d@Sgn{} <- relsMentionedIn r, d `notElem` relsUsedIn p]] of
+                       []  -> []
+                       [r] -> [ Para [ Str "Within this data set, the following integrity rule shall be true at all times. " ]]++
+                              if showPredExpr opts
+                              then pandocEqnArrayOnelabel (symDefLabel r) ((showLatex.toPredLogic) r)
+                              else [ Para [ Math DisplayMath $ showMath r]]
+                       rs  -> [ Para [ Str "Within this data set, the following integrity rules shall be true at all times. " ]
+                              , if showPredExpr opts
+                                then BulletList [(pandocEqnArrayOnelabel (symDefLabel r) . showLatex . toPredLogic) r | r<-rs ]
+                                else BulletList [ [Para [Math DisplayMath $ showMath r]] | r<-rs ]
+                              ]
+           Dutch   -> case [r | r<-invariants fSpec, null [d | d@Sgn{} <- relsMentionedIn r, d `notElem` relsUsedIn p]] of
+                       []  -> []
+                       [r] -> [ Para [ Str "Binnen deze gegevensverzameling dient de volgende integriteitsregel te allen tijde waar te zijn. " ]]++
+                              if showPredExpr opts
+                              then pandocEqnArrayOnelabel (symDefLabel r) ((showLatex.toPredLogic) r)
+                              else [ Para [ Math DisplayMath $ showMath r]]
+                       rs  -> [ Para [ Str "Binnen deze gegevensverzameling dienen de volgende integriteitsregels te allen tijde waar te zijn. " ]
+                              , if showPredExpr opts
+                                then BulletList [(pandocEqnArrayOnelabel (symDefLabel r) . showLatex . toPredLogic) r | r<-rs ]
+                                else BulletList [ [Para [Math DisplayMath $ showMath r]] | r<-rs ]
+                              ]
+       plugIdentities
+        = case fsLang fSpec of
+           English -> case [k | k<-identityRules fSpec, null [d | d@Sgn{} <- relsMentionedIn k, d `notElem` relsUsedIn p]] of
+                       []  -> []
+                       [s] -> [ Para [ Str "This data set contains one key. " ]]++
+                              if showPredExpr opts
+                              then pandocEqnArrayOnelabel (symDefLabel s) ((showLatex.toPredLogic) s)
+                              else [ Para [ Math DisplayMath $ showMath s]]
+                       ss  -> [ Para [ Str "This data set contains the following keys. " ]
+                              , if showPredExpr opts
+                                then BulletList [(pandocEqnArrayOnelabel (symDefLabel s) . showLatex . toPredLogic) s | s<-ss ]
+                                else BulletList [ [Para [Math DisplayMath $ showMath s]]
+                                                | s<-ss ]
+                              ]
+           Dutch   -> case [k | k<-identityRules fSpec, null [d | d@Sgn{} <- relsMentionedIn k, d `notElem` relsUsedIn p]] of
+                       []  -> []
+                       [s] -> [ Para [ Str ("Deze gegevensverzameling genereert één key. ") ]]++
+                              if showPredExpr opts
+                              then pandocEqnArrayOnelabel (symDefLabel s) ((showLatex.toPredLogic) s)
+                              else [ Para [ Math DisplayMath $ showMath s]]
+                       ss  -> [ Para [ Str "Deze gegevensverzameling genereert de volgende keys. " ]
+                              , if showPredExpr opts
+                                then BulletList [(pandocEqnArrayOnelabel (symDefLabel s) . showLatex . toPredLogic) s | s<-ss ]
+                                else BulletList [ [Para [Math DisplayMath $ showMath s]] | s<-ss ]
+                              ]
+       plugSignals
+        = case (fsLang fSpec, [r | r<-vrules fSpec, isSignal r , null [d | d@Sgn{} <- relsMentionedIn r, d `notElem` relsUsedIn p]]) of
+    --       English -> case [r | r<-vrules fSpec, isSignal r , null [d | d@Sgn{} <- relsMentionedIn r, d `notElem` relsUsedIn p]] of
+            (_      , [])  -> []
+            (English, [s]) -> [ Para [ Str "This data set generates one process rule. " ]]++
+                              if showPredExpr opts
+                              then pandocEqnArrayOnelabel (symDefLabel s) ((showLatex.toPredLogic) s)
+                              else [ Para [ Math DisplayMath $ showMath s]]
+            (English, ss)  -> [  Para [ Str "This data set generates the following process rules. " ]
+                              , if showPredExpr opts
+                                then BulletList [(pandocEqnArrayOnelabel (symDefLabel s) . showLatex . toPredLogic) s | s<-ss ]
+                                else BulletList [ [Para [Math DisplayMath $ showMath s]] | s<-ss ]
+                              ]
+            (Dutch  , [s]) -> [ Para [ Str ("Deze gegevensverzameling genereert één procesregel. ") ]]++
+                              if showPredExpr opts
+                              then pandocEqnArrayOnelabel (symDefLabel s) ((showLatex.toPredLogic) s)
+                              else [ Para [ Math DisplayMath $ showMath s]]
+            (Dutch  , ss ) -> [ Para [ Str "Deze gegevensverzameling genereert de volgende procesregels. " ]
+                              , if showPredExpr opts
+                                then BulletList [(pandocEqnArrayOnelabel (symDefLabel s) . showLatex . toPredLogic) s | s<-ss ]
+                                else BulletList [ [Para [Math DisplayMath $ showMath s]] | s<-ss ]
+                              ]
+       iRules
+        = case fsLang fSpec of
+           English -> case irs of
+                       []  -> []
+                       [e] -> [ Para [ Str "The following rule defines the integrity of data within this data set. It must remain true at all times. " ]]++
+                              if showPredExpr opts
+                              then pandocEqnArrayOnelabel "" ((showLatex.toPredLogic) e)
+                              else [ Para [ Math DisplayMath $ showMath e]]
+                       es  -> [ Para [ Str "The following rules define the integrity of data within this data set. They must remain true at all times. " ]
+                              , if showPredExpr opts
+                                then BulletList [(pandocEqnArrayOnelabel "" . showLatex . toPredLogic) e | e<-es ]
+                                else BulletList [ [Para [Math DisplayMath $ showMath e]] | e<-es ]
+                              ]
+           Dutch   -> case irs of
+                       []  -> []
+                       [e] -> [ Para [ Str "De volgende regel definieert de integriteit van gegevens binnen deze gegevensverzameling. Hij moet te allen tijde blijven gelden. "]]++
+                              if showPredExpr opts
+                              then pandocEqnArrayOnelabel "" ((showLatex.toPredLogic) e)
+                              else [ Para [ Math DisplayMath $ showMath e]]
+                       es  -> [ Para [ Str "De volgende regels definiëren de integriteit van gegevens binnen deze gegevensverzameling. Zij moeten te allen tijde blijven gelden. " ]
+                              , if showPredExpr opts
+                                then BulletList [(pandocEqnArrayOnelabel "" . showLatex . toPredLogic) e | e<-es ]
+                                else BulletList [ [Para [Math DisplayMath $ showMath e]] | e<-es ]
+                              ]
+          where irs = [ dnf2expr dc
+                      | q<-vquads fSpec
+                      , r_usr (qRule q)==UserDefined, isIdent (qDcl q), source (qDcl q) `elem` pcpts
+                      , x<-qConjuncts q
+                      , dc@(Dnf [EDcD nega] _)<-rc_dnfClauses x
+                      , qDcl q==nega
+                      ]
+                pcpts = case p of
+                  ScalarSQL{} -> [cLkp p]
+                  _           -> map fst (cLkpTbl p)
+-}
+
+primExpr2pandocMath :: Lang -> Expression -> Inlines
+primExpr2pandocMath lang e =
+ case e of
+  (EDcD d ) ->
+           case lang of
+             Dutch -> text "de relatie "
+             English -> text "the relation "
+        <> math ((name.source) d++ " \\xrightarrow {"++name d++"} "++(name.target) d)
+  (EFlp (EDcD d)) ->
+           case lang of
+             Dutch -> text "de relatie "
+             English -> text "the relation "
+        <> math ((name.source) d++ " \\xleftarrow  {"++name d++"} "++(name.target) d)
+  (EIsc (r1,_)) ->
+           let srcTable = case r1 of
+                            EDcI c -> c
+                            _      -> fatal 767 ("Unexpected expression: "++show r1)
+           in
+           case lang of
+             Dutch -> text "de identiteitsrelatie van "
+             English -> text "the identityrelation of "
+        <> math (name srcTable)
+  (EDcI c) ->
+            case lang of
+             Dutch -> text "de identiteitsrelatie van "
+             English -> text "the identityrelation of "
+        <> math (name c)
+  _   -> fatal 223 ("Have a look at the generated Haskell to see what is going on..\n"++show e)

+ src/Database/Design/Ampersand/Output/ToPandoc/ChapterDiagnosis.hs view
@@ -0,0 +1,629 @@+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE OverloadedStrings #-}
+module Database.Design.Ampersand.Output.ToPandoc.ChapterDiagnosis where
+
+import Database.Design.Ampersand.Output.ToPandoc.SharedAmongChapters
+import Database.Design.Ampersand.ADL1
+import Database.Design.Ampersand.Classes
+import Database.Design.Ampersand.Output.PandocAux
+import Data.List
+import System.FilePath
+
+
+fatal :: Int -> String -> a
+fatal = fatalMsg "Output.ToPandoc.ChapterDiagnosis"
+
+chpDiagnosis :: FSpec -> (Blocks,[Picture])
+chpDiagnosis fSpec
+ = ( (chptHeader (fsLang fSpec) Diagnosis) <>
+     fromList
+     (
+     diagIntro ++             -- an introductory text
+     roleomissions ++         -- tells which role-rule, role-interface, and role-relation assignments are missing
+     roleRuleTable ++         -- gives an overview of rule-rule assignments
+     missingConceptDefs ++    -- tells which concept definitions have been declared without a purpose
+     missingRels ++           -- tells which relations have been declared without a purpose
+     unusedConceptDefs ++     -- tells which concept definitions are not used in any relation
+     relsNotUsed ++           -- tells which relations are not used in any rule
+     missingRules ++          -- tells which rule definitions are missing
+     ruleRelationRefTable ++  -- table that shows percentages of relations and rules that have references
+     invariantsInProcesses ++ --
+     processrulesInPatterns++ --
+-- TODO: Needs rework.     populationReport++       -- says which relations are populated.
+     wipReport++              -- sums up the work items (i.e. the violations of process rules)
+     toList violationReport          -- sums up the violations caused by the population of this script.
+     )
+   , pics )
+  where
+  diagIntro :: [Block]
+  diagIntro =
+    case fsLang fSpec of
+      Dutch   -> [Para
+                  [ Str "Dit hoofdstuk geeft een analyse van het Ampersand-script van ", Quoted  SingleQuote [Str (name fSpec)], Str ". "
+                  , Str "Deze analyse is bedoeld voor de auteurs van dit script. "
+                  , Str "Op basis hiervan kunnen zij het script completeren en mogelijke tekortkomingen verbeteren. "
+                  ]]
+      English -> [Para
+                  [ Str "This chapter provides an analysis of the Ampersand script of ", Quoted  SingleQuote [Str (name fSpec)], Str ". "
+                  , Str "This analysis is intended for the authors of this script. "
+                  , Str "It can be used to complete the script or to improve possible flaws. "
+                  ]]
+
+  roleRuleTable :: [Block]
+  roleRuleTable
+    | null ruls = []
+    | null (fRoles fSpec) =
+        case fsLang fSpec of
+          Dutch    -> [Para [ Str $ upCap (name fSpec)++" specificeert geen rollen. " ]]
+          English  -> [Para [ Str $ upCap (name fSpec)++" does not define any roles. " ]]
+    | null [r | r<-vrules fSpec, isSignal r ] =
+        case fsLang fSpec of
+          Dutch    -> [Para [ Str $ upCap (name fSpec)++" kent geen procesregels. " ]]
+          English  -> [Para [ Str $ upCap (name fSpec)++" does not define any process rules. " ]]
+    | otherwise =
+        (case fsLang fSpec of
+          Dutch    -> Para [ Str $ upCap (name fSpec)++" kent regels aan rollen toe. "
+                            , Str "De volgende tabel toont welke regels door een bepaalde rol kunnen worden gehandhaafd."]
+          English  -> Para [ Str $ upCap (name fSpec)++" assigns rules to roles. "
+                            , Str "The following table shows the rules that are being maintained by a given role."]
+        ) :
+        [Table []  -- the table containing the role-rule assignments
+        (AlignLeft:[AlignCenter |_<-fRoles fSpec])
+        (0.0:[0.0 |_<-fRoles fSpec])
+        (( case fsLang fSpec of
+          Dutch   -> [Plain [Str "regel"]]
+          English -> [Plain [Str "rule" ]]
+        ) :    [ [Plain [Str (name r)]] | r <- fRoles fSpec ]
+        )
+        [ [Plain [Str (name rul)]]:[f r rul | r<-fRoles fSpec] | rul<-ruls ]
+        ]
+     where
+      ruls = if null (themes fSpec)
+             then [r | r<-vrules fSpec, isSignal r ]
+             else [r | pat<-vpatterns   fSpec, name pat `elem` themes fSpec, r<-udefrules pat,         isSignal r ]                  
+      f r rul | (r,rul) `elem` maintained      = [Plain [Math InlineMath "\\surd"]]
+              | (r,rul) `elem` dead            = [Plain [Math InlineMath "\\times"]]
+              | (r,rul) `elem` fRoleRuls fSpec = [Plain [Math InlineMath "\\odot"]]
+              | otherwise                      = []
+      maintained  -- (r,rul) `elem` maintained means that r can maintain rul without restrictions.
+        = [ (role,rul)
+          | (role,rul)<-fRoleRuls fSpec
+          , and (map (mayedit role) (relsUsedIn rul))
+          ]
+      mayedit :: Role -> Declaration -> Bool
+      mayedit role decl = decl `elem` ((snd.unzip) (filter (\x -> role == fst x) (fRoleRels fSpec)))
+      dead -- (r,rul) `elem` dead means that r cannot maintain rul without restrictions.
+       = [ (role,rul)
+         | (role,rul)<-fRoleRuls fSpec
+         , (not.or) (map (mayedit role) (relsUsedIn rul))
+         ]
+
+  roleomissions :: [Block]
+  roleomissions
+   = if      null  (themes fSpec) && (not.null) (vpatterns fSpec) ||
+        (not.null) (themes fSpec) && (not.null) (themes fSpec `isc` map name (vpatterns fSpec))
+     then [ case fsLang fSpec of
+              Dutch   ->
+                Plain [ Str $ upCap (name fSpec)++" kent geen regels aan rollen toe. "
+                       , Str "Een generieke rol, User, zal worden gedefinieerd om al het werk te doen wat in het bedrijfsproces moet worden uitgevoerd."
+                       ]
+              English ->
+                Plain [ Str $ upCap (name fSpec)++" does not assign rules to roles. "
+                       , Str "A generic role, User, will be defined to do all the work that is necessary in the business process."
+                       ]
+          | (null.fRoleRuls) fSpec && (not.null.vrules) fSpec] ++
+          [ case fsLang fSpec of
+              Dutch   ->
+                Plain [ Str $ upCap (name fSpec)++" specificeert niet welke rollen de inhoud van welke relaties mogen wijzigen. "
+                       , Str ""
+                       ]
+              English ->
+                Plain [ Str $ upCap (name fSpec)++" does not specify which roles may change the contents of which relations. "
+                       , Str ""
+                       ]
+          | null (fRoleRels fSpec), (not.null.fRoleRuls) fSpec ||(not.null.fRoleRels) fSpec]
+     else []
+  missingConceptDefs :: [Block]
+  missingConceptDefs
+   = case (fsLang fSpec, missing) of
+      (Dutch,[])  -> [Para
+                       [Str "Alle concepten in dit document zijn voorzien van een bestaansreden."]
+                     | (not.null.concs) fSpec]
+      (Dutch,[c]) -> [Para
+                       [Str "De bestaansreden van concept ", Quoted SingleQuote [Str (name c)], Str " is niet gedocumenteerd."]
+                     ]
+      (Dutch,xs)  -> [Para $
+                       [Str "De bestaansreden van de concepten: "]++commaNLPandoc (Str "en") (map (Str . name) xs)++[Str " is niet gedocumenteerd."]
+                     ]
+      (English,[])  -> [Para
+                        [Str "All concepts in this document have been provided with a purpose."]
+                     | (not.null.concs) fSpec]
+      (English,[c]) -> [Para
+                         [Str "The concept ", Quoted SingleQuote [Str (name c)], Str " remains without a purpose."]
+                     ]
+      (English,xs)  -> [Para $
+                       [Str "Concepts "]++commaEngPandoc (Str "and") (map (Str . name) xs)++[Str " remain without a purpose."]
+                     ]
+   where missing = [c | c <-ccs
+                      , cd <- concDefs fSpec c
+                      , null (purposesDefinedIn fSpec (fsLang fSpec) cd)
+                   ]++
+                   [c | c <-ccs, null (concDefs fSpec c)]
+         ccs = concs [ d | d<-vrels fSpec, null (themes fSpec)||decpat d `elem` themes fSpec]  -- restrict if the documentation is partial.
+  unusedConceptDefs :: [Block]
+  unusedConceptDefs
+   = case (fsLang fSpec, unused) of
+      (Dutch,[])  -> [Para
+                       [Str "Alle concepten, die in dit document zijn voorzien van een definitie, worden gebruikt in relaties."]
+                     | (not.null.cDefsInScope) fSpec]
+      (Dutch,[c]) -> [Para
+                       [Str "Het concept ", Quoted SingleQuote [Str (name c)], Str " is gedefinieerd, maar wordt niet gebruikt."]
+                     ]
+      (Dutch,xs)  -> [Para $
+                       [Str "De concepten: "]++commaNLPandoc (Str "en") (map (Str . name) xs)++[Str " zijn gedefinieerd, maar worden niet gebruikt."]
+                     ]
+      (English,[])  -> [Para
+                        [Str "All concepts defined in this document are used in relations."]
+                     | (not.null.cDefsInScope) fSpec]
+      (English,[c]) -> [Para
+                         [Str "The concept ", Quoted SingleQuote [Str (name c)], Str " is defined, but isn't used."]
+                     ]
+      (English,xs)  -> [Para $
+                       [Str "Concepts "]++commaEngPandoc (Str "and") (map (Str . name) xs)++[Str " are defined, but not used."]
+                     ]
+   where unused = [cd | cd <-cDefsInScope fSpec, name cd `notElem` map name (allConcepts fSpec)]
+
+  missingRels :: [Block]
+  missingRels
+   = case (fsLang fSpec, missing) of
+      (Dutch,[])  -> [Para
+                       [Str "Alle relaties in dit document zijn voorzien van een reden van bestaan (purpose)."]
+                     | (not.null.relsMentionedIn.vrules) fSpec]
+      (Dutch,[r]) -> [Para
+                       [ Str "De reden waarom relatie ", r
+                       , Str " bestaat wordt niet uitgelegd."
+                     ] ]
+      (Dutch,rs)  -> [Para $
+                       [ Str "Relaties "]++commaNLPandoc (Str "en") rs++
+                       [ Str " zijn niet voorzien van een reden van bestaan (purpose), en daardoor niet opgenomen als afspraak in hoofdstuk "]++
+                       (toList $ xRefReference (getOpts fSpec) SharedLang)++
+                       [ Str "."]
+                     ] 
+      (English,[])  -> [Para
+                         [Str "All relations in this document have been provided with a purpose."]
+                       | (not.null.relsMentionedIn.vrules) fSpec]
+      (English,[r]) -> [Para
+                         [ Str "The purpose of relation ", r
+                         , Str " remains unexplained."
+                       ] ]
+      (English,rs)  -> [Para $
+                         [ Str "The purpose of relations "]++commaEngPandoc (Str "and") rs++
+                         [ Str " is not documented. Hence, they are not contained as agreement in chapter "]++
+                       (toList $ xRefReference (getOpts fSpec) SharedLang)++
+                       [ Str "."]
+                     ] 
+     where missing = [(Math InlineMath . showMath) (EDcD d)
+                     | d@Sgn{} <- relsInThemes fSpec
+                     , null (purposesDefinedIn fSpec (fsLang fSpec) d)
+                     ]
+
+  relsNotUsed :: [Block]
+  pics :: [Picture]
+  (relsNotUsed,pics)
+   = ( ( case (fsLang fSpec, notUsed) of
+          (Dutch,[])  -> [Para
+                           [Str "Alle relaties in dit document worden in één of meer regels gebruikt."]
+                         | (not.null.relsMentionedIn.vrules) fSpec]
+          (Dutch,[r]) -> [Para
+                           [ Str "De relatie ", r
+                           , Str " wordt in geen enkele regel gebruikt. "
+                         ] ]
+          (Dutch,rs)  -> [Para $
+                           [ Str "Relaties "]++commaNLPandoc (Str "en") rs++
+                           [ Str " worden niet gebruikt in regels. "
+                         ] ]
+          (English,[])  -> [Para
+                             [Str "All relations in this document are being used in one or more rules."]
+                           | (not.null.relsMentionedIn.vrules) fSpec]
+          (English,[r]) -> [Para
+                             [ Str "Relation ", r
+                             , Str " is not being used in any rule. "
+                           ] ]
+          (English,rs)  -> [Para $
+                             [ Str "Relations "]++commaEngPandoc (Str "and") rs++
+                             [ Str " are not used in any rule. "
+                           ] ] ) ++
+       toList
+       ( case (fsLang fSpec, pictsWithUnusedRels) of
+          (Dutch,[pict])   -> para ("Figuur " <> xRefReference (getOpts fSpec) pict <> " geeft een conceptueel diagram met alle relaties.") <>
+                              plain((showImage (getOpts fSpec)) pict)
+          (English,[pict]) -> para ("Figure " <> xRefReference (getOpts fSpec) pict <> " shows a conceptual diagram with all relations.") <>
+                              plain((showImage (getOpts fSpec)) pict)
+          (Dutch,picts)    -> mconcat
+                                  [ para (  "Figuur " <> xRefReference (getOpts fSpec) pict
+                                         <> " geeft een conceptueel diagram met alle relaties die gedeclareerd zijn in "
+                                         <> (singleQuoted.str.name) pat <> "."
+                                         ) <>
+                                    (plain . showImage (getOpts fSpec)) pict
+                                  | (pict,pat)<-zip picts pats ]
+          (English,picts) -> mconcat
+                                  [ para (  "Figure " <> xRefReference (getOpts fSpec) pict
+                                         <> " shows a conceptual diagram with all relations declared in "
+                                         <> (singleQuoted.str.name) pat <> "."
+                                         )<>
+                                    (plain . showImage (getOpts fSpec)) pict
+                                  | (pict,pat)<-zip picts pats ]
+       )
+       , pictsWithUnusedRels           -- draw the conceptual diagram
+     )
+     where notUsed = nub [(Math InlineMath . showMath) (EDcD d)
+                         | d@Sgn{} <- relsInThemes fSpec -- only signal relations that are used or defined in the selected themes
+                         , decusr d
+                         , d `notElem` (relsMentionedIn . vrules) fSpec
+                         ]
+           pats  = [ pat | pat<-vpatterns fSpec
+                         , null (themes fSpec) || name pat `elem` themes fSpec  -- restrict if the documentation is partial.
+                         , (not.null) (relsDefdIn pat>-relsUsedIn pat) ]
+           pictsWithUnusedRels = [makePicture fSpec (PTDeclaredInPat pat) | pat<-pats ]
+
+  missingRules :: [Block]
+  missingRules
+   = case (fsLang fSpec, missingPurp, missingMeaning) of
+      (Dutch,[],[])    -> [ Para [Str "Alle regels in dit document zijn voorzien van een uitleg."]
+                          | (length.vrules) fSpec>1]
+      (Dutch,rs,rs')   -> [Para
+                           (case rs>-rs' of
+                              []  -> []
+                              [r] -> [ Str "De bestaansreden van regel ", Emph [Str (name r)]
+                                     , Str (" op regelnummer "++getLineNr r++" van bestand "++getFileName r)
+                                     , Str " wordt niet uitgelegd. "
+                                     ]
+                              rls -> (upC . commaNLPandoc (Str "en")  )
+                                        [let nrs = [(Str . show . linenr) l | l<-cl] in
+                                         strconcat ([Str ("op regelnummer"++(if length nrs>1 then "s" else "")++" ")]++
+                                                    commaNLPandoc (Str "en") nrs++
+                                                    [Str " van bestand "]++[(Str . takeFileName . locnm . head) cl])
+                                        | cl<-eqCl locnm (map origin rls)] ++
+                                       [ Str " worden regels gedefinieerd, waarvan de bestaansreden niet wordt uitgelegd. " ]
+                            ++
+                            case rs'>-rs of
+                              []  -> []
+                              [r] -> [ Str "De betekenis van regel ", Emph [Str (name r)]
+                                     , Str (" op regelnummer "++getLineNr r++" van bestand "++getFileName r)
+                                     , Str " wordt uitgelegd in taal die door de computer is gegenereerd. "
+                                     ]
+                              rls -> (upC . commaNLPandoc (Str "en")  )
+                                        [let nrs = [(Str . show . linenr) l | l<-cl] in
+                                         strconcat ([Str ("op regelnummer"++(if length nrs>1 then "s" else "")++" ")]++
+                                                    commaNLPandoc (Str "en") nrs++
+                                                    [Str " van bestand "]++[(Str . takeFileName . locnm . head) cl])
+                                        | cl<-eqCl locnm (map origin rls)] ++
+                                       [ Str " staan regels, waarvan de betekenis wordt uitgelegd in taal die door de computer is gegenereerd. " ]
+                            ++
+                            case rs `isc` rs' of
+                              []  -> []
+                              [r] -> [ Str "Regel ", Emph [Str (name r)]
+                                     , Str (" op regelnummer "++getLineNr r++" van bestand "++getFileName r++" wordt niet uitgelegd. ")
+                                     ]
+                              rls -> (upC . commaNLPandoc (Str "en")  )
+                                        [let nrs = [(Str . show . linenr) l | l<-cl] in
+                                         strconcat ([Str ("op regelnummer"++(if length nrs>1 then "s" else "")++" ")]++
+                                                    commaNLPandoc (Str "en") nrs++
+                                                    [Str " van bestand "]++[(Str . takeFileName . locnm . head) cl])
+                                        | cl<-eqCl locnm (map origin rls)] ++
+                                       [ Str " worden regels gedefinieerd, zonder verdere uitleg. " ]
+                           )
+                          ]
+      (English,[],[])  -> [ Para [Str "All rules in this document have been provided with a meaning and a purpose."]
+                          | (length.vrules) fSpec>1]
+      (English,rs,rs') -> [Para $
+                           ( case rs>-rs' of
+                              []  -> []
+                              [r] -> [ Str "The purpose of rule ", Emph [Str (name r)]
+                                     , Str (" on line "++getLineNr r++" of file "++getFileName r)
+                                     , Str " is not documented. "
+                                     ]
+                              rls -> (upC . commaEngPandoc (Str "and") )
+                                        [let nrs = [(Str . show . linenr) l | l<-cl] in
+                                         strconcat ([ Str ("on line number"++(if length nrs>1 then "s" else "")++" ")]++
+                                                    commaEngPandoc (Str "and") nrs ++
+                                                    [Str " of file "]++[(Str . takeFileName . locnm . head) cl])
+                                        | cl<-eqCl locnm (map origin rls)] ++
+                                       [ Str " rules are defined without documenting their purpose. " ]
+                           ) ++
+                           ( case rs'>-rs of
+                              []  -> []
+                              [r] -> [ Str "The meaning of rule ", Emph [Str (name r)]
+                                     , Str (" on line "++getLineNr r++" of file "++getFileName r)
+                                     , Str " is documented by means of computer generated language. "
+                                     ]
+                              rls -> (upC . commaEngPandoc (Str "and") )
+                                        [let nrs = [(Str . show . linenr) l | l<-cl] in
+                                         strconcat ([ Str ("on line number"++(if length nrs>1 then "s" else "")++" ")]++
+                                                    commaEngPandoc (Str "and") nrs ++
+                                                    [Str " of file "]++[(Str . takeFileName . locnm . head) cl])
+                                        | cl<-eqCl locnm (map origin rls)] ++
+                                       [ Str " rules are defined, the meaning of which is documented by means of computer generated language. " ]
+                           ) ++
+                           ( case rs `isc` rs' of
+                              []  -> []
+                              [r] -> [ Str "Rule ", Emph [Str (name r)]
+                                     , Str (" on line "++getLineNr r++" of file "++getFileName r++" is not documented. ")
+                                     ]
+                              rls -> (upC . commaEngPandoc (Str "and") )
+                                        [let nrs = [(Str . show . linenr) l | l<-cl] in
+                                         strconcat ([ Str ("on line number"++(if length nrs>1 then "s" else "")++" ")]++
+                                                    commaEngPandoc (Str "and") nrs ++
+                                                    [Str " of file "]++[(Str . takeFileName . locnm . head) cl])
+                                        | cl<-eqCl locnm (map origin rls)] ++
+                                       [ Str " rules are defined without any explanation. " ]
+                           )
+                          ]
+     where missingPurp
+            = nub [ r
+                  | r<-ruls
+                  , null (purposesDefinedIn fSpec (fsLang fSpec) r)
+                  ]
+           missingMeaning
+            = nub [ r
+                  | r<-ruls
+                  , null [m | m <- ameaMrk (rrmean r), amLang m == fsLang fSpec]
+                  ]
+           ruls = if null (themes fSpec)
+                  then vrules fSpec
+                  else concat [udefrules pat | pat<-vpatterns fSpec, name pat `elem` themes fSpec]
+           upC (Str str':strs) = Str (upCap str'):strs
+           upC str' = str'
+
+           getFileName :: Traced a => a -> String
+           getFileName x = takeFileName . locnm . origin $ x 
+           
+           getLineNr :: Traced a => a -> String
+           getLineNr x = locln . origin $ x
+
+           strconcat :: [Inline] -> Inline
+           strconcat strs = (Str . concat) [ str' | Str str'<-strs]
+
+  ruleRelationRefTable =
+    [ Para [ Str descriptionStr ]
+    , Table [] (AlignLeft : replicate 6 AlignCenter) [0.0,0.0,0.0,0.0,0.0,0.0,0.0]
+            (map strCell [ themeStr, relationsStr, withRefStr, "%", rulesStr, withRefStr, "%"])
+            (map mkTableRowPat (vpatterns fSpec) ++
+            [[]] ++ -- empty row
+            [mkTableRow contextStr (filter decusr $ vrels fSpec) (vrules fSpec)])
+    ]
+    where mkTableRowPat p            = mkTableRow (name p) (ptdcs p) (ptrls p)
+          mkTableRow nm decls ruls =
+            let nrOfRels = length decls
+                nrOfRefRels = length $ filter hasRef decls
+                nrOfRules = length ruls
+                nrOfRefRules = length $ filter hasRef ruls
+            in  map strCell [ nm
+                            , show nrOfRels, show nrOfRefRels, showPercentage nrOfRels nrOfRefRels
+                            , show nrOfRules, show nrOfRefRules, showPercentage nrOfRules nrOfRefRules
+                            ]
+
+          hasRef x = maybe False (any  ((/=[]).explRefIds)) (purposeOf fSpec (fsLang fSpec) x)
+
+          showPercentage x y = if x == 0 then "-" else show (y*100 `div` x)++"%"
+
+          strCell strng = [Plain [Str strng]]
+
+          (descriptionStr, themeStr, relationsStr, withRefStr, rulesStr, contextStr) =
+            case fsLang fSpec of Dutch -> ( "Onderstaande tabel bevat per thema (dwz. proces of patroon) tellingen van het aantal relaties en regels, " ++
+                                            "gevolgd door het aantal en het percentage daarvan dat een referentie bevat. Relaties die in meerdere thema's " ++
+                                            "gedeclareerd worden, worden ook meerdere keren geteld."
+                                          , "Thema", "Relaties",  "Met referentie", "Regels", "Gehele context")
+                                 _     -> ( "The table below shows for each theme (i.e. process or pattern) the number of relations and rules, followed " ++
+                                            " by the number and percentage that have a reference. Relations declared in multiple themes are counted multiple " ++
+                                            " times."
+                                          , "Theme", "Relations", "With reference", "Rules", "Entire context")
+
+  locnm (FileLoc(FilePos(filename,_,_))) = filename
+  locnm (DBLoc str') = str'
+  locnm _ = "NO FILENAME"
+  locln (FileLoc(FilePos(_,Pos l _,_))) = show l
+  locln (DBLoc str') = str'
+  locln p = fatal 875 ("funny position "++show p++" in function 'locln'")
+
+-- TODO: give richer feedback...
+  invariantsInProcesses :: [Block]
+  invariantsInProcesses
+   = (case (fsLang fSpec, prs, procs) of
+      (_,      [],[] )  -> []
+      (Dutch,  [],[p])  -> [ Para [ Str $ "Alle regels in proces "++name p++" zijn gekoppeld aan rollen." ]]
+      (English,[],[p])  -> [ Para [ Str $ "All rules in process "++name p++" are linked to roles." ]]
+      (Dutch,  [], _ )  -> [ Para [ Str "Alle regels in alle processen zijn gekoppeld aan rollen." ]]
+      (English,[], _ )  -> [ Para [ Str "All rules in all processes are linked to roles." ]]
+      (Dutch,  _ , _ )  -> [ Para [ Str "De volgende tabel toont welke regels in welke processen niet aan een rol gekoppeld zijn. "
+                                  , Str "Dit heeft als consequentie dat de computer de betreffende regel(s) zal handhaven."
+                                  ]]
+      (English,_ , _ )  -> [ Para [ Str "The following table shows which rules are not linked to a role within a particular process. "
+                                  , Str "This has as consequence that these rule(s) will be maintained by the computer."
+                                  ]]
+     )++
+-- the table containing the role-rule assignments
+     [ Table [] [AlignLeft,AlignLeft] [0.0,0.0]
+       ( case fsLang fSpec of
+          Dutch   -> [ [Plain [Str "proces" ]] , [Plain [Str "regel"]] ]
+          English -> [ [Plain [Str "process"]] , [Plain [Str "rule" ]] ]
+       )
+       [ [[Plain [Str (name p)]], [Plain (intercalate [Str ", "] [[Str (name r)] | r<-rs])]]
+       | (p,rs)<-prs
+       ]
+     | not (null prs)]
+     where prs = [(p,rs) | p<-procs
+                          , let rs=[r | r<-invariants fSpec, name p == r_env r], not (null rs) ]
+           procs = if null (themes fSpec) then vpatterns fSpec else [prc | prc<-vpatterns fSpec, name prc `elem` themes fSpec ]
+
+  processrulesInPatterns :: [Block]
+  processrulesInPatterns = (toList $ para ("TODO: Inleiding bij de rol-regel tabel"))++
+     [ Table []
+       ([AlignLeft]++[AlignLeft | multProcs]++[AlignLeft,AlignLeft])
+       ([0.0]++[0.0 | multProcs]++[0.0,0.0])
+       ( case fsLang fSpec of
+          Dutch   ->
+              [[Plain [Str "rol"]] ]++[[Plain [Str "in proces" ]] | multProcs]++[[Plain [Str "regel"]], [Plain [Str "uit"  ]] ]
+          English ->
+              [[Plain [Str "role"]]]++[[Plain [Str "in process"]] | multProcs]++[[Plain [Str "rule" ]], [Plain [Str "from" ]] ]
+       )
+       [ [[Plain [Str (name rol)]]]++[[Plain [Str (r_env rul)]] | multProcs]++[[Plain [Str (name rul)]], [Plain [Str (r_env rul)]]]
+       | (rol,rul)<-prs
+       ]
+     | length prs>1]
+     where prs :: [( Role, Rule )]
+           prs = fRoleRuls fSpec
+           multProcs = length procs>1
+           procs = [ p | p<-vpatterns fSpec
+                   , null (themes fSpec) || name p `elem` themes fSpec]  -- restrict if this is partial documentation.
+
+
+  wipReport :: [Block]
+  wipReport
+   = [ Para (case (fsLang fSpec, concat popwork,popwork) of
+              (Dutch,  [],_)       -> [ Str "De populatie in dit script beschrijft geen onderhanden werk. "
+                                      | (not.null.initialPops) fSpec ]  -- SJ 20131212 Is dit correct? Waarom?
+              (English,[],_)       -> [ Str "The population in this script does not specify any work in progress. "
+                                      | (not.null.initialPops) fSpec ]  -- SJ 20131212 Is this correct? Why
+              (Dutch,  [(r,ps)],_) -> [ Str "Regel ", quoterule r, Str (" laat "++count Dutch   (length ps) "taak"++" zien.") ]
+              (English,[(r,ps)],_) -> [ Str "Rule ", quoterule r, Str (" shows "++count English (length ps) "task"++".") ]
+              (Dutch,  _,[_])      -> [ Str "Dit script bevat onderhanden werk. De volgende tabel bevat details met regelnummers in het oorspronkelijk script-bestand." ]
+              (English,_,[_])      -> [ Str "This script contains work in progress. The following table provides details with line numbers from the original script file." ]
+              (Dutch,  _,_)        -> [ Str "Dit script bevat onderhanden werk. De volgende tabellen geven details met regelnummers in de oorspronkelijk script-bestanden." ]
+              (English,_,_)        -> [ Str "This script contains work in progress. The following tables provide details with line numbers from the original script files." ]
+            )
+     ]        ++
+-- the following table actually belongs to the intro
+     [ Table []
+       [AlignLeft,AlignRight,AlignRight]
+       [0.0,0.0,0.0]
+       ( case fsLang fSpec of
+          Dutch   ->
+              [[Plain [Str "regel"]], [Plain $[Str ((locnm . origin . fst . head) cl++" ") |length popwork>1]++[Str "script",LineBreak,Str "regel#"]], [Plain [Str "#signalen"] ]]
+          English ->
+              [[Plain [Str "rule" ]], [Plain $[Str ((locnm . origin . fst . head) cl++" ") |length popwork>1]++[Str "line#"]], [Plain [Str "#signals"] ]]
+       )
+       [ [[Plain [Str (name r)]], [Plain [(Str . locln . origin) r]], [Plain [(Str . show . length) ps]]]
+       | (r,ps)<-cl, length ps>0
+       ]
+     | (length.concat) popwork>1, cl<-popwork ]        ++
+-- the tables containing the actual work in progress population
+     concat
+     [ [ Para ( (case fsLang fSpec of
+                  Dutch   -> Str "Regel"
+                  English -> Str "Rule"):
+                [Space,quoterule r,Space]++
+                toList(xRefTo (XRefNaturalLanguageRule r) )++
+                (case fsLang fSpec of
+                  Dutch   -> [ Str " luidt: " ]
+                  English -> [ Str " says: "  ]
+                )
+              )]  ++meaning2Blocks (fsLang fSpec) r++
+       [Plain ( case fsLang fSpec of
+                  Dutch  ->
+                     [ Str "Deze regel bevat nog werk (voor "]++
+                     commaNLPandoc (Str "of") (nub [Str (name rol) | (rol, rul)<-fRoleRuls fSpec, r==rul])++[Str ")"]++
+                     (if length ps == 1 then [Str ", te weten "]++oneviol r ps++[Str ". "] else
+                      [ Str (". De volgende tabel laat de "++(if length ps>10 then "eerste tien " else "")++"items zien die aandacht vragen.")]
+                     )
+                  English ->
+                     [ Str "This rule contains work"]++
+                     commaEngPandoc (Str "or") (nub [Str (name rol) | (rol, rul)<-fRoleRuls fSpec, r==rul])++[Str ")"]++
+                     if length ps == 1 then [Str " by "]++oneviol r ps++[Str ". "] else
+                      [ Str ("The following table shows the "++(if length ps>10 then "first ten " else "")++"items that require attention.")]
+
+              ) ]++
+       [ violtable r ps | length ps>1]
+     | (r,ps)<-concat popwork ]
+     where
+--      text r
+--       = if null expls
+--         then explains2Blocks (autoMeaning (fsLang fSpec) r)
+--         else expls
+--         where expls = [Plain (block++[Space]) | Means l econt<-rrxpl r, l==Just (fsLang fSpec) || l==Nothing, Para block<-econt]
+      quoterule r
+       = if name r==""
+         then case fsLang fSpec of
+               English -> Str ("on "++show (origin r))
+               Dutch   -> Str ("op "++show (origin r))
+         else Quoted SingleQuote [Str (name r)]
+      oneviol :: Rule -> Pairs -> [Inline]
+      oneviol r [p]
+       = if source r==target r && srcPaire p==trgPaire p
+         then [Quoted  SingleQuote [Str (name (source r)),Space,Str (srcPaire p)]]
+         else [Str "(",Str (name (source r)),Space,Str (srcPaire p),Str ", ",Str (name (target r)),Space,Str (trgPaire p),Str ")"]
+      oneviol _ _ = fatal 810 "oneviol must have a singleton list as argument."
+      popwork :: [[(Rule,Pairs)]];
+      popwork = eqCl (locnm.origin.fst) [(r,ps) | (r,ps) <- allViolations fSpec, isSignal r, partofThemes r]
+  partofThemes r =
+        or [ null (themes fSpec)
+           , r `elem` concat [udefrules pat | pat<-vpatterns fSpec, name pat `elem` themes fSpec]
+           ]
+
+  violationReport :: Blocks
+  violationReport
+   = let (processViolations,invariantViolations) = partition (isSignal.fst) (allViolations fSpec)
+         showViolatedRule :: (Rule,Pairs) -> Blocks
+         showViolatedRule (r,ps)
+             = let capt = case (fsLang fSpec,isSignal r) of
+                               (Dutch  , False) -> text "Overtredingen van regel "<>  text (name r)
+                               (English, False) -> text "Violations of rule "<>  text (name r)
+                               (Dutch  , True ) -> text "Openstaande taken voor "        <> text (commaNL  "of" (map name (nub [rol | (rol, rul)<-fRoleRuls fSpec, r==rul])))
+                               (English, True ) -> text "Tasks yet to be performed by "  <> text (commaEng "or" (map name (nub [rol | (rol, rul)<-fRoleRuls fSpec, r==rul])))
+
+                   showRow :: Paire -> [Blocks]
+                   showRow p = [(para.text.srcPaire) p,(para.text.trgPaire) p]
+               in para ( case fsLang fSpec of
+                            Dutch   -> text "Regel "
+                            English -> text "Rule "
+                         <>  text (name r)
+                       )
+               <> para (text (case (fsLang fSpec,isSignal r) of
+                               (Dutch  , False) -> "Totaal aantal overtredingen: "++show (length ps)
+                               (English, False) -> "Total number of violations: " ++show (length ps)
+                               (Dutch  , True ) -> "Totaal aantal taken: "        ++show (length ps)
+                               (English, True ) -> "Total number of work items: " ++show (length ps)
+                             )
+                       )
+               <> table capt
+                   [(AlignLeft,0)                          ,(AlignLeft,0)          ]
+                   [(para.strong.text.name.source.rrexp) r,(para.strong.text.name.target.rrexp) r]
+                   (map showRow ps)
+
+     in (para (case (fsLang fSpec, invariantViolations, processViolations) of
+                (Dutch  ,[] , [] ) -> text "De populatie in dit script overtreedt geen regels. "
+                (English,[] , [] ) -> text "The population in this script violates no rule. "
+                (Dutch  ,iVs, pVs)
+                   -> text ("De populatie in dit script overtreedt "
+                             ++show(length iVs)++" invariant"++(if length iVs == 1 then "" else "en")++" en "
+                             ++show(length pVs)++" procesregel"++if length pVs == 1 then "" else "s"++"."
+                           )
+                (English,iVs, pVs)
+                   -> text ("The population in this script violates "
+                             ++show(length iVs)++" invariant"++(if length iVs == 1 then "" else "s")++" and "
+                             ++show(length pVs)++" process rule"++if length pVs == 1 then "" else "s"++"."
+                           )
+              )
+        )
+     <> bulletList  [showViolatedRule vs | vs<- invariantViolations]
+     <> bulletList  [showViolatedRule vs | vs<- processViolations]
+
+
+  violtable :: Rule -> Pairs -> Block
+  violtable r ps
+      = if hasantecedent r && isIdent (antecedent r)  -- note: treat 'isIdent (consequent r) as binary table.
+        then Table []
+             [AlignLeft]
+             [0.0]
+             [[Plain [(Str . name . source) r]]]
+             [ [[Plain [Str (srcPaire p)]]]
+             | p <-take 10 ps
+             ]
+        else Table []
+             [AlignLeft,AlignLeft]
+             [0.0,0.0]
+             [[Plain [(Str . name . source) r]], [Plain [(Str . name . target) r] ]]
+             [ [[Plain [Str (srcPaire p)]], [Plain [Str (trgPaire p)]]]
+             | p <-take 10 ps
+             ]
+

+ src/Database/Design/Ampersand/Output/ToPandoc/ChapterECArules.hs view
@@ -0,0 +1,55 @@+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE OverloadedStrings #-}
+module Database.Design.Ampersand.Output.ToPandoc.ChapterECArules
+where
+import Database.Design.Ampersand.Output.ToPandoc.SharedAmongChapters
+import Database.Design.Ampersand.FSpec.ToFSpec.NormalForms (proofPA)
+import Database.Design.Ampersand.ADL1
+
+chpECArules :: FSpec -> Blocks
+chpECArules fSpec =
+  if genEcaDoc (getOpts fSpec)
+  then chpECArules' fSpec
+  else mempty
+
+chpECArules' :: FSpec -> Blocks
+chpECArules' fSpec
+ =   chptHeader (fsLang fSpec) EcaRules
+  <> ecaIntro
+  <> ifcECA
+ where
+  ecaIntro :: Blocks
+  ecaIntro
+   = case fsLang fSpec of
+       Dutch   -> plain "Dit hoofdstuk bevat de ECA regels."
+       English -> plain "This chapter lists the ECA rules."
+
+  ifcECA :: Blocks
+  ifcECA
+   = case fsLang fSpec of
+      Dutch   -> para ( "ECA regels:" <> linebreak
+                     <> "   tijdelijk ongedocumenteerd")
+                     <> mconcat
+                         [   (blockQuote . codeBlock . ("\n     "++) . showECA "\n     ") eca
+                          <> para ( linebreak <>
+                                    "------ Afleiding ----->"   -- Dit in- en uitschakelbaar maken
+                                  )
+                          <> (showProof (codeBlock . ("\n     "++) . showECA "\n     ") . proofPA (getOpts fSpec) . ecaAction) eca   --  voor het bewijs
+                          <> para ( linebreak <>
+                                    "<------Einde afleiding --"   -- Dit in- en uitschakelbaar maken
+                                  )
+                         | eca<-vEcas fSpec, (not.isNop.ecaAction) eca
+                         ]
+      English -> para ( "ECA rules:" <> linebreak
+                     <> "   temporarily not documented")
+                     <> mconcat
+                         [   (blockQuote . codeBlock . ("\n     "++) . showECA "\n     ") eca
+                          <> para ( linebreak <>
+                                    "------ Derivation ----->"   -- Dit in- en uitschakelbaar maken
+                                  )
+                          <> (showProof (codeBlock . ("\n     "++) . showECA "\n     ") . proofPA (getOpts fSpec) . ecaAction) eca   --  voor het bewijs
+                          <> para ( linebreak <>
+                                    "<------End Derivation --"   -- Dit in- en uitschakelbaar maken
+                                  )
+                         | eca<-vEcas fSpec, (not.isNop.ecaAction) eca
+                         ]

+ src/Database/Design/Ampersand/Output/ToPandoc/ChapterFunctionPointAnalysis.hs view
@@ -0,0 +1,67 @@+{-# LANGUAGE OverloadedStrings #-}
+module Database.Design.Ampersand.Output.ToPandoc.ChapterFunctionPointAnalysis where
+
+import Database.Design.Ampersand.Output.ToPandoc.SharedAmongChapters
+import Database.Design.Ampersand.FSpec.FPA
+
+fatal :: Int -> String -> a
+fatal = fatalMsg "Output.ToPandoc.ChapterFunctionPointAnalysis"
+
+-- TODO: add introductory and explanatory text to chapter
+-- TODO: what about KGVs?
+
+chpFunctionPointAnalysis :: FSpec -> (Blocks,[Picture])
+chpFunctionPointAnalysis fSpec
+ = ( (chptHeader (fsLang fSpec) FunctionPointAnalysis) <>
+     (fromList . concat)
+       [ introBlocks
+       , dataModelFPABlocks
+       , userTransactionFPABlocks
+       ]
+   , []) -- no pictures at the moment
+  where
+  lang = Dutch -- TODO: add English labels and use (fsLang fSpec) here
+  fpa = fpAnalyze fSpec 
+  introBlocks :: [Block]
+  introBlocks =
+    case lang of
+      Dutch   -> [Para
+                  [ Str "Dit hoofdstuk ..."
+                  ]]
+      English -> [Para
+                  [ Str "This chapter ..."
+                  ]]
+
+  dataModelFPABlocks :: [Block]
+  dataModelFPABlocks =
+    [ Table [Str "Datamodel"]
+                [AlignLeft,        AlignLeft,         AlignLeft,                             AlignLeft                     ]
+                [0.0,              0.0,               0.0,                                   0.0                           ]
+              [ [plainStr "Type"], [plainStr "Naam"], [plainStr "Complexiteit"],             [plainStr "FP"]               ] $
+            [ [ [plainStr "ILGV"], [plainStr nm],     [plainStr $ showLang lang cmplxty], [plainStr $ show $ fpVal fp ] ]
+            | fp@FP{fpType=ILGV, fpName=nm, fpComplexity=cmplxty} <- fps
+            ] ++
+            [ []
+            , [ [plainStr "Totaal"], [],              [],                                    [plainStr $ show totalFP]     ]
+            ]
+    ]
+   where (fps, totalFP) = dataModelFPA fpa
+
+  userTransactionFPABlocks :: [Block]
+  userTransactionFPABlocks =
+    [ Table [Str "Gebruikerstransacties"]
+                [AlignLeft,        AlignLeft,         AlignLeft,                             AlignLeft                     ]
+                [0.0,              0.0,               0.0,                                   0.0                           ]
+              [ [plainStr "Type"], [plainStr "Naam"], [plainStr "Complexiteit"],             [plainStr "FP"]               ] $
+            [ [ [plainStr tpStr],  [plainStr nm],     [plainStr $ showLang lang cmplxty], [plainStr $ show $ fpVal fp ] ]
+            | fp@FP{fpType=tp, fpName=nm, fpComplexity=cmplxty} <- fps
+            , let tpStr = showLang lang tp
+            ] ++
+            [ []
+            , [ [plainStr "Totaal"], [],              [],                                    [plainStr $ show totalFP]     ] 
+            ]
+    ]
+   where (fps, totalFP) = userTransactionFPA fpa
+    
+plainStr :: String -> Block
+plainStr str'  = Plain [Str str']

+ src/Database/Design/Ampersand/Output/ToPandoc/ChapterGlossary.hs view
@@ -0,0 +1,23 @@+{-# LANGUAGE ScopedTypeVariables #-}
+module Database.Design.Ampersand.Output.ToPandoc.ChapterGlossary
+  (chpGlossary)
+where
+import Database.Design.Ampersand.Output.ToPandoc.SharedAmongChapters
+import Database.Design.Ampersand.ADL1
+import Database.Design.Ampersand.Classes
+
+chpGlossary :: Int -> FSpec ->  Blocks
+chpGlossary _ fSpec
+ = fromList $
+   if fspecFormat (getOpts fSpec)==FLatex
+   then [ Para [RawInline (Format "latex") "\\printglossaries"] ]
+   else [ Table [] [AlignLeft,AlignLeft,AlignLeft] [0.0,0.0,0.0]
+          ( case fsLang fSpec of
+               Dutch   ->
+                 [ [Plain [Str "term"]] , [Plain [Str "definitie"]] , [Plain [Str "bron"]]]
+               English ->
+                 [ [Plain [Str "term"]] , [Plain [Str "definition"]], [Plain [Str "source"]]]
+          )
+          [ [ [Plain [(Str . name)  c]], [Plain [(Str . cddef) cd]], [Plain [(Str . cdref) cd]]]
+          | c<-concs fSpec, cd<-concDefs fSpec c
+          ]]

+ src/Database/Design/Ampersand/Output/ToPandoc/ChapterInterfaces.hs view
@@ -0,0 +1,216 @@+module Database.Design.Ampersand.Output.ToPandoc.ChapterInterfaces
+  ( chpInterfacesPics
+  , chpInterfacesBlocks
+  )
+where
+import Data.List
+import Database.Design.Ampersand.ADL1
+import Database.Design.Ampersand.Classes.Relational
+import Database.Design.Ampersand.FSpec.Crud
+import Database.Design.Ampersand.FSpec.FPA
+import Database.Design.Ampersand.Output.PandocAux
+import Database.Design.Ampersand.Output.ToPandoc.SharedAmongChapters
+
+fatal :: Int -> String -> a
+fatal = fatalMsg "Output.ToPandoc.ChapterInterfaces"
+
+chpInterfacesPics :: FSpec -> [Picture]
+chpInterfacesPics _ = []
+
+chpInterfacesBlocks :: Int -> FSpec -> Blocks
+chpInterfacesBlocks lev fSpec = -- lev is the header level (0 is chapter level)
+  mconcat $ map interfaceChap regularInterfaces ++ [ messagesChap messageInterfaces | not (null messageInterfaces) ]
+  where
+    messageInterfaces :: [Interface]
+    regularInterfaces :: [Interface]
+    (messageInterfaces, regularInterfaces) = partition (\i -> ifcClass i == Just "Message") $ interfaceS fSpec
+    
+    lang = Dutch -- TODO: add English labels and use (fsLang fSpec) here
+      
+    interfaceChap :: Interface -> Blocks
+    interfaceChap ifc
+     =  headerWithLabel (XRefInterfacesInterface ifc) (lev+1) (text ("Interface: " ++ quoteName ifc)) <>
+        ifcIntro ifc <>
+        docInterface ifc
+      
+    ifcIntro :: Interface -> Blocks
+    ifcIntro ifc
+     =  introBlocks <>
+        purposes2Blocks (getOpts fSpec) purps        
+       where purps = purposesDefinedIn fSpec lang ifc
+ 
+             introBlocks :: Blocks
+             introBlocks = fromList $
+               case lang of
+                 Dutch   -> [Para
+                             [ Str $ "Dit hoofdstuk bevat de documentatie voor de interface "++ quoteName ifc++"."
+                             ]]
+                 English -> [Para
+                             [ Str $ "This chapter contains the documentation for the interface "++ quoteName ifc++"."
+                             ]]
+
+    docInterface :: Interface -> Blocks
+    docInterface ifc =
+      (plainText $ "De interface is beschikbaar voor " ++ showRoles (ifcRoles ifc) ++ ".") <>
+      (if null $ ifcControls ifc
+       then plainText "Voor deze interface hoeven geen regels gecontroleerd te worden."
+       else plainText "Voorafgaand aan het afsluiten van een transactie (commit), moet aan de volgende regels voldaan zijn:" <>  
+              (bulletList . map plainText . nub) [rrnm rule | conj <- ifcControls ifc, rule <- rc_orgRules conj, r_usr rule == UserDefined]) <>
+      (if genFPAChap (getOpts fSpec)
+       then (plain . strong . text) "Functiepunten:" <>
+            plainText ("Deze interface is gerubriceerd als " ++ showLang lang (fpType interfaceFP) ++
+                       " " ++ showLang lang (fpComplexity interfaceFP) ++ 
+                       ", en is daarmee " ++ show (fpVal interfaceFP) ++ " functiepunten waard.")
+       else plainText "" -- TODO: vervangen door de Pandoc-aanduiding voor "niks"
+      ) <>
+      docCrudMatrix ifc <>
+      (plain . strong . text) "Interfacestructuur:" <>
+      docInterfaceObjects (ifcParams ifc) (ifcRoles ifc) [] (ifcObj ifc)
+      where interfaceFP = fpaInterface ifc
+
+    docInterfaceObjects :: [Declaration] -> [Role] -> [Int] -> ObjectDef -> Blocks
+    docInterfaceObjects editableRels roles hierarchy object =
+      case hierarchy of
+        [] -> plain . text $ "Interface voor een waarde van type " ++ quoteName (target iExp) ++ "."
+              -- TODO: unclear what we want to do here. Probably want to hide "ONE". Do we need to take multiplicites into account? (e.g. waarden)  
+        _  -> plain . strong . fromList $ [Str $ (intercalate "." $ map show hierarchy) ++ " " ++ objectName]
+      <> interfaceObjDoc <>
+      mconcat subInterfaceDocs
+      where objectName = let nm = name object in if null nm then "<Naamloos>" else nm
+      
+            interfaceObjDoc :: Blocks
+            interfaceObjDoc =
+              mconcat $
+                [ plainText  $ fieldDescr ++ quoteName (target iExp) ++ ". (" ++ (if isEditable then "" else "niet ") ++ "editable)"              
+                ] ++
+                
+                case navigationDocs of
+                  []               -> []
+                  navDocs@(_:rest) -> 
+                    [ plainText $ "Hiervandaan kan genavigeerd worden naar interface"++(if null rest then "" else "s")++":"] ++
+                    [ bulletList navDocs ]
+                ++
+                [ plainText $ "De bijbehorende Ampersand expressie is: ", plain . code $ showADL iExp ] ++
+                [ plainText $ fieldRef ++ " bestaat uit " ++ show (length subInterfaceDocs) ++ " deelveld"++ (if len>1 then "en" else "") ++":"
+                | let len = length subInterfaceDocs, len > 0 ] ++
+                if not $ development (getOpts fSpec) then [] else -- some debug info shown on --dev
+                  [ plainText $ "DEBUG: Props: ["++props++"]" | development (getOpts fSpec) ] ++
+                  case expressionRelM of
+                    Nothing -> []
+                    Just (_, d, _, isFlipped) -> 
+                      [ plainText $ "DEBUG: Declaration "++ name d ++ (if isFlipped then "~" else "")
+                      , plainText $ "DEBUG: showADL: " ++ showADL d
+                      ] 
+              where (fieldDescr,fieldRef) = 
+                      if isSur iExp then if isUni iExp then ("Een verplicht veld van type ", "Dit veld")
+                                                       else ("Een lijst van 1 of meer velden van type ", "Elk veld")
+                                    else if isUni iExp then ("Een optioneel veld van type ", "Dit veld")
+                                                       else ("Een lijst van 0 of meer velden van type ", "Elk veld")
+                    props = intercalate "," $ [ "INJ" | isInj iExp] ++ [ "SUR" | isSur iExp] ++ [ "TOT" | isTot iExp] ++ [ "UNI" | isUni iExp]
+                    
+                    (expressionRelM, isEditable) = case getExpressionRelation iExp of
+                                                     Just e@(_,d,_,_) -> (Just e, d `elem` editableRels)
+                                                     Nothing          -> (Nothing, False)
+                    
+                    navigationDocs = [ plainText $ quoteName navIfc ++ " (voor " ++ showRoles sharedRoles ++ ")" 
+                                     | navIfc <- regularInterfaces
+                                     , source (objctx . ifcObj $ navIfc) == target iExp
+                                     , let sharedRoles = ifcRoles navIfc `intersect` roles
+                                     , not . null $ sharedRoles
+                                     ]
+
+            iExp = conjNF (getOpts fSpec) $ objctx object
+                    
+            subInterfaceDocs = docMSubInterface editableRels roles hierarchy (objmsub object)
+
+    docMSubInterface :: [Declaration] -> [Role] -> [Int] -> Maybe SubInterface -> [Blocks]
+    docMSubInterface editableRels roles hierarchy subIfc =
+      case subIfc of
+        Nothing                -> []
+        Just (InterfaceRef nm) -> [ plainText $ "REF "++nm ] -- TODO: handle InterfaceRef
+        Just (Box _ _ objects) -> [ docInterfaceObjects editableRels roles (hierarchy ++[i]) obj | (obj,i) <- zip objects [1..] ]
+
+    docCrudMatrix :: Interface -> Blocks
+    docCrudMatrix ifc = mconcat
+      [ plain . strong . text $ "CRUD matrix:"
+      , simpleTable [ plainText "Concept", plainText "C", plainText "R", plainText "U", plainText "D" ] $
+          [ [plainText $ name cncpt, checkMark isC, checkMark isR, checkMark isU, checkMark isD ]
+          | (cncpt, isC, isR, isU, isD) <- getCrudObjectsForInterface (crudInfo fSpec) ifc
+          ]
+      ]
+      where checkMark isChecked = if isChecked then plain $ fromList [Math InlineMath "\\surd"] else mempty
+    
+    -- shorthand for easy localizing    
+    l :: LocalizedStr -> String
+    l lstr = localize (fsLang fSpec) lstr
+
+    messagesChap :: [Interface] -> Blocks
+    messagesChap ifcs = mconcat
+      [ header (lev+1) (text $ l (NL "Berichten", EN "Messages"))
+      , para . text $ l ( NL "Dit hoofdstuk geeft een overzicht van alle berichten."
+                        , EN "This chapter lists all messages." )
+      , simpleTable [ plainText $ l (NL "Eigenschap term (TODO: naam ok?)", EN "Property term"), plainText $ l (NL "Card.", EN "Card.")
+                    , plainText $ l (NL "Expressie", EN "Expression"), plainText $ l (NL "Definitie", EN "Definition") ] $
+          intercalate [[]] . map mkTableRows $ genEntity_Interfaces fSpec ifcs
+      ]
+      
+    mkTableRows :: Entity -> [[Blocks]]
+    mkTableRows (Entity nm dpth xpr card df _ props) = 
+      [plain $ (fromList $ replicate (dpth*3) nbsp) <> (if dpth == 0 then strong else id) (text nm) , plainText card, plainText xpr, plainText df]
+      : concatMap mkTableRows props
+      where nbsp :: Inline
+            nbsp = RawInline (Format "latex") "~"
+
+-- TODO: copied from prototype GenBericht.hs, if that module is kept, we should move this to a shared module.  
+data Entity = Entity { entName ::     String
+                     , depth ::       Int
+                     , expr ::        String
+                     , cardinality :: String
+                     , definition ::  String
+                     , refType ::     String
+                     , properties ::  [Entity]
+                     } deriving Show
+
+genEntity_Interfaces :: FSpec -> [Interface] -> [Entity]
+genEntity_Interfaces fSpec interfaces = map genEntity_Interface interfaces
+  where 
+    genEntity_Interface ::Interface -> Entity
+    genEntity_Interface interface = genEntity_ObjDef 0 (ifcObj interface)
+     where
+       genEntity_ObjDef :: Int -> ObjectDef -> Entity
+       genEntity_ObjDef dpth objDef =
+           Entity { entName = name objDef
+                  , depth = dpth
+                  , expr = showADL $ objctx objDef
+                  , cardinality = card $ objctx objDef
+                  , definition  = defn $ objctx objDef
+                  , refType     = name (target $ objctx objDef)
+                  , properties  =
+                      case objmsub objDef of
+                        Nothing -> []
+                        Just (Box _ _ objs)    -> map (genEntity_ObjDef (dpth+1)) objs
+                        Just (InterfaceRef nm) -> map (genEntity_ObjDef (dpth+1)) $ objsForInterfaceNamed nm
+                  }
+        where card e = (if isTot e then "1" else "0")++".."++(if isUni e then "1" else "*")
+  
+              defn rel = case concDefs fSpec (target rel) of
+                            Cd {cddef=def'} : _ | def' /= "" -> def'
+                            _                                -> "** NO DEFINITION **"
+
+              objsForInterfaceNamed :: String -> [ObjectDef]
+              objsForInterfaceNamed nm =
+                case objmsub $ ifcObj $ getInterfaceByName (interfaceS fSpec) nm of
+                  Just (Box _ _ objs) -> objs
+                  _                   -> fatal 81 "Bericht interfaces have wrong format"
+
+-- TODO: Maybe we should create a more general version of this function (might already exist, but I couldn't find it)
+showRoles :: [Role] -> String
+showRoles roles = case roles of
+                    [] -> "alle rollen"
+                    [rl] -> "de rol " ++ quoteName rl
+                    [rl1,rl2] -> "de rollen " ++ quoteName rl1 ++ " en " ++ quoteName rl2
+                    (rl1:rls) -> "de rollen " ++ quoteName rl1 ++ 
+                                 (concat . reverse $ zipWith (++) (", en ": repeat ", ") $ reverse $ map quoteName rls)
+
+quoteName :: Named a => a -> String
+quoteName x = "``"++name x++"''"

+ src/Database/Design/Ampersand/Output/ToPandoc/ChapterIntroduction.hs view
@@ -0,0 +1,148 @@+{-# LANGUAGE ScopedTypeVariables #-}
+module Database.Design.Ampersand.Output.ToPandoc.ChapterIntroduction
+where
+import Database.Design.Ampersand.Output.ToPandoc.SharedAmongChapters
+import Data.Time.Format
+
+chpIntroduction :: FSpec -> Blocks
+chpIntroduction fSpec =
+      chptHeader (fsLang fSpec) Intro
+   <> fromList purposesOfContext  -- the motivation(s) of this context
+   <> readingGuide                -- tells what can be expected in this document.
+  where
+    readingGuide
+      = case fsLang fSpec of
+          Dutch
+            -> para ( text "Dit document"
+                   <> (note.para.text) ("Dit document is gegenereerd op "++date++" om "++time++", dmv. "++ampersandVersionStr++".")
+                   <> text " definieert de functionaliteit van een informatiesysteem genaamd "
+                   <> (singleQuoted.text.name) fSpec
+                   <> text ". "
+                   <> text "Het definieert de database en de business-services van " <> (text.name) fSpec <> text " door middel van bedrijfsregels"
+                   <> (note.para.text) "Het ontwerpen met bedrijfsregels is een kenmerk van de Ampersand aanpak, die gebruikt is bij het samenstellen van dit document. "
+                   <> text ". "
+                   <> (if SharedLang `elem` chaptersInDoc (getOpts fSpec)
+                       then ( if canXRefer (getOpts fSpec)
+                              then text "Deze afspraken staan opgesomd in hoofdstuk "
+                                <> xRefReference (getOpts fSpec) SharedLang
+                              else text "Deze afspraken staan opgesomd in het hoofdstuk genaamd "
+                                <> (doubleQuoted.chptTitle (fsLang fSpec)) SharedLang
+                            ) <> text ", geordend op thema. "
+                       else text "Deze afspraken zijn niet opgenomen in dit document."
+                      )
+                    )
+            <> if Diagnosis `elem` chaptersInDoc (getOpts fSpec)
+               then para ((if canXRefer (getOpts fSpec)
+                           then text "De diagnose in hoofdstuk "
+                             <> xRefReference (getOpts fSpec) Diagnosis
+                           else text "De diagnose in het hoofdstuk genaamd"
+                             <> (doubleQuoted.chptTitle (fsLang fSpec)) Diagnosis
+                          ) <> text " is bedoeld voor de auteurs om gebreken uit hun Ampersand model op te sporen. "
+                         )
+               else mempty
+            <> if ConceptualAnalysis `elem` chaptersInDoc (getOpts fSpec)
+               then para ( ( if canXRefer (getOpts fSpec)
+                             then text "De conceptuele analyse in hoofdstuk "
+                               <> xRefReference (getOpts fSpec) ConceptualAnalysis
+                             else text "De conceptuele analyse in het hoofdstuk genaamd"
+                               <> (doubleQuoted.chptTitle (fsLang fSpec)) ConceptualAnalysis
+                           ) <> text " is bedoeld voor requirements engineers en architecten om de gemaakte afspraken"
+                             <> text " te valideren en te formaliseren. "
+                             <> text "Tevens is het bedoeld voor testers om eenduidige testgevallen te kunnen bepalen. "
+                             <> text "De formalisatie in dit hoofdstuk maakt consistentie van de functionele specificatie bewijsbaar. "
+                             <> text "Ook garandeert het een eenduidige interpretatie van de afspraken."
+                         )
+               else mempty
+            <> if DataAnalysis `elem` chaptersInDoc (getOpts fSpec)
+               then para ( text "De hoofdstukken die dan volgen zijn bedoeld voor de bouwers van "
+                        <> (singleQuoted.text.name) fSpec
+                        <> text ". "
+                        <> ( if canXRefer (getOpts fSpec)
+                             then text "De gegevensanalyse in hoofdstuk "
+                               <> xRefReference (getOpts fSpec) DataAnalysis
+                             else text "De gegevensanalyse in het hoofdstuk genaamd"
+                               <> (doubleQuoted.chptTitle (fsLang fSpec)) DataAnalysis
+                           )
+                        <> text " beschrijft de gegevensverzamelingen waarop "
+                        <> (singleQuoted.text.name) fSpec
+                        <> text " wordt gebouwd. "
+                        <> text "Elk volgend hoofdstuk definieert één business service. "
+                        <> text "Hierdoor kunnen bouwers zich concentreren op één service tegelijk. "
+                         )
+                 <> para ( text "Tezamen ondersteunen deze services alle geldende afspraken. "
+                        <> text "Door alle functionaliteit uitsluitend via deze services te ontsluiten waarborgt "
+                        <> (singleQuoted.text.name) fSpec
+                        <> text " compliance ten aanzien van alle gestelde afspraken. "
+                         )
+               else mempty
+
+          English
+            -> para ( text "This document"
+                   <> (note.para.text) ("This document was generated at "++date++" on "++time++", using "++ampersandVersionStr++".")
+                   <> text " defines the functionality of an information system called "
+                   <> (singleQuoted.text.name) fSpec
+                   <> text ". "
+                   <> text "It defines the database and the business services of " <> (text.name) fSpec <> text " by means of business rules"
+                   <> (note.para.text) "Rule based design characterizes the Ampersand approach, which has been used to produce this document. "
+                   <> text ". "
+                   <> (if SharedLang `elem` chaptersInDoc (getOpts fSpec)
+                       then ( if canXRefer (getOpts fSpec)
+                              then text "Those rules are listed in chapter "
+                                <> xRefReference (getOpts fSpec) SharedLang
+                                <> text ", ordered by theme. "
+                              else text "Those rules are listed in the chapter named "
+                                <> (doubleQuoted.chptTitle (fsLang fSpec)) SharedLang
+                            ) <> text ", ordered by theme. "
+                       else text "Those rules are not included in this document."
+                      )
+                    )
+             <> if Diagnosis `elem` chaptersInDoc (getOpts fSpec)
+               then para ((if canXRefer (getOpts fSpec)
+                           then text "The diagnosis in chapter "
+                             <> xRefReference (getOpts fSpec) Diagnosis
+                           else text "The diagnosis in the chapter named "
+                             <> (doubleQuoted.chptTitle (fsLang fSpec)) Diagnosis
+                          ) <> text " is meant to help the authors identify shortcomings in their Ampersand script."
+                         )
+               else mempty
+            <> if ConceptualAnalysis `elem` chaptersInDoc (getOpts fSpec)
+               then para ( ( if canXRefer (getOpts fSpec)
+                             then text "The conceptual analysis in chapter "
+                               <> xRefReference (getOpts fSpec) ConceptualAnalysis
+                             else text "The conceptual analysis in the chapter named "
+                               <> (doubleQuoted.chptTitle (fsLang fSpec)) ConceptualAnalysis
+                           ) <> text " is meant for requirements engineers and architects to validate and formalize the requirements. "
+                             <> text "It is also meant for testers to come up with correct test cases. "
+                             <> text "The formalization in this chapter makes consistency of the functional specification provable. "
+                             <> text "It also yields an unambiguous interpretation of all requirements."
+                         )
+               else mempty
+            <> if DataAnalysis `elem` chaptersInDoc (getOpts fSpec)
+               then para ( text "Chapters that follow have the builders of "
+                        <> (singleQuoted.text.name) fSpec
+                        <> text " as their intended audience. "
+                        <> ( if canXRefer (getOpts fSpec)
+                             then text "The data analysis in chapter "
+                               <> xRefReference (getOpts fSpec) DataAnalysis
+                             else text "The data analysis in the chapter named "
+                               <> (doubleQuoted.chptTitle (fsLang fSpec)) DataAnalysis
+                           )
+                        <> text " describes the data sets upon which "
+                        <> (singleQuoted.text.name) fSpec
+                        <> text " is built. "
+                        <> text "Each subsequent chapter defines one business service. "
+                        <> text "This allows builders to focus on a single service at a time. "
+                         )
+                 <> para ( text "Together, these services fulfill all commitments. "
+                        <> text "By disclosing all functionality exclusively through these services, "
+                        <> (singleQuoted.text.name) fSpec
+                        <> text " ensures compliance to all rules agreed upon."
+                         )
+               else mempty
+
+    date = formatTime (lclForLang (fsLang fSpec)) "%-d-%-m-%Y" (genTime (getOpts fSpec))
+    time = formatTime (lclForLang (fsLang fSpec)) "%H:%M:%S" (genTime (getOpts fSpec))
+
+    purposesOfContext = concat [amPandoc (explMarkup p) | p<-purposesDefinedIn fSpec (fsLang fSpec) fSpec]
+
+ 
+ src/Database/Design/Ampersand/Output/ToPandoc/ChapterNatLangReqs.hs view
@@ -0,0 +1,478 @@+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE OverloadedStrings #-}
+module Database.Design.Ampersand.Output.ToPandoc.ChapterNatLangReqs where
+
+import Data.Char hiding (Space)
+import Data.List
+import Data.List.Split
+import GHC.Exts (sortWith)
+import Data.Maybe
+import Database.Design.Ampersand.Basics
+import Database.Design.Ampersand.Output.ToPandoc.SharedAmongChapters hiding (sortWith)
+import Database.Design.Ampersand.ADL1
+import Database.Design.Ampersand.Classes
+import Database.Design.Ampersand.Output.PandocAux
+import Text.Pandoc.Builder
+
+fatal :: Int -> String -> a
+fatal = fatalMsg "Output.ToPandoc.ChapterNatLangReqs"
+
+{- TODO: This module needs to be rewritten from scratch. Instead of deciding on the fly what should be included,
+         a datastructure needs to be added to the fSpec, which contains per theme the concepts, rules and relations
+         that need to be printed.
+-}
+chpNatLangReqs :: Int -> FSpec -> Blocks
+chpNatLangReqs lev fSpec =
+      --  *** Header ***
+   chptHeader (fsLang fSpec) SharedLang
+   <> --  *** Intro  ***
+    case fsLang fSpec of
+        Dutch   -> para
+                     (  "Dit hoofdstuk beschrijft een natuurlijke taal, waarin functionele eisen ten behoeve van "
+                     <> (singleQuoted.str.name) fSpec
+                     <> " kunnen worden besproken en uitgedrukt. "
+                     <> "Hiermee wordt beoogd dat verschillende belanghebbenden hun afspraken op dezelfde manier begrijpen. "
+                     <> "De taal van "
+                     <> (singleQuoted. str. name) fSpec
+                     <> " bestaat uit begrippen en basiszinnen, "
+                     <> "waarin afspraken worden uitgedrukt. "
+                     <> "Wanneer alle belanghebbenden afspreken dat zij deze basiszinnen gebruiken, "
+                     <> "althans voor zover het "
+                     <> (singleQuoted. str. name) fSpec
+                     <> " betreft, "
+                     <> "delen zij precies voldoende taal om afspraken op dezelfde manier te begrijpen. "
+                     <> "Alle definities zijn genummerd omwille van de traceerbaarheid. "
+                     )
+        English -> para
+                     (  "This chapter defines the natural language, in which functional requirements of "
+                     <> (singleQuoted.str.name) fSpec
+                     <> " can be discussed and expressed. "
+                     <> "The purpose of this chapter is to create shared understanding among stakeholders. "
+                     <> "The language of "
+                     <> (singleQuoted.str.name) fSpec
+                     <> " consists of concepts and basic sentences. "
+                     <> "All functional requirements are expressed in these terms. "
+                     <> "When stakeholders can agree upon this language, "
+                     <> "at least within the scope of "
+                     <> (singleQuoted.str.name) fSpec
+                     <> ", they share precisely enough language to have meaningful discussions about functional requirements. "
+                     <> "All definitions have been numbered for the sake of traceability. "
+                     )
+   <> --  *** Requirements ***
+   fromList dpRequirementsOld
+--   dpRequirementesNew
+   <> --  *** Legal Refs ***
+     if genLegalRefs (getOpts fSpec) then legalRefs else mempty
+
+  where
+  legalRefs :: Blocks
+  legalRefs = (header (lev+2) sectionTitle)
+            <> table caption'
+                     [(AlignLeft,1/4),(AlignLeft,3/4)]
+                     [plain lawHeader, plain articleHeader]  --headers
+                     [ [(para.str.aOlLaw) art  , (para.str.unscanRef.aOlArt) art]
+                     | art <-(sort.nub.concatMap getArticlesOfLaw.getRefs) fSpec  ]
+
+         where (sectionTitle, lawHeader, articleHeader, caption') =
+                 case fsLang fSpec of
+                   Dutch   -> ("Referentietabel", "Wet", "Artikel", "Referentietabel van de wetsartikelen")
+                   English -> ("Reference table", "Law", "Article", "Reference table of articles of law")
+               getRefs ::FSpec ->  [LawRef]
+               getRefs f = concatMap catMaybes ((map (map toLawRef).map explRefIds.explanations) f)
+
+  --TODO: Deze nieuwe functie moet de oude dpRequirementsOld vervangen, waardoor een effectieve scheiding 
+  --wordt gerealiseerd van WAT er wordt afgedrukt en de VOLGORDE van afdrukken. (code disabled until it will be used, to prevent warning) 
+  {-
+  dpRequirementesNew :: Blocks
+  dpRequirementesNew =  let (_,blocks) = foldl printTheme (newCounter,mempty)  (orderingByTheme fSpec)
+                        in blocks
+    where
+     printTheme :: (Counter,Blocks)
+                -> ( Maybe Theme   -- A theme is about either a pattern or a process.
+                   , [Rule]        -- The rules of that theme
+                   , [Declaration] -- The relations that are used in a rule of this theme, but not in any rule of a previous theme.
+                   , [A_Concept]   -- The concepts that are used in a rule of this theme, but not in any rule of a previous theme.
+                   ) -> (Counter,Blocks)
+     printTheme (counter,bs) themeStuff  =
+        let (blocks,count') = printOneTheme themeStuff counter
+        in (count',bs <> blocks)
+  -}
+
+  dpRequirementsOld :: [Block]
+  dpRequirementsOld = theBlocks
+    where
+      (theBlocks,_) = 
+        printThemes toBeProcessedStuff newCounter
+           [pat | pat<-vpatterns fSpec, null (themes fSpec) || name pat `elem` themes fSpec ]
+      toBeProcessedStuff = ( conceptsWith
+                           , allRelsThatMustBeShown
+                           , [r | r<-vrules fSpec, r_usr r == UserDefined] )  -- All user declared rules
+         where
+           conceptsWith     -- All concepts that have at least one non-empty definition (must be the first)
+              = [ c
+                | c@PlainConcept{} <- concs fSpec
+                , (not.null) (concDefs fSpec c)
+                ]
+           allRelsThatMustBeShown -- All relations declared in this specification that have at least one user-defined purpose.
+              = [ d | d <- vrels fSpec
+                , decusr d
+                , not . null $ purposesDefinedIn fSpec (fsLang fSpec) d
+                ]
+
+      printThemes :: (   [A_Concept]     -- all concepts that have one or more definitions or purposes. These are to be used into this section and the sections to come
+                       , [Declaration]           -- all relations to be processed into this section and the sections to come
+                       , [Rule])                 -- all rules to be processed into this section and the sections to come
+                    -> Counter           -- unique definition counters
+                    -> [Pattern]         -- the patterns that must be processed into this specification
+                    -> ([Block],Counter) -- The blocks that define the resulting document and the last used unique definition number
+      printThemes  (still2doCPre, still2doRelsPre, still2doRulesPre) iPre allThemes
+           = case allThemes of
+              []  -> if null still2doCPre && null still2doRelsPre && null still2doRelsPre
+                     then ([],iPre)
+                     else let (a,b) = printOneTheme (Nothing, still2doRulesPre, still2doRelsPre, still2doCPre) iPre
+                          in (toList a,b)
+              _   -> (toList blocksOfOneTheme ++ blocksOfThemes,iPost)
+         where
+           (thm:thms) = allThemes
+           (blocksOfOneTheme,iPostFirst) = printOneTheme  thisThemeStuff iPre
+           (blocksOfThemes,iPost)        = printThemes stuff2PrintLater iPostFirst thms
+           thisThemeStuff    = (Just thm, [r | r<-thisThemeRules, r_usr r == UserDefined], thisThemeRels, thisThemeCs)
+           thisThemeRules    = [r | r<-still2doRulesPre, r_env r == name thm ]      -- only user defined rules, because generated rules are documented in whatever caused the generation of that rule.
+           rules2PrintLater  = still2doRulesPre >- thisThemeRules
+           thisThemeRels     = [ d | d <- still2doRelsPre
+                               , decpat d == name thm ||         -- all relations declared in this theme, combined
+                                 d `eleM` relsMentionedIn thisThemeRules] -- all relations used in this theme's rules
+           rels2PrintLater   = [x | x <-still2doRelsPre, (not.or) [ x==y | y <- thisThemeRels ]]
+           thisThemeCs       = [c | c <- still2doCPre, c `eleM` (concs thisThemeRules ++ concs thisThemeRels)] -- relations are rules ('Eis') too
+           concs2PrintLater  = still2doCPre >- thisThemeCs
+           stuff2PrintLater  = (concs2PrintLater, rels2PrintLater, rules2PrintLater)
+
+      -- | printOneTheme tells the story in natural language of a single theme.
+      -- For this purpose, Ampersand authors should take care in composing explanations.
+      -- Each explanation should state the purpose (and nothing else).
+  printOneTheme :: ( Maybe Pattern    -- The theme to process (if any)
+                   , [Rule]         -- Rules to print in this section
+                   , [Declaration]  -- Relations to print in this section
+                   , [A_Concept]    -- Concepts, to print in this section
+                   )
+                -> Counter      -- first free number to use for numbered items
+                -> (Blocks,Counter)-- the resulting blocks and first free number after processing of the theme.
+  printOneTheme (mTheme, rules2print, rels2print, concs2print) counter0
+    = case (mTheme, themes fSpec) of
+       (Nothing, _:_)
+          -> ( mempty, counter0 )         -- The document is partial (because themes have been defined), so we don't print loose ends.
+       _  -> ( (  --  *** Header of the theme: ***
+                 headerWithLabel (XRefNaturalLanguageTheme mTheme) (lev+2)
+                                 (case (mTheme,fsLang fSpec) of
+                                     (Nothing, Dutch  ) -> "Losse eindjes..."
+                                     (Nothing, English) -> "Loose ends..."
+                                     _                  -> text themeName
+                                 )
+
+               <> --  *** Purpose of the theme: ***
+                  case mTheme of
+                      Nothing  -> case fsLang fSpec of
+                                     Dutch   -> para $
+                                                    "Deze paragraaf beschrijft de relaties en concepten die "
+                                                 <> "niet in voorgaande secties zijn beschreven."
+                                     English -> para $
+                                                    "This paragraph shows remaining fact types and concepts "
+                                                 <> "that have not been described in previous paragraphs."
+                      Just pat -> purposes2Blocks (getOpts fSpec) (purposesDefinedIn fSpec (fsLang fSpec) pat)
+                <> --  *** Introduction text of the theme: ***
+                   printIntro (filter isDefined concs2print)
+                <> fromList reqdefs
+                )
+             , Counter (getEisnr counter0 + length reqs)
+             )
+           where
+              isDefined :: A_Concept -> Bool
+              isDefined = not.null.concDefs fSpec
+              -- the concepts for which one of the relations of this theme contains a source or target definition
+              -- (these will be printed, regardless whether the concept was printed before)
+
+              -- sort the requirements by file position
+              reqs = sortWith fst [ ((i,filenm org, linenr org,colnr org), bs)
+                                  | (i,org,bs)<- addIndex 0 (printConcepts concs2print) ++
+                                                 addIndex 2 (printRels rels2print) ++ addIndex 3 (printRules rules2print)]
+               where addIndex i ps = [ (i::Int,fs, sn) | (fs,sn) <- ps ] -- add an index to sort first on category (concept, rel, ..)
+
+              -- make blocks for requirements
+              reqblocks = [(pos,req (Counter cnt)) | (cnt,(pos,req))<-zip [(getEisnr counter0)..] reqs]
+              reqdefs = concatMap snd reqblocks
+
+              themeName = case mTheme of
+                           Nothing  -> ""
+                           Just pat -> name pat
+                           
+-- The following paragraph produces an introduction of one theme (i.e. pattern or process).
+              printIntro :: [A_Concept] -> Blocks
+              printIntro [] = mempty
+              printIntro ccds
+                = case fsLang fSpec of
+                      Dutch   -> (case ([(emph.str.unCap) cname | cname<-map name ccds]
+                                       , length [p |p <- (vpatterns fSpec) , name p == themeName]
+                                       ) of
+                                    ([] ,_) -> mempty
+                                    ([_],1) -> case mTheme of
+                                                 Nothing  -> mempty
+                                                 Just tme -> para ( "In het volgende wordt de taal geïntroduceerd ten behoeve van "
+                                                                 <> (str.name) tme <> "."
+                                                                  )
+                                    (cs ,1) -> para ( "Nu volgen definities van de concepten "
+                                                   <> commaNLPandoc' ("en") cs <> ".")
+                                    ([c],_) -> para ( "Deze sectie introduceert het concept " <>  c )
+                                    (cs ,_) -> para ( "Deze sectie introduceert de concepten " <>
+                                                          commaNLPandoc' "en" cs <> ". ")
+                                 ) <>
+                                 (let cs = [(c,cds) | (c)<-ccds, let cds = concDefs fSpec c,length cds>1] in
+                                   case (cs, length cs==length ccds) of
+                                    ([]       ,   _  ) -> mempty
+                                    ([(c,_)]  , False) -> para ("Eén daarvan, " <> (str.name) c <>", heeft meerdere definities. ")
+                                    (_        , False) -> para ("Daarvan hebben "<>commaNLPandoc' "en" (map (str. name . fst) cs)<> " meerdere definities. ")
+                                    ([(_,cds)], True ) -> para ("Deze heeft "<>str(count Dutch (length cds) "definitie")<>". ")
+                                    (_        , True ) -> para ("Elk daarvan heeft meerdere definities. ")
+                                 )
+
+                      English -> (case ([(emph.str.unCap) cname | cname<-map name ccds]
+                                       , length [p |p <- vpatterns fSpec, name p == themeName]
+                                       ) of
+                                    ([] ,_) -> mempty
+                                    ([_],1) -> case mTheme of
+                                                 Nothing  -> mempty
+                                                 Just tme -> para ( "The sequel introduces the language of "
+                                                                 <> (str.name) tme <> "."
+                                                                  )
+                                    (cs ,1) -> para ( "At this point, the definitions of "
+                                                   <> commaEngPandoc' "and" cs <>" are given.")
+                                    ([c],_) -> para ("This section introduces concept " <> c )
+                                    (cs ,_) -> para ("This section introduces concepts " <>
+                                                       commaEngPandoc' "and" cs <> ". ")
+                                 )<>
+                                 (let cs = [(c,cds) | c <- ccds, let cds = concDefs fSpec c, length cds>1] in
+                                   case (cs, length cs==length ccds) of
+                                    ([]       ,   _  ) -> mempty
+                                    ([(c,_)]  , False) -> para ("One of these concepts, " <> (str.name) c <>", has multiple definitions. ")
+                                    (_        , False) -> para ("Of those concepts "<>commaEngPandoc' "and" (map (str. name . fst) cs)<> " have multiple definitions. ")
+                                    ([(_,cds)], True ) -> para ("It has "<>str(count English (length cds) "definition")<>". ")
+                                    (_        , True ) -> para ("Each one has several definitions. ")
+                                 )
+
+              -- | the origin of c is the origin of the head of uniquecds c
+              --   after sorting by origin the counter will be applied
+              printConcepts :: [A_Concept] -> [(Origin, Counter -> [Block])]
+              printConcepts cs = map printConcept cs
+              printConcept :: A_Concept -> (Origin, Counter -> [Block])
+              printConcept c = (case uniquecds fSpec c of
+                                  []      -> OriginUnknown
+                                  (_,x):_ -> origin x
+                               , cptBlock c
+                               )
+              -- | make a block for a concept with all its purposes and definitions
+              cptBlock :: A_Concept -> Counter -> [Block]
+              cptBlock cpt cnt = concat [amPandoc (explMarkup e) | e<-exps]
+                  ++ zipWith (cdBlock cpt)
+                       (if length (uniquecds fSpec cpt) == 1 then [(cnt, "")] else
+                          [(cnt, '.' : show i) | i <- [(1 :: Int) ..]])
+                       (uniquecds fSpec cpt)
+                  where exps = case purposeOf fSpec (fsLang fSpec) cpt of
+                                 Nothing -> []
+                                 Just ps -> ps
+              -- | make a block for a concept definition
+              cdBlock :: A_Concept -> (Counter,String) -> (String,ConceptDef) -> Block
+              cdBlock cpt (cnt,xcnt) tup 
+               = DefinitionList [( toList (definitionListItemLabel (XRefNaturalLanguageConcept cpt)
+                                            ((case fsLang fSpec of
+                                                 Dutch   -> "Definitie "
+                                                 English -> "Definition "
+                                             ) ++ show (getEisnr cnt)++xcnt++":"
+                                          ) )
+                                   
+                                 , [toList $ makeDefinition (getOpts fSpec) tup] 
+                                 )
+                                ]
+
+              makeDefinition :: Options -> (String,ConceptDef) -> Blocks
+              makeDefinition opts (nm,cd) =
+                 para
+                   ( rawInline "latex"
+                               ("\\newglossaryentry{"++escapeNonAlphaNum nm ++"}\n"++
+                                "     { name={"++latexEscShw nm ++"}\n"++
+                                "     , description={"++latexEscShw (cddef cd)++"}}\n") <>
+                     
+                     case fspecFormat opts of
+                       FLatex ->   rawInline "latex" (insertAfterFirstWord refStr defStr)
+                                <> if null ref then mempty
+                                   else rawInline "latex" (latexEscShw (" ["++ref++"]"))
+                       _      ->   str (cddef cd) 
+                                <> if null ref then mempty
+                                   else str (" ["++ref++"]") 
+                   )
+                 
+               where refStr = "\\marge{\\gls{"++escapeNonAlphaNum nm++"}}"
+                     defStr = latexEscShw (cddef cd)
+                     ref = cdref cd
+                     -- by putting the ref after the first word of the definition, it aligns nicely with the definition
+                     insertAfterFirstWord s wordsStr = let (fstWord, rest) = break (==' ') wordsStr
+                                                       in  fstWord ++ s ++ rest
+
+
+
+              -- | sctds prints the requirements related to relations that are introduced in this theme.
+              printRels :: [Declaration] -> [(Origin, Counter -> [Block])]
+              printRels = map (\dcl -> (origin dcl, printRel dcl))
+              printRel :: Declaration -> Counter -> [Block]
+              printRel dcl cnt
+               = Plain [RawInline (Text.Pandoc.Builder.Format "latex") "\\bigskip"] :
+                 toList (purposes2Blocks (getOpts fSpec) purps)
+                 ++
+                 [ DefinitionList [(  (toList (definitionListItemLabel (XRefNaturalLanguageDeclaration dcl)
+                                                  ((case fsLang fSpec of
+                                                        Dutch   -> "Afspraak "
+                                                        English -> "Agreement "
+                                                   )++show(getEisnr cnt)
+                                                    ++if development (getOpts fSpec) && name dcl/="" 
+                                                      then (" ("++name dcl++")") 
+                                                      else ""
+                                                  )
+                                              )
+                                      )
+                                   , [ meaning2Blocks (fsLang fSpec) dcl]
+                                   )
+                                  ] 
+                 ]++
+                 ( case (fsLang fSpec, length samplePop) of
+                        (_      , 0) -> []
+                        (Dutch  , 1) -> [Para [Str "Een frase die hiermee gemaakt kan worden is bijvoorbeeld:"]]
+                        (English, 1) -> [Para [Str "A phrase that can be formed is for instance:"]]
+                        (Dutch  , _) -> [Para [Str "Frasen die hiermee gemaakt kunnen worden zijn bijvoorbeeld:"]]
+                        (English, _) -> [Para [Str "Phrases that can be made are for instance:"]]
+                 ) ++
+                 sampleSentences
+                 where purps     = purposesDefinedIn fSpec (fsLang fSpec) dcl
+                       samplePop = (take 3 . fullContents (vgens fSpec) (initialPops fSpec) . EDcD) dcl
+                       sampleSentences =
+                         [ Para $ mkSentence (development (getOpts fSpec)) dcl srcViewAtom tgtViewAtom
+                         | p <-samplePop
+                         , let srcViewAtom = showViewAtom fSpec (Just dcl) (source dcl) (srcPaire p)
+                         , let tgtViewAtom = showViewAtom fSpec Nothing (target dcl) (trgPaire p)
+                         ] ++
+                         (if null samplePop then [] else [Plain [RawInline (Text.Pandoc.Builder.Format "latex") "\\medskip"]])
+
+              printRules :: [Rule] -> [(Origin,Counter -> [Block])]
+              printRules = map (\rul -> (origin rul, printRule rul))
+
+  printRule :: Rule -> Counter -> [Block]
+  printRule rul cnt
+   =  Plain [RawInline (Text.Pandoc.Builder.Format "latex") "\\bigskip"] :
+      toList (purposes2Blocks (getOpts fSpec) purps)
+      ++
+      [ DefinitionList [(toList (definitionListItemLabel (XRefNaturalLanguageRule rul)
+                                  ((case fsLang fSpec of
+                                        Dutch   -> "Afspraak "
+                                        English -> "Agreement "
+                                   )++show(getEisnr cnt)
+                                    ++if development (getOpts fSpec) && name rul/="" 
+                                      then (" ("++name rul++")")
+                                      else ""
+                               )  )
+                        , [ meaning2Blocks (fsLang fSpec) rul]
+                        ) 
+                       ]
+      | not (null$meaning2Blocks (fsLang fSpec) rul)]
+   where purps = purposesDefinedIn fSpec (fsLang fSpec) rul
+
+  mkSentence :: Bool -> Declaration -> String -> String -> [Inline]
+  mkSentence isDev decl srcAtom tgtAtom
+   = case decl of
+       Sgn{} | null (prL++prM++prR)
+                  -> [str' (upCap srcAtom), Space] ++ devShow (source decl) ++ [Str "corresponds",Space,Str "to",Space,str' tgtAtom, Space] ++ devShow (target decl) ++[Str "in",Space,Str "relation",Space,str' (name decl),Str "."]
+             | otherwise
+                  -> leftHalf prL ++ rightHalf
+                    where prL = decprL decl
+                          prM = decprM decl
+                          prR = decprR decl
+                          leftHalf ""    = devShow (source decl)
+                          leftHalf prLft = [str' (upCap prLft), Space] ++ devShow (source decl)
+                          rightHalf = [str' srcAtom,Space,str' prM, Space] ++ devShow (target decl) ++ [str' tgtAtom]++(if null prR then [] else [Space,str' prR]) ++ [str' "."]
+
+       Isn{}     -> devShow (source decl) ++ [str' (upCap srcAtom),Space,Str "equals",Space,str' tgtAtom,Str "."]
+       Vs{}      -> [Str "True"]
+   where str' = if fspecFormat (getOpts fSpec)==FLatex then RawInline (Text.Pandoc.Builder.Format "latex") . latexEscShw else Str
+         devShow c | isDev     = [Str "(", str' $ name c, Str ") "] -- only show the concept when --dev option is given
+                   | otherwise = []
+
+-- TODO: fix showing/not showing based on relation
+-- TODO: what about relations in the target view?
+-- TODO: move these to some auxiliaries or utils
+showViewAtom :: FSpec -> Maybe Declaration -> A_Concept -> String -> String
+showViewAtom fSpec mDec cncpt atom =
+  case mapMaybe (getView fSpec) (cncpt : largerConcepts (vgens fSpec) cncpt) of
+    []    -> atom
+    view:_ -> case mDec of
+              Nothing -> concatMap showViewSegment (vdats view)
+              Just md -> if (not.null) [() | ViewExp objDef <- vdats view, EDcD d<-[objctx objDef], d==md]
+                         then atom
+                         else concatMap showViewSegment (vdats view)
+             -- if we are showing one of the view relations, don't expand the view
+     where showViewSegment (ViewText str') = str'
+           showViewSegment (ViewHtml str') = str'
+           showViewSegment (ViewExp objDef) =
+             case [ trgPaire p | p <- fullContents (vgens fSpec) (initialPops fSpec) (objctx objDef), atom == srcPaire p ] of
+               []         -> ""
+               viewAtom:_ -> viewAtom
+        -- justViewRels = map (Just . objctx) [objDef | ViewExp objDef <- vdats view]
+
+{-
+getIdentity :: FSpec -> A_Concept -> Maybe IdentityDef
+getIdentity fSpec cncpt =
+  case filter ((== cncpt) .  idCpt) (vIndices fSpec) of
+    []         -> Nothing
+    identity:_ -> Just identity
+-}
+
+getView :: FSpec -> A_Concept -> Maybe ViewDef
+getView fSpec cncpt =
+  case filter ((== cncpt) .  vdcpt) (vviews fSpec) of
+    []       -> Nothing
+    viewDef:_ -> Just viewDef
+
+data LawRef = LawRef { lawRef :: String}
+data ArticleOfLaw = ArticleOfLaw { aOlLaw :: String
+                                 , aOlArt :: [Either String Int]
+                                 } deriving Eq
+toLawRef:: String -> Maybe LawRef
+toLawRef s = case s of
+              [] -> Nothing
+              _  -> (Just . LawRef) s
+getLaw :: ArticleOfLaw -> Inlines
+getLaw x = (str.aOlLaw) x
+
+-- the article is everything but the law (and we also drop any trailing commas)
+getArticlesOfLaw :: LawRef -> [ArticleOfLaw]
+getArticlesOfLaw ref = map buildLA  ((splitOn ", ".unwords.init.words.lawRef) ref)
+   where
+     buildLA art = ArticleOfLaw ((last.words.lawRef) ref) (scanRef art)
+       where
+    -- group string in number and text sequences, so "Art 12" appears after "Art 2" when sorting (unlike in normal lexicographic string sort)
+         scanRef :: String -> [Either String Int]
+         scanRef "" = []
+         scanRef str'@(c:_) | isDigit c = scanRefInt str'
+                            | otherwise = scanRefTxt str'
+         scanRefTxt "" = []
+         scanRefTxt str' = let (txt, rest) = break isDigit str'
+                           in  Left txt : scanRefInt rest
+
+         scanRefInt "" = []
+         scanRefInt str' = let (digits, rest) = break (not . isDigit) str'
+                           in  Right (read digits) : scanRefTxt rest
+
+instance Ord ArticleOfLaw where
+ compare a b =
+   case compare (aOlLaw a) (aOlLaw b) of
+     EQ   -> compare (aOlArt a) (aOlArt b)
+     ord' -> ord'
+
+unscanRef :: [Either String Int] -> String
+unscanRef scannedRef = concat $ map (either id show) scannedRef
+             
+ src/Database/Design/Ampersand/Output/ToPandoc/ChapterProcessAnalysis.hs view
@@ -0,0 +1,141 @@+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE OverloadedStrings #-}
+module Database.Design.Ampersand.Output.ToPandoc.ChapterProcessAnalysis
+where
+import Database.Design.Ampersand.Output.ToPandoc.SharedAmongChapters
+import Database.Design.Ampersand.Classes
+import Data.List
+import Database.Design.Ampersand.Output.PandocAux
+
+--DESCR -> the process analysis contains a section for each process in the fSpec
+-- If an Ampersand script contains no reference to any role whatsoever, a process analysis is meaningless.
+-- In that case it will not be printed. To detect whether this is the case, we can look whether the
+-- mayEdit attributes remain empty.
+noProcesses :: FSpec -> Bool
+noProcesses fSpec = null (fRoles fSpec)
+
+chpProcessAnalysis :: Int -> FSpec -> (Blocks,[Picture])
+chpProcessAnalysis lev fSpec
+ = ( if null procs
+     then mempty
+     else headerBlocks <> roleRuleBlocks <> fromList roleRelationBlocks <> processSections
+   , pictures)
+ where
+  pictures = [] -- Disabled the pictures, because they are not helpful. (They look like a big ball of Mud)  (map picProcessModel procs)
+  procs = if null (themes fSpec)
+          then vpatterns fSpec
+          else [ p | p<-vpatterns fSpec, name p `elem` themes fSpec ]
+  processSections :: Blocks
+  processSections = mconcat (procSections procs)
+
+  headerBlocks :: Blocks
+  headerBlocks
+   = (chptHeader (fsLang fSpec) ProcessAnalysis) <>
+     purposes2Blocks (getOpts fSpec) purps <> -- This explains the purpose of this context.
+     fromList(
+     [ case fsLang fSpec of
+         Dutch   ->
+            Plain [ Str $ upCap (name fSpec)++" benoemt geen enkele rol. "
+                  , Str "Een generieke rol, User, zal worden gedefinieerd om al het werk te doen wat in het bedrijfsproces moet worden uitgevoerd."
+                  ]
+         English ->
+            Plain [ Str $ upCap (name fSpec)++" does not mention any role. "
+                  , Str "A generic role, User, will be defined to do all the work that is necessary in the business process."
+                  ]
+     | null (fRoles fSpec)] ++
+     [ case fsLang fSpec of
+         Dutch   ->
+            Plain [ Str $ upCap (name fSpec)++" specificeert niet welke rollen de inhoud van welke relaties mogen wijzigen. "
+                  , Str ""
+                  ]
+         English ->
+            Plain [ Str $ upCap (name fSpec)++" does not specify which roles may change the contents of which relations. "
+                  , Str ""
+                  ]
+     | null (fRoleRels fSpec)])
+     where purps = purposesDefinedIn fSpec (fsLang fSpec) fSpec
+
+  roleRuleBlocks :: Blocks
+  roleRuleBlocks
+   = if null (fRoleRuls fSpec) && (not.null.vrules) fSpec then mempty else
+      (case fsLang fSpec of
+          Dutch   ->
+            para ( (str.upCap.name) fSpec <> " kent regels aan rollen toe. "
+                 <> "De volgende tabel toont de regels die door een bepaalde rol worden gehandhaafd."
+                 )
+          English ->
+            para ( (str.upCap.name) fSpec <> " assigns rules to roles. "
+                 <> "The following table shows the rules that are being maintained by a given role."
+                 )
+-- the table containing the role-rule assignments
+     )<>
+     fromList
+     [ Para  $ [ RawInline (Format "latex") "\\begin{tabular}{|l|l|}\\hline\n"
+               , case fsLang fSpec of
+                  Dutch   -> RawInline (Format "latex") "Rol&Regel\\\\ \\hline\n"
+                  English -> RawInline (Format "latex") "Role&Rule\\\\ \\hline\n"
+               ]++
+               [ RawInline (Format "latex") $ intercalate "\\\\ \\hline\n   "
+                       [ latexEscShw (name role)++" & "++latexEscShw (name r)++
+                         concat[ "\\\\\n   &"++latexEscShw  (name rul) | rul<-map snd (tail rrClass)]
+                       | rrClass<-eqCl fst (fRoleRuls fSpec)
+                       , let role=fst (head rrClass), let r=snd (head rrClass)
+                       ]
+               ]++
+               [ RawInline (Format "latex") "\\\\ \\hline\n\\end{tabular}"
+               ]
+     ]
+
+-- the table containing the role-relation assignments
+  roleRelationBlocks :: [Block]
+  roleRelationBlocks
+   = if null (fRoleRels fSpec) then [] else
+     [ case fsLang fSpec of
+          Dutch   ->
+            Para [ Str $ upCap (name fSpec)++" kent rollen aan relaties toe. "
+                 , Str "De volgende tabel toont de relaties waarvan de inhoud gewijzigd kan worden door iemand die een bepaalde rol vervult."
+                 ]
+          English ->
+            Para [ Str $ upCap (name fSpec)++" assigns roles to relations. "
+                 , Str "The following table shows the relations, the content of which can be altered by anyone who fulfills a given role."
+                 ]
+     , Para  $ [ RawInline (Format "latex") "\\begin{tabular}{|l|l|}\\hline\n"
+               , RawInline (Format "latex")
+                    (case  fsLang fSpec of
+                       Dutch   -> "Rol&Relatie\\\\ \\hline\n"
+                       English -> "Role&Relation\\\\ \\hline\n")
+               ]++
+               [ RawInline (Format "latex") $ intercalate "\\\\ \\hline\n   "
+                       [ name role++" & $"++showMath r++"$"++
+                         concat[ "\\\\\n   &$"++showMath (snd rs)++"$" | rs<-tail rrClass]
+                       | rrClass<-eqCl fst (fRoleRels fSpec)
+                       , let role=fst (head rrClass), let r=snd (head rrClass)
+                       ]
+               ]++
+               [ RawInline (Format "latex") "\\\\ \\hline\n" | not (null rolelessRels)]++
+               [ RawInline (Format "latex") $ intercalate "\\\\\n   " [ "&$"++showMath d++"$" | d<-rolelessRels] | not (null rolelessRels)]++
+               [ RawInline (Format "latex") "\\\\ \\hline\n\\end{tabular}"
+               ]
+     ]
+     where
+      rolelessRels = [ d | d<-vrels fSpec, d `notElem` (nub.map snd) (fRoleRels fSpec) ]
+
+-- the sections in which processes are analyzed
+  procSections :: [Pattern] -> [Blocks]
+  procSections fprocs = iterat [fp |fp<-fprocs, (not.null.udefrules) fp] 1 declaredConcepts  declaredRelations
+   where
+    declaredRelations = (concatMap relsDefdIn.vpatterns) fSpec
+    declaredConcepts  = (concs.vpatterns) fSpec
+    iterat :: [Pattern] -> Int -> [A_Concept] -> [Declaration] -> [Blocks]
+    iterat [] _ _ _ = mempty
+    iterat (fproc:fps) i seenConcepts seenDeclarations
+     = (
+           headerWithLabel (XRefProcessAnalysis fproc) (lev+2) (text(name fproc))
+        <> (purposes2Blocks (getOpts fSpec) (purposesDefinedIn fSpec (fsLang fSpec) fproc))
+   --    <> (txtProcessModel fproc)
+        <> (if null sctRules then mempty else definitionList sctRules)
+         ):  iterat fps i' seenCrs seenDrs
+       where
+         sctRules :: [(Inlines, [Blocks])]
+         (sctRules,i',seenCrs,seenDrs) = dpRule' fSpec(udefrules fproc) i seenConcepts seenDeclarations
+

+ src/Database/Design/Ampersand/Output/ToPandoc/ChapterSoftwareMetrics.hs view
@@ -0,0 +1,72 @@+{-# LANGUAGE ScopedTypeVariables #-}
+module Database.Design.Ampersand.Output.ToPandoc.ChapterSoftwareMetrics
+where
+import Database.Design.Ampersand.Output.ToPandoc.SharedAmongChapters
+--import Database.Design.Ampersand.Output.Statistics (Statistics(..))
+--import Database.Design.Ampersand.Output.PandocAux
+
+------------------ Function Point Analysis --------------------
+-- TODO: Engels en Nederlands netjes scheiden.
+-- TODO: Andere formaten dan LaTeX ondersteunen.
+
+fpAnalysis :: FSpec -> Blocks
+fpAnalysis _ = mempty -- if null (themes fSpec) then header ++ caIntro ++ fpa2Blocks else []
+ where
+--  header :: Blocks
+--  header = chptHeader (fsLang fSpec) SoftwareMetrics
+--  caIntro :: [Block]
+--  caIntro =
+--   case fsLang fSpec of
+--      Dutch   -> [Para
+--                  [ Str "De specificatie van "
+--                  , Quoted  SingleQuote [Str (name fSpec)]
+--                  , Str " is geanalyseerd door middel van een functiepuntentelling"
+--                  , xrefCitation "IFPUG"
+--                  , Str ". "
+--                  , Str $ "Dit heeft geresulteerd in een geschat totaal van "++(show.nFpoints) fSpec++" functiepunten."
+--                  ]]
+--      English -> [Para
+--                  [ Str "The specification of "
+--                  , Quoted  SingleQuote [Str (name fSpec)]
+--                  , Str " has been analysed by counting function points"
+--                  , xrefCitation "IFPUG"
+--                  , Str ". "
+--                  , Str $ "This has resulted in an estimated total of "++(show.nFpoints) fSpec++" function points."
+--                  ]]
+--
+--
+--  fpa2Blocks' :: [Block]
+--  fpa2Blocks' = []
+--   = [ Table [] [AlignLeft,AlignLeft,AlignRight] [0.0,0.0,0.0]
+--             ( case fsLang fSpec of
+--                 Dutch   -> [ [Plain [Str "gegevensverzameling"]]
+--                            , [Plain [Str "analyse"]]
+--                            , [Plain [Str "FP"]]]
+--                 English -> [ [Plain [Str "data set"]]
+--                            , [Plain [Str "analysis"]]
+--                            , [Plain [Str "FP"]]]
+--             )
+--             [ [ [Plain [(Str . name)                 plug]]
+--               , [Plain [(Str . show . fpa)           plug]]
+--               , [Plain [(Str . show . fPoints . fpa) plug]]
+--               ]
+--             | plug<-plugInfos fSpec, fPoints (fpa plug)>0
+--             ]
+--     , Table [] [AlignLeft,AlignLeft,AlignRight] [0.0,0.0,0.0]
+--             ( case fsLang fSpec of
+--                Dutch   ->
+--                    [ [Plain [Str "interface"]]
+--                    , [Plain [Str "analyse"]]
+--                    , [Plain [Str "FP"]]]
+--                English ->
+--                    [ [Plain [Str "interface"]]
+--                    , [Plain [Str "analysis"]]
+--                    , [Plain [Str "FP"]]]
+--             )
+--             [ [ [Plain [(Str . name)                    act]]
+--               , [Plain [(Str . show . actFPA)           act]]
+--               , [Plain [(Str . show . fPoints . actFPA) act]]]
+--             | act<-fActivities fSpec
+--             ]
+--     ]
+

+ src/Database/Design/Ampersand/Output/ToPandoc/SharedAmongChapters.hs view
@@ -0,0 +1,407 @@+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE OverloadedStrings #-}
+module Database.Design.Ampersand.Output.ToPandoc.SharedAmongChapters
+    ( module Text.Pandoc
+    , module Text.Pandoc.Builder
+    , bulletList -- (is redefined in this module, but belongs in Text.Pandoc.Builder.)
+    , math --
+    , module Data.Monoid
+    , module Database.Design.Ampersand.Basics
+    , module Database.Design.Ampersand.FSpec
+    , module Database.Design.Ampersand.Misc
+    , module Database.Design.Ampersand.Core.AbstractSyntaxTree
+    , Chapter(..)
+    , chaptersInDoc
+    , chptHeader
+    , chptTitle
+    , Xreferencable(..)
+    , showImage
+    , canXRefer
+    , Purpose(..)
+    , purposes2Blocks
+    , isMissing
+    , lclForLang
+    , dpRule'
+    , relsInThemes
+    , Counter(..),newCounter,incEis
+    , inlineIntercalate
+    , orderingByTheme
+    , plainText
+    , NLString(..)
+    , ENString(..)
+    , LocalizedStr
+    , localize
+    )
+where
+import Database.Design.Ampersand.Basics
+import Database.Design.Ampersand.Core.AbstractSyntaxTree hiding (Meta)
+import Database.Design.Ampersand.ADL1
+import Database.Design.Ampersand.Classes
+import Database.Design.Ampersand.FSpec
+import Text.Pandoc
+import Text.Pandoc.Builder hiding (bulletList,math)
+import qualified Text.Pandoc.Builder as  BuggyBuilder
+import Database.Design.Ampersand.Output.PredLogic        (PredLogicShow(..), showLatex)
+import Database.Design.Ampersand.Misc
+import Database.Design.Ampersand.Output.PandocAux
+import Data.List             (intercalate,partition)
+import Data.Monoid
+import System.Locale
+
+fatal :: Int -> String -> a
+fatal = fatalMsg "Output.ToPandoc.SharedAmongChapters"
+
+data Chapter = Intro
+             | SharedLang
+             | Diagnosis
+             | ConceptualAnalysis
+             | ProcessAnalysis
+             | DataAnalysis
+             | SoftwareMetrics
+             | EcaRules
+             | Interfaces
+             | FunctionPointAnalysis
+             | Glossary
+             deriving (Eq, Show)
+
+-- | Define the order of the chapters in the document.
+chaptersInDoc :: Options -> [Chapter]
+chaptersInDoc opts = [chp | chp<-chapters, chp `notElem` disabled]
+ where
+   -- temporarily switch off chapters that need too much refactoring, but keep this Haskell code compilable.
+    disabled = []
+    chapters
+     | test opts                  = [Interfaces]
+     | diagnosisOnly opts         = [Diagnosis]
+     | theme opts == StudentTheme = [Intro,SharedLang,Diagnosis,ConceptualAnalysis,DataAnalysis]
+     | otherwise                   = [ Intro
+                                     , SharedLang
+                                     , Diagnosis
+                                     , ConceptualAnalysis
+                                     , ProcessAnalysis
+                                     , DataAnalysis
+                                     , SoftwareMetrics
+                                     , EcaRules
+                                     , Interfaces
+                                     ] ++
+                                     [ FunctionPointAnalysis | genFPAChap opts ] ++
+                                     [ Glossary
+                                     ]
+
+-- | This function returns a header of a chapter
+chptHeader :: Lang -> Chapter -> Blocks
+chptHeader lang chap
+ = header 1 (chptTitle lang chap ) <> (para (xrefLabel chap))
+
+chptTitle :: Lang -> Chapter -> Inlines
+chptTitle lang cpt =
+     (case (cpt,lang) of
+        (Intro                 , Dutch  ) -> text "Inleiding"
+        (Intro                 , English) -> text "Introduction"
+        (SharedLang            , Dutch  ) -> text "Gemeenschappelijke taal"
+        (SharedLang            , English) -> text "Shared Language"
+        (Diagnosis             , Dutch  ) -> text "Diagnose"
+        (Diagnosis             , English) -> text "Diagnosis"
+        (ConceptualAnalysis    , Dutch  ) -> text "Conceptuele Analyse"
+        (ConceptualAnalysis    , English) -> text "Conceptual Analysis"
+        (ProcessAnalysis       , Dutch  ) -> text "Procesanalyse"
+        (ProcessAnalysis       , English) -> text "Process Analysis"
+        (DataAnalysis          , Dutch  ) -> text "Gegevensstructuur"
+        (DataAnalysis          , English) -> text "Data structure"
+        (SoftwareMetrics       , Dutch  ) -> text "Functiepunt Analyse"
+        (SoftwareMetrics       , English) -> text "Function Point Analysis"
+        (EcaRules              , Dutch  ) -> text "ECA regels"
+        (EcaRules              , English) -> text "ECA rules (Flash points)"
+        (Interfaces            , Dutch  ) -> text "Koppelvlakken"
+        (Interfaces            , English) -> text "Interfaces"
+        (FunctionPointAnalysis , Dutch  ) -> text "Functiepuntanalyse"
+        (FunctionPointAnalysis , English) -> text "Function point analysis"
+        (Glossary              , Dutch  ) -> text "Begrippen"
+        (Glossary              , English) -> text "Glossary"
+     )
+
+class Xreferencable a where
+  xLabel :: a  -> String
+--  xrefReference :: a  -> Inline   --Depreciated! TODO: use xRefReference instead
+--  xrefReference a = fatal 117 $ "--Depreciated! TODO: use xRefReference instead"
+  xRefReference :: Options -> a -> Inlines
+  xRefReference opts a
+    | canXRefer opts = rawInline "latex" ("\\ref{"++xLabel a++"}")
+    | otherwise       = mempty -- "fatal 89 xreferencing is not supported!"
+  xrefLabel :: a -> Inlines
+  xrefLabel a = rawInline "latex" ("\\label{"++xLabel a++"}")
+
+canXRefer :: Options -> Bool
+canXRefer opts = fspecFormat opts `elem` [FLatex]
+
+instance Xreferencable Chapter where
+  xLabel a = "chapter" ++ escapeNonAlphaNum (show a)
+
+instance Xreferencable Picture where
+  xLabel a = "figure" ++ escapeNonAlphaNum (caption a)
+
+--Image [Inline] Target
+--      alt.text (URL,title)
+showImage :: Options -> Picture -> Inlines
+showImage opts pict =
+      case fspecFormat opts of
+         FLatex  -> rawInline "latex" ("\\begin{figure}[htb]\n\\begin{center}\n\\scalebox{"++scale pict++"}["++scale pict++"]{")
+         _       -> mempty
+   <> image (imagePath opts pict) (xLabel pict) (text $ "Here, "++caption pict++" should have been visible" )
+   <> case fspecFormat opts of
+         FLatex  -> rawInline "latex" "}\n"
+                  <>rawInline "latex" ("\\caption{"++latexEscShw (caption pict)++"}\n")
+         _       -> mempty
+   <> (xrefLabel pict)
+   <> case fspecFormat opts of
+         FLatex  -> rawInline "latex" "\n\\end{center}\n\\end{figure}"
+         _       -> mempty
+
+-- | This function orders the content to print by theme. It returns a list of
+--   tripples by theme. The last tripple might not have a theme, but will contain everything
+--   that isn't handled in a specific theme.
+orderingByTheme :: FSpec -> [( Maybe Pattern   -- A theme is about either a pattern or a process.
+                            , [Rule]        -- The rules of that theme
+                            , [Declaration] -- The relations that are used in a rule of this theme, but not in any rule of a previous theme.
+                            , [A_Concept]   -- The concepts that are used in a rule of this theme, but not in any rule of a previous theme.
+                            )
+                           ]
+orderingByTheme fSpec
+ = f (fallRules fSpec) (filter isUserDefined (relsMentionedIn fSpec)) (allConcepts fSpec) tms
+ where
+  isUserDefined d = case d of
+                       Sgn{} -> decusr d
+                       _     -> False
+  -- | The patterns that should be taken into account for this ordering
+  tms = if null (themes fSpec)
+        then (vpatterns fSpec)
+        else [ pat           | pat <-vpatterns   fSpec, name pat  `elem` themes fSpec ]
+  f ruls rels cpts ts
+   = case ts of
+       t:ts' -> let ( (rulsOfTheme,rulsNotOfTheme)
+                     , (relsOfTheme,relsNotOfTheme)
+                     , (cptsOfTheme,cptsNotOfTheme)
+                     ) = partitionByTheme t ruls rels cpts
+                in (Just t, rulsOfTheme, relsOfTheme, cptsOfTheme)
+                   : f rulsNotOfTheme relsNotOfTheme cptsNotOfTheme ts'
+       []    -> [(Nothing, ruls, rels, cpts)]
+  -- | This function takes care of partitioning each of the
+  --   lists in a pair of lists of elements which do and do not belong
+  --   to the theme, respectively
+  partitionByTheme :: Pattern
+                   -> [Rule]
+                   -> [Declaration]
+                   -> [A_Concept]
+                   -> ( ([Rule],[Rule])
+                      , ([Declaration],[Declaration])
+                      , ([A_Concept],[A_Concept])
+                      )
+  partitionByTheme pat ruls rels cpts
+      = ((rulsOfTheme,rulsNotOfTheme), (relsOfTheme,relsNotOfTheme), (cptsOfTheme,cptsNotOfTheme))
+     where
+       (rulsOfTheme,rulsNotOfTheme) = partition isRulOfTheme ruls
+       isRulOfTheme r = r `elem` ptrls pat
+       (relsOfTheme,relsNotOfTheme) = partition isRelOfTheme rels
+       isRelOfTheme r = r `elem` (concatMap relsUsedIn rulsOfTheme)
+       (cptsOfTheme,cptsNotOfTheme) = partition isCptOfTheme cpts
+       isCptOfTheme c = c `elem` concatMap concs relsOfTheme
+
+--GMI: What's the meaning of the Int?
+dpRule' :: FSpec -> [Rule] -> Int -> [A_Concept] -> [Declaration]
+          -> ([(Inlines, [Blocks])], Int, [A_Concept], [Declaration])
+dpRule' fSpec = dpR
+ where
+   l lstr = text $ localize (fsLang fSpec) lstr
+   dpR [] n seenConcs seenDeclarations = ([], n, seenConcs, seenDeclarations)
+   dpR (r:rs) n seenConcs seenDeclarations
+     = ( ( str (name r)
+         , [theBlocks]
+          ): dpNext
+       , n'
+       , seenCs
+       , seenDs
+       )
+       where
+        theBlocks :: Blocks
+        theBlocks =
+         (  (purposes2Blocks (getOpts fSpec) (purposesDefinedIn fSpec (fsLang fSpec) r)) -- Als eerste de uitleg van de betreffende regel..
+         <> (purposes2Blocks (getOpts fSpec) [p | d<-nds, p<-purposesDefinedIn fSpec (fsLang fSpec) d])  -- Dan de uitleg van de betreffende relaties
+         <> case (nds, fsLang fSpec) of
+             ([] ,_)       -> mempty 
+             ([d],Dutch)   -> plain ("Om dit te formaliseren is een " <> (if isFunction d then "functie"  else "relatie" ) <> str (name d) <> " nodig ("         <> xRefTo (XRefNaturalLanguageDeclaration d) <> "):")
+             ([d],English) -> plain ("In order to formalize this, a " <> (if isFunction d then "function" else "relation") <> str (name d) <> " is introduced (" <> xRefTo (XRefNaturalLanguageDeclaration d) <> "):")
+             (_  ,Dutch)   -> plain ("Om te komen tot de formalisatie van " <> xRefTo (XRefNaturalLanguageRule r) 
+                                    <>  " (" <> (singleQuoted.str.name) r  <> ") "
+                                    <> str (" zijn de volgende "++count Dutch (length nds) "in deze paragraaf geformaliseerde relatie"++" nodig."))
+             (_  ,English) -> plain ("To arrive at the formalization of "   <> xRefTo (XRefNaturalLanguageRule r) <> str (", the following "++count English (length nds) "relation"++" are introduced."))
+         <> (fromList $
+                  pandocEqnArray
+                      [ [ "("++xRefToLatexRefString (XRefConceptualAnalysisDeclaration d) ++ ")\\;\\;"
+                        ,  texOnly_Id(name d)
+                        , ":"
+                        , texOnly_Id(name (source d))++(if isFunction d then texOnly_fun else texOnly_rel)++texOnly_Id(name(target d))
+                        ] |d<-nds])
+         <> (case nds of
+              [] -> case rds of
+                       []   -> mempty
+                       [rd] -> plain (  l (NL "Relatie ", EN "We use relations ")
+                                     <> xRefTo (XRefConceptualAnalysisDeclaration rd) <> "(" <> (emph.str.name) rd <> ")"
+                                     <> l (NL " wordt gebruikt.", EN ".")
+                                     )
+                       _    -> plain (  (case fsLang fSpec of
+                                          Dutch   ->  "We gebruiken de relaties " 
+                                                     <> commaNLPandoc'  "en"  [xRefTo (XRefConceptualAnalysisDeclaration rd) <> " (" <> (emph.str.name) rd <> ")" |rd<-rds]
+                                          English ->   "We use relations "
+                                                     <> commaEngPandoc' "and" [xRefTo (XRefConceptualAnalysisDeclaration rd) <> " (" <> (emph.str.name) rd <> ")" |rd<-rds]
+                                        )
+                                     )
+              _  -> if null rds then mempty
+                    else ( plain ( ( case rds of
+                                      []   -> mempty
+                                      [rd] ->   l (NL "Daarnaast gebruiken we relatie ", EN "Beside that, we use relation ")
+                                              <> xRefTo (XRefConceptualAnalysisDeclaration rd) <> "(" <> (str.name) rd <> ")"
+                                      _ -> (case fsLang fSpec of
+                                          Dutch   ->   "Ook gebruiken we relaties " 
+                                                     <> commaNLPandoc'  "en"  [xRefTo (XRefConceptualAnalysisDeclaration rd) <> " (" <> (emph.str.name) rd <> ")" |rd<-rds]
+                                          English ->   "We also use relations "
+                                                     <> commaEngPandoc' "and" [xRefTo (XRefConceptualAnalysisDeclaration rd) <> " (" <> (emph.str.name) rd <> ")" |rd<-rds]
+                                           )
+                                   )
+                                 <> l (NL " om ", EN " to formalize ")
+                                 <> xRefTo (XRefNaturalLanguageRule r)
+                                 <> l (NL " te formaliseren: ", EN ": ")
+                                 )
+                         )
+           )
+         <> plain (if isSignal r
+                   then l ( NL "Activiteiten, die door deze regel zijn gedefinieerd, zijn afgerond zodra: "
+                          , EN "Activities that are defined by this rule are finished when: ")
+                   else l (NL "De regel luidt: ", EN "This means: ")
+                  )
+         <> (if showPredExpr (getOpts fSpec)
+             then pandocEqnArrayWithLabel (XRefConceptualAnalysisRule r) ((showLatex.toPredLogic) r)
+             else pandocEquationWithLabel (XRefConceptualAnalysisRule r) (showMath r)
+            )
+         <> (if length nds<=1 
+             then mempty
+             else plain (  l (NL "Dit komt overeen met ", EN "This corresponds to ")
+                        <> xRefTo (XRefNaturalLanguageRule r)
+                        <> " (" <> (singleQuoted.str.name) r  <> ")."
+                        
+                        )
+            )
+         )
+        ncs = concs r >- seenConcs            -- newly seen concepts
+        cds = [(c,cd) | c<-ncs, cd<-cDefsInScope fSpec, cdcpt cd==name c]    -- ... and their definitions
+        ds  = relsUsedIn r
+        nds = [d | d@Sgn{}<-ds >- seenDeclarations]     -- newly seen relations
+        rds = [d | d@Sgn{}<-ds `isc` seenDeclarations]  -- previously seen relations
+        ( dpNext, n', seenCs,  seenDs ) = dpR rs (n+length cds+length nds+1) (ncs++seenConcs) (nds++seenDeclarations)
+
+relsInThemes :: FSpec -> [Declaration]
+relsInThemes fSpec
+        -- a relation is considered relevant iff it is declared or mentioned in one of the relevant themes.
+ = [d | d<-vrels fSpec
+   , decusr d
+   , (  decpat d `elem` themes fSpec
+         || d `elem` relsMentionedIn [p | p<-  vpatterns fSpec   , name p `elem` themes fSpec]
+     )
+   ]
+
+data Counter = Counter { --getConc :: Int
+                    --     getDecl :: Int
+                    --   , getRule :: Int
+                        getEisnr:: Int
+                       }
+newCounter :: Counter
+newCounter = Counter 1
+incEis :: Counter -> Counter
+--incConc x = x{getConc = getConc x + 1}
+--incDecl x = x{getDecl = getDecl x + 1}
+--incRule x = x{getRule = getRule x + 1}
+incEis x = x{getEisnr = getEisnr x + 1}
+
+purposes2Blocks :: Options -> [Purpose] -> Blocks
+purposes2Blocks opts ps
+ = fromList $
+     case ps of
+      [] -> []
+            -- by putting the ref after the first inline of the definition, it aligns nicely with the definition
+      _  -> case concatMarkup [expl{amPandoc = insertAfterFirstInline (ref purp) $ amPandoc expl} | purp<-ps, let expl=explMarkup purp] of
+             Nothing -> []
+             Just p  -> amPandoc p
+       where   -- The reference information, if available for this purpose, is put
+        ref :: Purpose -> [Inline]
+        ref purp = case fspecFormat opts of
+                    FLatex | (not.null.explRefIds) purp-> [RawInline (Text.Pandoc.Builder.Format "latex")
+                                                             ("\\marge{"++intercalate "; " (map latexEscShw (explRefIds purp))++"}\n")]
+                    _                                  -> []
+concatMarkup :: [A_Markup] -> Maybe A_Markup
+concatMarkup es
+ = case eqCl f es of
+    []   -> Nothing
+    [cl] -> Just A_Markup { amLang   = amLang (head cl)
+                          , amFormat = amFormat (head cl)
+                          , amPandoc = concatMap amPandoc es
+                          }
+    cls  -> fatal 136 ("don't call concatMarkup with different languages and formats\n   "++
+                      intercalate "\n   " [(show.f.head) cl | cl<-cls])
+   where f e = (amLang e, amFormat e)
+
+-- Insert an inline after the first inline in the list of blocks, if possible.
+insertAfterFirstInline :: [Inline] -> [Block] -> [Block]
+insertAfterFirstInline inlines (            Plain (inl:inls):pblocks)        =             Plain (inl : (inlines++inls)) : pblocks
+insertAfterFirstInline inlines (            Para (inl:inls):pblocks)         =             Para (inl : (inlines++inls)) : pblocks
+insertAfterFirstInline inlines (BlockQuote (Para (inl:inls):pblocks):blocks) = BlockQuote (Para (inl : (inlines++inls)) : pblocks):blocks
+insertAfterFirstInline inlines blocks                                        = Plain inlines : blocks
+
+isMissing :: Maybe Purpose -> Bool
+isMissing mp =
+  case mp of
+    Nothing -> True
+    Just p  -> (not . explUserdefd) p
+
+lclForLang :: Lang -> TimeLocale
+lclForLang lang = defaultTimeLocale { months =
+         case lang of
+           Dutch   -> [ ("januari","jan"),("februari","feb"),("maart","mrt"),("april","apr")
+                      , ("mei","mei"),("juni","jun"),("juli","jul"),("augustus","aug")
+                      , ("september","sep"),("oktober","okt"),("november","nov"),("december","dec")]
+           English -> [ ("January","Jan"),("February","Feb"),("March","Mar"),("April","Apr")
+                      , ("May","May"),("June","Jun"),("July","Jul"),("August","Aug")
+                      , ("September","Sep"),("October","Oct"),("November","Nov"),("December","Dec")]
+           }
+
+inlineIntercalate :: Inlines -> [Inlines] -> Inlines
+inlineIntercalate _  [] = mempty
+inlineIntercalate _ [x] = x
+inlineIntercalate sep (x:xs) = x <> sep <> inlineIntercalate sep xs
+
+plainText :: String -> Blocks 
+plainText = plain . text 
+
+-- Temporary fixes of Pandoc builder. ---
+bulletList :: [Blocks] -> Blocks
+bulletList [] = mempty
+bulletList xs = BuggyBuilder.bulletList xs
+
+math :: String -> Inlines
+math s = BuggyBuilder.math ("{"++s++"}")
+
+
+-- Utility types and functions for handling multiple-language strings
+
+-- If you declare a local function:   l lstr = localize (fsLang fSpec) lstr
+-- you can use:  l (NL "Nederlandse tekst", EN "English text") 
+-- to specify strings in multiple languages. 
+
+newtype NLString = NL String
+newtype ENString = EN String
+
+type LocalizedStr = (NLString, ENString)
+
+localize :: Lang -> LocalizedStr -> String
+localize Dutch   (NL s, _) = s
+localize English (_, EN s) = s
+
+

+ src/Database/Design/Ampersand/Prototype/Apps.hs view
@@ -0,0 +1,6 @@+module Database.Design.Ampersand.Prototype.Apps
+      ( module Database.Design.Ampersand.Prototype.Apps.RAP
+      )
+where
+
+import Database.Design.Ampersand.Prototype.Apps.RAP (fillAtlas,picturesForAtlas,atlas2context)

+ src/Database/Design/Ampersand/Prototype/Apps/RAP.hs view
@@ -0,0 +1,350 @@+{-# LANGUAGE FlexibleInstances #-}
+--hdbc and hdbc-odbc must be installed (from hackage)
+module Database.Design.Ampersand.Prototype.Apps.RAP
+   (fillAtlas,picturesForAtlas,atlas2context,atlas2populations)
+where
+import Database.Design.Ampersand.Prototype.CoreImporter
+import Database.Design.Ampersand.Prototype.AutoInstaller (odbcinstall)
+import Database.HDBC.ODBC
+import Database.HDBC
+import Database.Design.Ampersand.FSpec.SQL
+
+-- fatal :: Int -> String -> a
+-- fatal = fatalMsg "Ampersand.Prototype.Apps.RAP"
+------
+dsnatlas::String
+dsnatlas = "DSN=RAPv1"
+
+----------------------------------------------------
+
+fillAtlas :: FSpec -> IO()
+fillAtlas fSpec = odbcinstall fSpec dsnatlas
+
+picturesForAtlas :: FSpec -> [Picture]
+picturesForAtlas fSpec
+   = map (makePicture fSpec)
+         ( [PTRelsUsedInPat pat   | pat <- vpatterns fSpec] ++
+           [PTSingleRule userRule | userRule <- vrules fSpec]++
+           [PTConcept cpt         | cpt <- concs fSpec]
+         )
+
+----------------------------------------------------
+
+--select population of concepts or reldeclsDefdInations from the atlas of this user
+--REMARK quickQuery' is strict and needed to keep results for use after disconnecting
+type AtomVal = String
+type RelTbl = [(AtomVal,AtomVal)]
+selectdecl :: (IConnection conn) => conn
+      -> FSpec
+      -> String   -- ^The name of the declaration
+      -> IO RelTbl
+selectdecl conn fSpec dclName
+ = do rows <- quickQuery' conn stmt []
+      return [(fromSql x,fromSql y) |[x,y]<-rows]
+   where stmt = prettySQLQuery fSpec 0 dcl
+         dcl = therel dclName "" ""
+         therel ::String -> String -> String -> Declaration
+         therel relname relsource reltarget
+          = theonly [ d |
+                       d<-vrels fSpec
+                      ,relname==name d
+                      ,null relsource || relsource==name(source d)
+                      ,null reltarget || reltarget==name(target d)]
+                    ("when searching for the relation x with searchpattern (name,source,target)" ++ show (relname,relsource,reltarget))
+
+theonly :: [t] -> String -> t
+theonly xs err
+ | length xs==1 = head xs
+ | null xs = error ("no x: " ++ err)
+ | otherwise = error ("more than one x: " ++ err)
+geta :: [(String,b)] -> String -> b -> b
+geta f x notfound = (\xs-> if null xs then notfound else head xs) [y | (x',y)<-f,x==x']
+
+atlas2populations :: FSpec -> IO String
+atlas2populations fSpec =
+   do verboseLn (getOpts fSpec) "Connecting to atlas..."
+      conn<-connectODBC dsnatlas
+      verboseLn (getOpts fSpec) "Connected."
+      -----------
+      --select (strict) everything you need, then disconnect, then assemble it into a context with populations only
+      --Context--
+      r_ctxnm           <- selectdecl conn fSpec "ctxnm" --ctxnm ::Context->Conid
+      --Concept--
+      r_cptnm           <- selectdecl conn fSpec "cptnm" --cptnm :: Concept->Conid
+      r_cptos           <- selectdecl conn fSpec "cptos" --cptos :: Concept*AtomID
+      r_atomvalue       <- selectdecl conn fSpec "atomvalue" --atomvalue::AtomID->Atom
+      --Relation--
+      r_decnm           <- selectdecl conn fSpec "decnm" --decnm ::Declaration->Varid
+      r_decsgn          <- selectdecl conn fSpec "decsgn" --decsgn ::Declaration->Sign
+      r_src             <- selectdecl conn fSpec "src" --src::Sign->Concept
+      r_trg             <- selectdecl conn fSpec "trg" --trg::Sign->Concept
+      --P_Population--
+      r_decpopu         <- selectdecl conn fSpec "decpopu" --decpopu ::Declaration*PairID
+      r_left            <- selectdecl conn fSpec "left" --left::Pair->AtomID
+      r_right           <- selectdecl conn fSpec "right" --right::Pair->AtomID
+      -----------
+      disconnect conn
+      verboseLn (getOpts fSpec) "Disconnected."
+      makepops r_ctxnm r_decnm r_decsgn r_src r_trg r_cptnm r_decpopu r_left r_right r_cptos r_atomvalue
+
+makepops :: RelTbl -> RelTbl -> RelTbl -> RelTbl -> RelTbl -> RelTbl -> RelTbl -> RelTbl -> RelTbl -> RelTbl -> RelTbl -> IO String
+makepops r_ctxnm r_decnm r_decsgn r_src r_trg r_cptnm r_decpopu r_left r_right r_cptos r_atomvalue
+ = return ("CONTEXT "++cxnm++" IN DUTCH\n"++concatMap showADL pops++"\nENDCONTEXT")
+    -- SJ: The " IN DUTCH\n" part is wrong, surely. But how to fix this? In any case, it doesn't block the parser anymore.
+   where
+   cxnm    = snd(theonly r_ctxnm "no context found in Atlas DB")
+   pops    = atlas2pops r_decnm r_decsgn r_src r_trg r_cptnm r_decpopu r_left r_right r_cptos r_atomvalue
+
+atlas2context :: Options -> FSpec -> IO A_Context
+atlas2context opts fSpec =
+   do --tbls <- readAtlas fSpec
+      verboseLn (getOpts fSpec) "Connecting to atlas..."
+      conn<-connectODBC dsnatlas
+      verboseLn (getOpts fSpec) "Connected."
+      -----------
+      --select (strict) everything you need, then disconnect, then assemble it into a context and patterns and stuff
+      --Context--
+      r_ctxnm           <- selectdecl conn fSpec "ctxnm" --ctxnm ::Context->Conid
+      --not needed because there is only one context
+      --ctxpats :: Context*Pattern
+      --ctxcs ::   Context*Concept
+      --Pattern--
+      r_ptnm            <- selectdecl conn fSpec "ptnm" --ptnm ::   Pattern->Conid
+      r_ptrls           <- selectdecl conn fSpec "ptrls" --ptrls :: Pattern*Rule
+      r_ptdcs           <- selectdecl conn fSpec "ptdcs" --ptdcs :: Pattern*Declaration
+      r_ptgns           <- selectdecl conn fSpec "ptgns" --ptgns :: Pattern*Isa
+      r_ptxps           <- selectdecl conn fSpec "ptxps" --ptxps :: Pattern*Blob
+      --Isa--
+      r_gengen          <- selectdecl conn fSpec "gengen" --gengen :: Isa->Concept
+      r_genspc          <- selectdecl conn fSpec "genspc" --genspc :: Isa->Concept
+      r_genrhs          <- selectdecl conn fSpec "genrhs" --genrhs :: Isa*Concept
+      --Concept--
+      r_cptnm           <- selectdecl conn fSpec "cptnm" --cptnm :: Concept->Conid
+      r_cptpurpose      <- selectdecl conn fSpec "cptpurpose" --cptpurpose:: Concept*Blob
+--    r_cptdf           <- selectdecl conn fSpec "cptdf" --cptdf :: Concept*Blob
+      r_cptos           <- selectdecl conn fSpec "cptos" --cptos :: Concept*AtomID
+      r_atomvalue       <- selectdecl conn fSpec "atomvalue" --atomvalue::AtomID->Atom
+      --Relation--
+      r_decnm           <- selectdecl conn fSpec "decnm" --decnm ::   Declaration->Varid
+      r_decsgn          <- selectdecl conn fSpec "decsgn" --decsgn :: Declaration->Sign
+      r_src             <- selectdecl conn fSpec "src" --src::Sign->Concept
+      r_trg             <- selectdecl conn fSpec "trg" --trg::Sign->Concept
+      r_decprps         <- selectdecl conn fSpec "decprps"    --decprps::Declaration*PropertyRule
+      r_declaredthrough <- selectdecl conn fSpec "declaredthrough" --declaredthrough :: PropertyRule*Property
+      r_decprL          <- selectdecl conn fSpec "decprL"     --decprL ::     Declaration*String
+      r_decprM          <- selectdecl conn fSpec "decprM"     --decprM ::     Declaration*String
+      r_decprR          <- selectdecl conn fSpec "decprR"     --decprR ::     Declaration*String
+      r_decmean         <- selectdecl conn fSpec "decmean"    --decmean ::    Declaration * Blob
+      r_decpurpose      <- selectdecl conn fSpec "decpurpose" --decpurpose :: Declaration * Blob
+      --P_Population--
+      r_decpopu         <- selectdecl conn fSpec "decpopu"    --decpopu ::    Declaration*PairID
+      r_left            <- selectdecl conn fSpec "left"       --left ::       PairID->AtomID
+      r_right           <- selectdecl conn fSpec "right"      --right ::      PairID->AtomID
+      --Rule--
+      r_rrnm            <- selectdecl conn fSpec "rrnm"       --rrnm ::       Rule -> ADLid
+      r_rrexp           <- selectdecl conn fSpec "rrexp"      --rrexp ::      Rule -> ExpressionID
+      r_rrmean          <- selectdecl conn fSpec "rrmean"     --rrmean ::     Rule * Blob
+      r_rrpurpose       <- selectdecl conn fSpec "rrpurpose"  --rrpurpose ::  Rule * Blob
+      --Expression--
+      r_exprvalue'      <- selectdecl conn fSpec "exprvalue"  --exprvalue ::  ExpressionID->Expression
+      --not needed
+      --rels ::   ExpressionID*Relation
+      --relnm ::  Relation -> Varid
+      --reldcl :: Relation -> Declaration
+      -----------
+      disconnect conn
+      verboseLn (getOpts fSpec) "Disconnected."
+      let r_exprvalue = parseexprs r_exprvalue' --parsing is the safest way to get the Term
+      --verboseLn (getOpts fSpec) (show(map showADL (atlas2pops relcontent relname relsc reltg  pairleft pairright atomsyntax)))
+      actx <- makectx opts r_ctxnm (fsLang fSpec)
+                     r_ptnm r_ptrls r_ptdcs r_ptgns r_ptxps
+                     r_gengen r_genspc r_genrhs
+                     r_cptnm r_cptpurpose {- r_cptdf -} r_cptos r_atomvalue
+                     r_decnm r_decsgn r_src r_trg r_decprps r_declaredthrough r_decprL r_decprM r_decprR r_decmean r_decpurpose
+                     r_decpopu r_left r_right
+                     r_rrnm r_rrexp r_rrmean r_rrpurpose r_exprvalue
+      case actx of
+       (Errors x)  -> error (show x)
+       (Checked x) -> return x
+      where
+      parseexprs :: RelTbl -> [(AtomVal, Term TermPrim)]
+      parseexprs = map f
+         where
+           f :: (AtomVal,AtomVal) -> (AtomVal, Term TermPrim)
+           f (str, expr) =
+               (str , case parseADL1pExpr expr "Atlas(Rule)" of
+                        Left err   -> error err
+                        Right term -> term
+               )
+
+makectx :: Options -> RelTbl -> Lang -> RelTbl -> RelTbl -> RelTbl -> RelTbl -> RelTbl
+                             -> RelTbl -> RelTbl -> RelTbl
+                             -> RelTbl -> RelTbl -> {- RelTbl -> -} RelTbl -> RelTbl
+                             -> RelTbl -> RelTbl -> RelTbl -> RelTbl -> RelTbl -> RelTbl -> RelTbl -> RelTbl -> RelTbl -> RelTbl -> RelTbl
+                             -> RelTbl -> RelTbl -> RelTbl -> RelTbl
+                             -> RelTbl -> RelTbl -> RelTbl -> [(AtomVal,(Term TermPrim))] -> IO (Guarded A_Context)
+makectx opts r_ctxnm lang r_ptnm r_ptrls r_ptdcs r_ptgns r_ptxps
+                          r_gengen r_genspc r_genrhs
+                          r_cptnm r_cptpurpose {- r_cptdf -} r_cptos r_atomvalue
+                          r_decnm r_decsgn r_src r_trg r_decprps r_declaredthrough r_decprL r_decprM r_decprR r_decmean r_decpurpose
+                          r_decpopu r_left r_right
+                          r_rrnm r_rrexp r_rrmean r_rrpurpose r_exprvalue
+ = return a_context
+   where
+   (a_context) = pCtx2aCtx opts rawctx
+   rawctx
+    = PCtx {
+         ctx_nm    = snd(theonly r_ctxnm "not one context in Atlas DB")
+       , ctx_pos   = [DBLoc "Atlas(Context)"]
+       , ctx_lang  = lang
+       , ctx_markup= Just LaTeX --ADLImportable writes LaTeX
+       , ctx_thms  = []
+       , ctx_pats  = [atlas2pattern p lang
+                                    r_ptrls r_ptdcs r_ptgns
+                                    r_gengen r_genspc r_genrhs
+                                    r_cptnm
+                                    r_decnm r_decsgn r_src r_trg r_decprps r_declaredthrough r_decprL r_decprM r_decprR r_decmean r_decpurpose
+                                    r_rrnm r_rrexp r_rrmean r_rrpurpose r_exprvalue
+                     |p<-r_ptnm]
+       , ctx_PPrcs = []
+       , ctx_rs    = [] --in pattern:(atlas2rules fSpec tbls)
+       , ctx_ds    = [] --in pattern:(atlas2decls fSpec tbls)
+       , ctx_cs    = [{- TODO: Han, please fix this:
+                      Cd { cdpos = DBLoc "Atlas(A_ConceptDef)"
+                         , cdcpt = cnm
+                         , cdplug = False
+                         , cddef = cdf
+                         , cdtyp = "Text"
+                         , cdref = []
+                         , cdfrom = ""
+                         }
+                     | (cid,cdf)<-r_cptdf, not(null cdf)
+                     , let cnm = geta r_cptnm cid (error "while geta r_cptnm for cdf.")  -} ]
+       , ctx_ks    = []
+       , ctx_rrules = []
+       , ctx_rrels = []
+       , ctx_vs    = []
+       , ctx_gs    = []
+       , ctx_ifcs  = []
+       , ctx_ps    = [PRef2 (DBLoc "Atlas(PatPurpose)") (PRef2Pattern pnm) (P_Markup Nothing Nothing ppurp) []
+                     | (pid,ppurp)<-r_ptxps, not(null ppurp)
+                     , let pnm = geta r_ptnm pid (error "while geta r_ptnm for ppurp.")]
+                  ++ [PRef2 (DBLoc "Atlas(CptPurpose)") (PRef2ConceptDef cnm) (P_Markup Nothing Nothing cpurp) []
+                     | (cid,cpurp)<-r_cptpurpose, not(null cpurp)
+                     , let cnm = geta r_cptnm cid (error "while geta r_cptnm for cpurp.")]
+       , ctx_pops  = atlas2pops r_decnm r_decsgn r_src r_trg r_cptnm r_decpopu r_left r_right r_cptos r_atomvalue
+       , ctx_sql   = []
+       , ctx_php   = []
+       , ctx_metas = []
+      }
+
+atlas2pattern :: (AtomVal,AtomVal) -> Lang -> RelTbl -> RelTbl -> RelTbl
+                  -> RelTbl -> RelTbl -> RelTbl
+                  -> RelTbl -> RelTbl -> RelTbl -> RelTbl -> RelTbl -> RelTbl -> RelTbl -> RelTbl -> RelTbl -> RelTbl -> RelTbl
+                  -> RelTbl -> RelTbl -> RelTbl -> RelTbl -> RelTbl -> [(AtomVal,(Term TermPrim))] -> P_Pattern
+atlas2pattern (pid,pnm) lang r_ptrls r_ptdcs r_ptgns
+                             r_gengen r_genspc _ {- r_genrhs -}
+                             r_cptnm
+                             r_decnm r_decsgn r_src r_trg r_decprps r_declaredthrough r_decprL r_decprM r_decprR r_decmean r_decpurpose
+                             r_rrnm r_rrexp r_rrmean r_rrpurpose r_exprvalue
+ = P_Pat { pt_nm  = pnm
+         , pt_pos = DBLoc "Atlas(Pattern)"
+         , pt_end = DBLoc "Atlas(Pattern)"
+         , pt_rls = [atlas2rule rid lang r_rrnm r_rrexp r_rrmean r_exprvalue
+                    | (pid',rid)<-r_ptrls, pid==pid', rid `notElem` map fst r_declaredthrough]
+         , pt_gns = [PGen{ gen_fp = DBLoc "Atlas(Isa)"
+                          ,gen_gen= PCpt gnm,gen_spc=(PCpt snm)}  -- TODO: Han, would you please look after the CLASSIFY IS statements?
+                    | (pid',genid)<-r_ptgns, pid'==pid
+                    , let gid = geta r_gengen genid (error "while geta r_gengen.")
+                    , let sid = geta r_genspc genid (error "while geta r_genspc.")
+                    , let gnm = geta r_cptnm gid (error "while geta r_cptnm for gen.")
+                    , let snm = geta r_cptnm sid (error "while geta r_cptnm for spc.")]
+         , pt_dcs = [atlas2decl rid i lang r_decnm r_decsgn r_src r_trg r_cptnm r_decprps r_declaredthrough r_decprL r_decprM r_decprR r_decmean
+                    |(i,(pid',rid))<-zip [1..] r_ptdcs, pid==pid']
+         , pt_RRuls = []
+         , pt_RRels = []
+         , pt_cds = []
+         , pt_ids = []
+         , pt_vds = []
+         , pt_xps = [PRef2 (DBLoc "Atlas(RulPurpose)") (PRef2Rule rnm) (P_Markup Nothing Nothing rpurp) []
+                    | (pid',rid)<-r_ptrls, pid==pid'
+                    , (rid',rpurp)<-r_rrpurpose, rid==rid', not(null rpurp)
+                    , let rnm = geta r_rrnm rid (error "while geta r_rrnm for rpurp.")]
+                 ++ [PRef2 (DBLoc "Atlas(RelPurpose)")
+                           (PRef2Declaration (PNamedRel OriginUnknown rnm (Just $ atlas2sign rid r_decsgn r_src r_trg r_cptnm)))
+                           (P_Markup Nothing Nothing rpurp) []
+                    | (pid',rid)<-r_ptdcs, pid==pid'
+                    , (rid',rpurp)<-r_decpurpose, rid==rid', not(null rpurp)
+                    , let rnm = geta r_decnm rid (error "while geta r_decnm for rpurp.")]
+         , pt_pop = []
+         }
+
+atlas2rule :: AtomVal -> Lang -> RelTbl -> RelTbl -> RelTbl -> [(AtomVal,Term TermPrim)] -> (P_Rule TermPrim)
+atlas2rule rid lang r_rrnm r_rrexp r_rrmean r_exprvalue
+ = P_Ru { rr_nm   = geta r_rrnm rid (error "while geta r_rrnm.")
+        , rr_exp  = geta r_exprvalue eid (error "while geta r_exprvalue.")
+        , rr_fps  = DBLoc "Atlas(Rule)"
+        , rr_mean = [PMeaning (P_Markup (Just lang) Nothing (geta r_rrmean rid ""))]
+        , rr_msg  = []
+        , rr_viol = Nothing
+        }
+   where eid = geta r_rrexp rid (error "while geta r_rrexp.")
+
+atlas2sign :: AtomVal -> RelTbl -> RelTbl -> RelTbl -> RelTbl -> P_Sign
+atlas2sign rid r_decsgn r_src r_trg r_cptnm
+ = P_Sign (PCpt srcnm) (PCpt trgnm)
+   where sid = geta r_decsgn rid (error "while geta r_decsgn.")
+         srcid = geta r_src sid (error ("while geta r_src."++sid++show r_src))
+         trgid = geta r_trg sid (error "while geta r_trg.")
+         srcnm = geta r_cptnm srcid (error "while geta r_cptnm of srcid.")
+         trgnm = geta r_cptnm trgid (error "while geta r_cptnm of trgid.")
+
+atlas2pops :: RelTbl -> RelTbl -> RelTbl -> RelTbl -> RelTbl -> RelTbl -> RelTbl -> RelTbl -> RelTbl -> RelTbl -> [P_Population]
+atlas2pops r_decnm r_decsgn r_src r_trg r_cptnm r_decpopu r_left r_right r_cptos r_atomvalue
+ = [ P_TRelPop { p_rnme  = rnm
+               , p_orig  = OriginUnknown
+               , p_type  = rsgn
+               , p_popps = rpop
+               }
+   | (rid,rnm)<-r_decnm
+   , let rsgn = atlas2sign rid r_decsgn r_src r_trg r_cptnm
+   , let rpop = [makepair pid | (rid',pid)<-r_decpopu, rid==rid']
+   ]
+   ++
+   [P_CptPopu { p_cnme=geta r_cptnm (fst(head cl)) (error "while geta r_cptnm for CptPopu.")
+              , p_orig  = OriginUnknown
+              , p_popas=[a | (_,aid)<-cl, let a=geta r_atomvalue aid (error "while geta r_atomvalue of aid.")]
+              }
+   | cl<-eqCl fst r_cptos, not (null cl)]
+   where
+   makepair pid = mkPair src trg
+         where lid = geta r_left pid (error "while geta r_left.")
+               rid = geta r_right pid (error "while geta r_right.")
+               src = geta r_atomvalue lid (error "while geta r_atomvalue of lid.")
+               trg = geta r_atomvalue rid (error "while geta r_atomvalue of rid.")
+
+atlas2decl :: AtomVal -> Int -> Lang
+              -> RelTbl -> RelTbl -> RelTbl -> RelTbl -> RelTbl -> RelTbl -> RelTbl -> RelTbl -> RelTbl -> RelTbl -> RelTbl -> P_Declaration
+atlas2decl rid i lang r_decnm r_decsgn r_src r_trg r_cptnm r_decprps r_declaredthrough r_decprL r_decprM r_decprR r_decmean
+ = P_Sgn { dec_nm = geta r_decnm rid (error "while geta r_decnm.")
+         , dec_sign = atlas2sign rid r_decsgn r_src r_trg r_cptnm
+         , dec_prps = [case geta r_declaredthrough prp (error "while geta r_declaredthrough.") of
+                        "UNI"->Uni
+                        "TOT"->Tot
+                        "INJ"->Inj
+                        "SUR"->Sur
+                        "RFX"->Rfx
+                        "IRF"->Irf
+                        "TRN"->Trn
+                        "SYM"->Sym
+                        "ASY"->Asy
+                        _ -> error "unknown prop in atlas"
+                      | (rid',prp)<-r_decprps, rid'==rid]
+         , dec_prL = geta r_decprL rid ""
+         , dec_prM = geta r_decprM rid ""
+         , dec_prR = geta r_decprR rid ""
+         , dec_Mean = [PMeaning (P_Markup (Just lang) Nothing (geta r_decmean rid ""))]
+         , dec_popu = []
+         , dec_fpos = DBLoc$"Atlas(Declaration)"++show i
+         , dec_plug = False
+         }

+ src/Database/Design/Ampersand/Prototype/AutoInstaller.hs view
@@ -0,0 +1,63 @@+--hdbc and hdbc-odbc must be installed (from hackage)
+--Strongly resembles running Installer.php rev:1770 only at compile time through an ODBC connection with DSN=dsn
+--the connection via ODBC should be the same as the connection via dbSettings.php
+--Difference with Installer.php rev:1770:
+-- + odbcinstall expects the database to exist (no CREATE DATABASE)
+-- + no row inserted into __History__ at odbcinstall
+module Database.Design.Ampersand.Prototype.AutoInstaller (odbcinstall)
+where
+import Database.Design.Ampersand.Prototype.CoreImporter
+import Database.Design.Ampersand.Prototype.ProtoUtil
+import Database.Design.Ampersand.Prototype.PHP
+import Database.HDBC.ODBC
+import Database.HDBC
+import Data.List  (intercalate)
+-- import Database.Design.Ampersand.Version (fatalMsg)
+
+--fatal :: Int -> String -> a
+--fatal = fatalMsg "AutoInstaller"
+
+odbcinstall :: FSpec -> String -> IO()
+odbcinstall fSpec dsn =
+   do verboseLn (getOpts fSpec) ("Connecting to ODBC connection "++ dsn ++"...")
+      conn<-connectODBC dsn
+      verboseLn (getOpts fSpec) "Connected."
+      verboseLn (getOpts fSpec) "Dropping tables..."
+      _ <- drops conn ("DROP TABLE `__History__`":"DROP TABLE `__SessionTimeout__`":[dropplug p | InternalPlug p<-plugInfos fSpec])
+      verboseLn (getOpts fSpec) "Creating tables..."
+      _ <- creates conn (historyTableSpec : sessionTableSpec : [plug2TableSpec p |InternalPlug p<-plugInfos fSpec])
+      verboseLn (getOpts fSpec) "Populating tables..."
+      _ <- inserts conn (vgens fSpec)(initialPops fSpec) [p |InternalPlug p<-plugInfos fSpec]
+      commit conn
+      verboseLn (getOpts fSpec) "Committed."
+      disconnect conn
+
+--drop tables
+--IGNORES all SQL errors!!!
+drops :: (IConnection conn) => conn -> [String] -> IO Integer
+drops _ [] = return 1
+drops conn (x:xs)  =
+   do _ <- handleSql (\_ -> return 0) (run conn x [])
+      drops conn xs
+
+--insert population
+inserts :: (IConnection conn) => conn -> [A_Gen] -> [Population] -> [PlugSQL] -> IO Integer
+inserts _ _ _ [] = return 1
+inserts conn a_gens udp (plug:plugs) =
+   do stmt<- prepare conn
+             ("INSERT INTO "++quote (name plug)++" ("++intercalate "," [quote (fldname f)++" " |f<-plugFields plug]++")"
+                                ++" VALUES ("++placeholders(plugFields plug)++")")
+      executeMany stmt [ map toSql tblRecord | tblRecord<-tblcontents a_gens udp plug]
+      inserts conn a_gens udp plugs
+   where
+   placeholders :: [a] -> String
+   placeholders [] = []
+   placeholders (_:[]) = "?"
+   placeholders (_:xs) = "?," ++ placeholders xs
+
+--create tables
+creates :: (IConnection conn) => conn -> [TableSpec] -> IO Integer
+creates _ [] = return 1
+creates conn ((_,crtbl,crflds,crengine):tbls) =
+   do _ <- run conn (crtbl ++ concat crflds ++ crengine) []
+      creates conn tbls

+ src/Database/Design/Ampersand/Prototype/CoreImporter.hs view
@@ -0,0 +1,79 @@+module Database.Design.Ampersand.Prototype.CoreImporter
+    ( module Database.Design.Ampersand
+    )
+where
+
+import Database.Design.Ampersand hiding (fatalMsg) -- we wrote our own version for the prototype
+--   ( -- Data Constructors:
+--     A_Context
+--   , P_Context(..)
+--   , PRef2Obj(..), PPurpose(..)
+--   , A_Concept(..), newAcpt
+--   , ConceptDef(..), ConceptStructure(..)
+--   , Pattern(..)
+--   , Declaration(..)
+--   , Expression(..)
+--   , P_Population(..)
+--   , FSpec(..)
+--   , ObjectDef(..)
+--   , PlugSQL(..), SqlField(..), SqlType(..), PlugInfo(..)
+--   , Relation(..)
+--   , Rule(..)
+--   , Prop(..)
+--   , Lang(..)
+--   , Options(..), DocTheme(..)
+--   , Picture(..), writePicture
+--   , Origin(..)
+--   , FPA(..), FPcompl(..)
+--   , mkPair
+--   , P_Populations
+--   -- * Classes:
+--   , Association(..), flp
+--   , Collection(..)
+--   , Named(..)
+--   , Relational(..)
+--   , Interface(..)
+--   , Object(..)
+--   , Plugable(..)
+--   , Traced(..)
+--   , SpecHierarchy(..)
+--   , Language(..)
+--   , makePicture
+--   , FPAble(..)
+--   , ShowHS(..), haskellIdentifier
+--   , ADL1Importable(..)
+--   -- * Functions on relsDefdIn
+--   , makeRelation
+--   -- * Functions on rules
+--   , normExpr
+--   , showexpression
+--   -- * Functions on expressions:
+--   , conjNF, disjNF, simplify
+--   , v, notCpl, isPos, isNeg
+--   -- * Functions with plugs:
+--   , tblfields, fldauto
+--   -- * Parser related stuff
+--   , ParserVersion(..)
+--   , parseFile
+--   , parseADL1Rule
+--   , parseADL1
+--   , parseADL1Pop
+--   -- * typechecking
+--   , typecheckAdl1
+--   -- * Prettyprinters
+--   , showADL, showADLcode, showSQL
+--   -- * Generators
+--   , makeFSpec
+--   , generate
+--   -- * Functions with Options
+--   , getOptions
+--   , verboseLn, verbose
+--   , ImportFormat(..),helpNVersionTexts
+--   -- * Other functions
+--   , eqCl, naming
+--   , versionNumber
+--   , putStr, readFile, writeFile
+--   -- * Stuff that should not be in the prototype
+--   , explainContent2String, RuleMeaning(..)
+--   )
+   
+ src/Database/Design/Ampersand/Prototype/GenBericht.hs view
@@ -0,0 +1,264 @@+{-# LANGUAGE NamedFieldPuns #-}
+module Database.Design.Ampersand.Prototype.GenBericht (doGenBericht) where
+
+import Prelude hiding (writeFile)
+import Data.List
+import Text.CSV
+import System.FilePath
+import System.Directory
+import Control.Monad
+import Database.Design.Ampersand
+-- TODO: only show Rel and Flp Rel? give error otherwise?
+--       what about Typ, Brk etc.?
+
+fatal :: Int -> String -> a
+fatal = fatalMsg "GenBericht"
+
+-- an intermediate data type, so we can easily generate to several output formats
+data Entity = Entity { entName ::     String
+                     , depth ::       Int
+                     , cardinality :: String
+                     , definition ::  String
+                     , refType ::     String
+                     , properties ::  [Entity]
+                     } deriving Show
+
+doGenBericht :: FSpec -> IO ()
+doGenBericht fSpec =
+ do { verboseLn (getOpts fSpec) "Generating 'Berichtendefinities'..."
+    ; createDirectoryIfMissing True $ combine (dirPrototype (getOpts fSpec)) "Berichten"
+    ; let entities = genEntity_Interfaces $ interfaceS fSpec
+    ; let berichtenCSV = allEntitiesToCSV entities
+    ; when (development (getOpts fSpec)) $ verboseLn (getOpts fSpec) $ layout berichtenCSV
+    ; genFile "Berichten/Berichten.csv" $ printSemicolonSeparated berichtenCSV
+    ; genFile "Berichten/Gegevenswoordenboek.html" $ genGegevensWB entities
+    ; genFile "Berichten/Berichtdefinitie.html" $ genBerichtDef entities
+    }
+ where
+   genFile filename contents =
+        do { writeFile (combine (dirPrototype (getOpts fSpec)) filename) contents
+           ; verboseLn (getOpts fSpec) $ "\nGenerated file "++filename
+           }
+   genEntity_Interfaces :: [Interface] -> [Entity]
+   genEntity_Interfaces interfaces' = map genEntity_Interface interfaces'
+     where
+       genEntity_Interface :: Interface -> Entity
+       genEntity_Interface interface = genEntity_ObjDef 0 (ifcObj interface)
+         where
+           genEntity_ObjDef :: Int -> ObjectDef -> Entity
+           genEntity_ObjDef dpth objDef =
+               Entity { entName = name objDef
+                      , depth = dpth
+                      , cardinality = card $ objctx objDef
+                      , definition  = def $ objctx objDef
+                      , refType     = name (target $ objctx objDef)
+                      , properties  =
+                          case objmsub objDef of
+                            Nothing -> []
+                            Just (Box _ _ objs)    -> map (genEntity_ObjDef (dpth+1)) objs
+                            Just (InterfaceRef nm) -> map (genEntity_ObjDef (dpth+1)) $ objsForInterfaceNamed nm
+                      }
+            where card e = (if isTot e then "1" else "0")++".."++(if isUni e then "1" else "*")
+
+                  def rel = case concDefs fSpec (target rel) of
+                                Cd {cddef=def'} : _ | def' /= "" -> def'
+                                _                                -> "** NO DEFINITION **"
+
+                  objsForInterfaceNamed :: String -> [ObjectDef]
+                  objsForInterfaceNamed nm =
+                    case objmsub $ ifcObj $ getInterfaceByName interfaces' nm of
+                      Just (Box _ _ objs) -> objs
+                      _                   -> fatal 81 "Bericht interfaces have wrong format"
+                  -- NOTE: We ignore the interface relation for interfaces refs
+
+allEntitiesToCSV :: [Entity] -> CSV
+allEntitiesToCSV entities = ["Naam", "Card.", "Definitie", "Type"] :
+                            intercalate [["","","",""]] (map entityToCSV  entities)
+
+entityToCSV :: Entity -> CSV
+entityToCSV (Entity nm dpth card def refTp props) =
+  [ concat (replicate dpth ". ") ++ nm, card, def, refTp] : concatMap entityToCSV props
+
+-- Utils
+
+layout :: [[String]] -> String
+layout linez =
+  let columns = transpose linez
+      formatColumn col = let width = maximum . map length $ col
+                         in  map (fill width) col
+  in  unlines . map unwords . transpose . map formatColumn $ columns
+ where fill i str = str ++ take (i - length str) (replicate i ' ')
+
+-- Modified version of Text.CSV.printCSV
+printSemicolonSeparated :: CSV -> String
+printSemicolonSeparated records = unlines (printRecord `map` records)
+    where printRecord = intercalate ";" . map printField
+          printField f = "\"" ++ concatMap escape f ++ "\""
+          escape '"' = "\"\""
+          escape x = [x]
+
+-- Html
+
+genGegevensWB :: [Entity] -> String
+genGegevensWB entities = gegevensWB_Header ++
+                         gegevensWB_Toc ++
+                         gegevensWB_Middle ++
+                         concatMap gegevensWB_Element entities ++
+                         gegevensWB_Footer
+ where
+  gegevensWB_Toc :: String
+  gegevensWB_Toc = unlines
+    [ "      <li>" ++ mkLocalLink concept' concept' ++ "</li>"
+    | Entity{ entName = concept' } <- entities
+    ]
+
+  -- TODO: it's not the concept, but the interface name, yet refTp is a concept? or also an interface name?
+  gegevensWB_Element :: Entity -> String
+  gegevensWB_Element (Entity concept' _ _ _ _ props) =
+    wbElement_Header ++
+    concatMap (wbElement_Element concept') props ++
+    wbElement_Footer
+   where
+      wbElement_Header :: String
+      wbElement_Header  =
+        "    " ++ mkAnchor concept' ++
+        "    <div class=\"gegevenselement\">\n" ++
+        "      <div class=\"objectclass\">"++concept'++"</div>\n" ++
+        "      <div class=\"definition\">"++concept'++"</div>\n" ++
+        "      <table class=\"properties\">\n" ++
+        "        <tr><td class=\"head\">Property term</td><td class=\"head\">Cardinality</td><td class=\"head\">Representation term</td></tr>\n"
+       where
+        mkAnchor :: String -> String
+        mkAnchor entityName = "<a name=\"abie-"++escapeNonAlphaNum entityName++"\" id=\"abie-"++escapeNonAlphaNum entityName++"\"> </a>\n"
+
+      wbElement_Element :: String -> Entity -> String
+      wbElement_Element parentConcept (Entity _ _ card def refTp _) =
+        "        <tr class=\"property-abie-"++escapeNonAlphaNum parentConcept++"\">\n" ++
+        "          <td class=\"property_term\" title=\""++def++"\">"++def++"</td>\n" ++
+        -- NOTE: don't want def twice here
+        "          <div class=\"info d1e110\"></div><td class=\"cardinality\">"++card++"</td>\n" ++
+        "          <td class=\"representationterm\">" ++ mkLink entities refTp refTp ++ "</a></td>\n" ++
+        -- TODO: leave out <a> if this is not a defined data type
+        "        </tr>\n"
+
+  wbElement_Footer :: String
+  wbElement_Footer =
+    "      </table>\n" ++
+    "    </div>\n"
+
+  gegevensWB_Header :: String
+  gegevensWB_Header =
+    "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">\n" ++
+    "<html xmlns=\"http://www.w3.org/1999/xhtml\">\n" ++
+    "<head>\n" ++
+    "<meta http-equiv=\"Content-Type\" content=\"text/html; charset=UTF-8\" />\n" ++
+    "<title>Rechtspraak 2011-11-25 20:14:20</title>\n" ++
+    "<link rel=\"stylesheet\" type=\"text/css\" href=\"lib/css/style.css\" media=\"screen\" />\n" ++
+    "<link rel=\"stylesheet\" type=\"text/css\" href=\"lib/css/style-print.css\" media=\"print\" />\n" ++
+    "</head>\n" ++
+    "<body>\n" ++
+    "<div id=\"index\">\n" ++
+    "  <div id=\"abie\" class=\"index-group\">\n" ++
+    "    <h2>Aggregate BIEs</h2>\n" ++
+    "    <ol>\n"
+
+  gegevensWB_Middle :: String
+  gegevensWB_Middle =
+    "    </ol>\n" ++
+    "  </div>\n" ++
+    "</div>\n" ++
+    "<div id=\"main\">\n" ++
+    "  <div id=\"main-abie\">\n"
+
+  gegevensWB_Footer :: String
+  gegevensWB_Footer =
+    "  </div>\n" ++
+    "</div>\n" ++
+    "</body>\n" ++
+    "</html>\n"
+
+mkLocalLink :: String -> String -> String
+mkLocalLink nm html = "<a href=\"#abie-"++escapeNonAlphaNum nm++"\" title=\""++nm++"\">" ++
+                        html ++ "</a>"
+
+mkLink :: [Entity] -> String -> String -> String
+mkLink entities nm html =
+  if isEntity entities nm
+  then "<a id=\"abie-"++escapeNonAlphaNum nm++"\" href=\"Gegevenswoordenboek.html#abie-"++escapeNonAlphaNum nm++"\">\n"++
+       html ++ "</a>"
+  else html
+
+isEntity :: [Entity] -> String -> Bool
+isEntity entities nm = (not.null) (filter ((==nm) . entName) entities)
+
+genBerichtDef :: [Entity] -> String
+genBerichtDef entities =
+  berichtDef_Header ++
+  berichtDef_Toc ++
+  berichtDef_Middle ++
+  concatMap berichtDef_ElementLine entities ++
+  berichtDef_Footer
+ where
+  berichtDef_Toc :: String
+  berichtDef_Toc = unlines
+    [ "    <li><a href=\"#abie-"++escapeNonAlphaNum entNm++"\" title=\"\">"++entNm++"</a></li>"
+    | Entity{ entName = entNm } <- entities
+    ]
+
+  berichtDef_ElementLine :: Entity -> String
+  berichtDef_ElementLine (Entity entNm depth card def refTp props) =
+    "        <tr>\n" ++
+    "          <td class=\"bold\" title=\""++def++"\""++padding++">\n" ++
+    "            " ++ mkLink entities refTp entNm ++
+    "          </td>\n" ++
+    "          <td>"++card++"</td>\n" ++
+    "          <td>"++def++"</td>\n" ++
+    "        </tr>\n" ++
+    concatMap berichtDef_ElementLine props
+   where padding = if depth > 0  then " style=\"padding-left:"++show (depth*25)++"px\"" else ""
+
+  -- Html-page strings
+
+  berichtDef_Header :: String
+  berichtDef_Header =
+    "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">\n" ++
+    "<html xmlns=\"http://www.w3.org/1999/xhtml\">\n" ++
+    "<head>\n" ++
+    "<meta http-equiv=\"Content-Type\" content=\"text/html; charset=UTF-8\" />\n" ++
+    "<title>Documentation for Aanlevering Zaakstuk</title>\n" ++
+    "<link rel=\"stylesheet\" type=\"text/css\" href=\"lib/css/style.css\" media=\"screen\" />\n" ++
+    "<link rel=\"stylesheet\" type=\"text/css\" href=\"lib/css/style-print.css\" media=\"print\" />\n" ++
+    "</head>\n" ++
+    "<body>\n" ++
+    "<h2>Business Document - AanleveringZaakstuk_BD-023011</h2>\n" ++
+    "<div id=\"main\">\n" ++
+    "  <h3>Document Information</h3>\n" ++
+    "  <table class=\"bdDescription\">\n" ++
+    "    <tr><td class=\"descriptionHeader\">Object Class Term</td><td>Aanlevering Zaakstuk</td></tr>\n" ++
+    "    <tr><td class=\"descriptionHeader\">Qualifier Term</td><td></td></tr>\n" ++
+    "    <tr><td class=\"descriptionHeader\">Version</td><td>1.1.0.0</td></tr>\n" ++
+    "    <tr><td class=\"descriptionHeader\">Unique Identifier</td><td>BD-023011</td></tr>\n" ++
+    "    <tr><td class=\"descriptionHeader\">Release Identifier</td><td>1.1RC02</td></tr>\n" ++
+    "    <tr><td class=\"descriptionHeader\">Date</td><td>2011-11-25</td></tr>\n" ++
+    "    <tr><td class=\"descriptionHeader\">Definition</td><td>Gebruikt om stukken aan te leveren aan de Rechtsprekende Instantie.</td></tr>\n" ++
+    "    <tr><td class=\"descriptionHeader\">Comments</td><td>'Generiek' BD Aanlevering Zaakstuk.&#13;1.1 heeft voorschot salaris toegevoegd - specifiek voor DDI</td></tr>\n" ++
+    "    <tr><td class=\"descriptionHeader\">Document Header</td><td>The XML schema for this business document includes the <a href=\"lib/headerdoc/ebvheader.html\">http://data.justid.nl/common/header-1</a> header(s).</td></tr>\n" ++
+    "  </table>\n" ++
+    "  <h3>Document Properties</h3>\n" ++
+    "  <ol>\n"
+
+  berichtDef_Middle :: String
+  berichtDef_Middle =
+    "  </ol>\n" ++
+    "  <div id=\"main-abie\">\n" ++
+    "    <div class=\"gegevenselement\">\n" ++
+    "      <table class=\"properties\">\n" ++
+    "        <tr><td class=\"head\">Property term</td><td class=\"head\">Cardinality</td><td class=\"head\">Definition</td></tr>\n"
+
+  berichtDef_Footer :: String
+  berichtDef_Footer =
+    "  </div>\n" ++
+    "</div>\n" ++
+    "</body>\n" ++
+    "</html>\n"
+

+ src/Database/Design/Ampersand/Prototype/GenFrontend.hs view
@@ -0,0 +1,421 @@+{-# LANGUAGE DeriveDataTypeable #-}
+module Database.Design.Ampersand.Prototype.GenFrontend (doGenFrontend, clearTemplateDirs) where
+
+import Prelude hiding (putStrLn,readFile)
+import Control.Monad
+import Data.Data
+import Data.List
+import Data.Maybe
+import System.Directory
+import System.FilePath
+import Text.StringTemplate
+import Text.StringTemplate.GenericStandard () -- only import instances
+import Database.Design.Ampersand.Basics
+import Database.Design.Ampersand.Classes.Relational
+import Database.Design.Ampersand.Core.AbstractSyntaxTree
+import Database.Design.Ampersand.FSpec.FSpec
+import Database.Design.Ampersand.FSpec.ShowADL
+import Database.Design.Ampersand.FSpec.ToFSpec.NormalForms
+import Database.Design.Ampersand.Misc
+import qualified Database.Design.Ampersand.Misc.Options as Opts
+import Database.Design.Ampersand.Prototype.ProtoUtil
+
+fatal :: Int -> String -> a
+fatal = fatalMsg "GenFrontend"
+
+{- TODO
+- Converse navInterfaces?
+- Be more consistent with record selectors/pattern matching
+- HStringTemplate hangs on uninitialized vars in anonymous template? (maybe only fields?)
+- isRoot is a bit dodgy (maybe make dependency on ONE and SESSIONS a bit more apparent)
+- Keeping templates as statics requires that the static files are written before templates are used.
+  Maybe we should keep them as cabal data-files instead. (file extensions and directory structure are predictable)
+
+
+NOTE: interface refs are handled as follows:
+
+INTERFACE MyInterface 
+  BOX [ ref : rel[$a*$b]
+        INTERFACE RefInterface
+      ]
+      
+INTERFACE RefInterface relRef[$b*$c]
+  BOX [ .. : ..[$c*$d]
+      ]
+
+is basically mapped onto:
+
+INTERFACE MyInterface 
+  BOX [ ref : (rel;relRef)[$a*$c]
+        BOX [ .. : ..[$c*$d]
+            ]
+      ]
+
+This is considered editable iff the composition rel;relRef yields an editable declaration (e.g. for editableR;I).
+
+-}
+
+data Include = Include { _fileOrDir :: FileOrDir, includeSrc :: String, _includeTgt :: String } deriving Show
+
+data FileOrDir = File | Dir deriving Show
+
+-- Files/directories that will be copied to the prototype, if present in $adlSourceDir/includes/
+allowedIncludeSubDirs :: [Include]
+allowedIncludeSubDirs = [ Include Dir  "templates"         "templates"
+                        , Include Dir  "views"             "app/views"
+                        , Include Dir  "css"               "app/css"
+                        , Include Dir  "js"                "app/js"
+                        , Include Dir  "images"            "app/images"
+                        , Include Dir  "extensions"        "extensions"
+                        , Include File "localSettings.php" "localSettings.php"
+                        ]
+
+getTemplateDir :: FSpec -> String
+getTemplateDir fSpec = Opts.dirPrototype (getOpts fSpec) </> "templates"
+
+-- Clear template dirs so the generator won't use lingering template files. 
+-- (Needs to be called before statics are generated, otherwise the templates from statics/newFrontend/templates will get deleted)
+-- TODO: refactor generate, so we can call generation of static files and generics.php from this module.
+clearTemplateDirs :: FSpec -> IO ()
+clearTemplateDirs fSpec = mapM_ emptyDir ["views", "controllers"]
+  where emptyDir path = 
+         do { let absPath = getTemplateDir fSpec </> path
+            ; dirExists <- doesDirectoryExist absPath
+            ; when dirExists $ -- dir may not exist if we haven't generated before
+               removeAllDirectoryFiles absPath
+            } -- Only remove files, withouth entering subdirectories, to prevent possible disasters with symbolic links.
+        
+-- For useful info on the template language, see
+-- https://theantlrguy.atlassian.net/wiki/display/ST4/StringTemplate+cheat+sheet
+-- NOTE: due to a bug in HStringTemplate's checkTemplateDeep, non-existent attribute names on
+--       composite attributes in anonymous templates will hang the generator :-(
+--       Eg.  "$subObjects:{subObj| .. $subObj.nonExistentField$ .. }$"
+
+doGenFrontend :: FSpec -> IO ()
+doGenFrontend fSpec =
+ do { putStrLn "Generating new frontend.." 
+    ; copyIncludes fSpec
+    ; feInterfaces <- buildInterfaces fSpec
+    ; genView_Interfaces fSpec feInterfaces
+    ; genController_Interfaces fSpec feInterfaces
+    ; genRouteProvider fSpec feInterfaces
+    }
+
+copyIncludes :: FSpec -> IO ()
+copyIncludes fSpec =
+ do { let adlSourceDir = takeDirectory $ fileName (getOpts fSpec)
+          includeDir = adlSourceDir </> "include"
+          protoDir = Opts.dirPrototype (getOpts fSpec)
+    ; includeDirExists <- doesDirectoryExist $ includeDir
+    ; if includeDirExists then
+       do { putStrLn $ "Copying user includes from " ++ includeDir 
+          ; includeDirContents <- fmap (map (includeDir </>)) $ getProperDirectoryContents includeDir
+          
+          ; let absIncludes = [ Include fOrD absSd (protoDir </> tgtPth)
+                              | Include fOrD srcPth tgtPth <- allowedIncludeSubDirs
+                              , let absSd = includeDir </> srcPth
+                              , absSd `elem` includeDirContents
+                              ]
+                              
+          ; sequence_ [ do { putStrLn $ "  Copying " ++ toFOrDStr fOrD ++ " " ++ srcPth ++ "\n    -> " ++ tgtPth
+                           ; case fOrD of
+                               File -> copyDeepFile srcPth tgtPth
+                               Dir  -> copyDirRecursively srcPth tgtPth
+                           }
+                      | Include fOrD srcPth tgtPth <- absIncludes
+                      ]
+                      
+          ; let ignoredPaths = includeDirContents \\ map includeSrc absIncludes
+          ; when (not $ null ignoredPaths) $
+             do { putStrLn $ "\nWARNING: only the following include/ paths are allowed:\n  " ++ show (map includeSrc allowedIncludeSubDirs) ++ "\n"
+                ; mapM_ (\d -> putStrLn $ "  Ignored " ++ d) $ ignoredPaths
+                }
+          }
+      else
+        putStrLn $ "No user includes (there is no directory " ++ includeDir ++ ")"
+    } 
+  where toFOrDStr File = "file"
+        toFOrDStr Dir  = "directory"
+        
+------ Build intermediate data structure
+
+-- NOTE: _ disables 'not used' warning for fields
+data FEInterface = FEInterface { ifcName :: String
+                               , _ifcMClass :: Maybe String 
+                               , _ifcExp :: Expression, _ifcSource :: A_Concept, _ifcTarget :: A_Concept
+                               , _ifcRoles :: [Role], _ifcEditableRels :: [Declaration], _ifcObj :: FEObject }
+
+data FEObject = FEObject { objName :: String
+                         , objExp :: Expression, objSource :: A_Concept, objTarget :: A_Concept
+                         , objIsEditable :: Bool, _exprIsUni :: Bool, _exprIsTot :: Bool, _exprIsProp :: Bool
+                         , _objNavInterfaces :: [NavInterface]
+                         , atomicOrBox :: FEAtomicOrBox } deriving Show
+
+-- Once we have mClass also for Atomic, we can get rid of FEAtomicOrBox and pattern match on _ifcSubIfcs to determine atomicity.
+data FEAtomicOrBox = FEAtomic { objMPrimTemplate :: Maybe (String, [String]) }
+                   | FEBox    {  _objMClass :: Maybe String, ifcSubObjs :: [FEObject] } deriving Show
+
+data NavInterface = NavInterface { _navIfcName :: String, _navIfcRoles :: [Role] } deriving Show
+
+flatten :: FEObject -> [FEObject]
+flatten obj = obj : concatMap flatten subObjs
+  where subObjs = case atomicOrBox obj of
+                    FEAtomic{}                 -> []
+                    FEBox{ ifcSubObjs = objs } -> objs 
+
+buildInterfaces :: FSpec -> IO [FEInterface]
+buildInterfaces fSpec = mapM (buildInterface fSpec allIfcs) allIfcs
+  where
+    allIfcs :: [Interface]
+    allIfcs = interfaceS fSpec
+            
+buildInterface :: FSpec -> [Interface] -> Interface -> IO FEInterface
+buildInterface fSpec allIfcs ifc =
+ do { let editableRels = ifcParams ifc
+    ; obj <- buildObject editableRels (ifcObj ifc)
+    ; return $
+        FEInterface (name ifc) (ifcClass ifc) (objExp obj) (objSource obj) (objTarget obj) (ifcRoles ifc) editableRels obj
+    -- NOTE: due to Amperand's interface data structure, expression, source, and target are taken from the root object. 
+    --       (name comes from interface, but is equal to object name)
+    } 
+  where    
+    buildObject :: [Declaration] -> ObjectDef -> IO FEObject
+    buildObject editableRels object =
+     do { let iExp = conjNF (getOpts fSpec) $ objctx object
+              
+        ; (aOrB, iExp', isEditable, src, tgt) <-
+            case objmsub object of
+              Nothing                  ->
+               do { let (isEditable, src, tgt) = getIsEditableSrcTgt iExp
+                  ; let mView = case objmView object of
+                                  Just nm -> Just $ lookupView fSpec nm
+                                  Nothing -> getDefaultViewForConcept fSpec tgt
+                  ; mSpecificTemplatePath <-
+                          case mView of
+                            Just Vd{vdhtml=Just (ViewHtmlTemplateFile fName), vdats=viewSegs}
+                              -> return $ Just ("views" </> fName, [ viewAttr | ViewExp Obj{objnm=viewAttr} <- viewSegs])
+                            _ -> -- no view, or no view with an html template, so we fall back to target-concept template
+                                 -- TODO: once we can encode all specific templates with views, we will probably want to remove this fallback
+                             do { let templatePath = "views/Atomic-" ++ (escapeIdentifier $ name tgt) ++ ".html"
+                                ; hasSpecificTemplate <- doesTemplateExist fSpec $ templatePath
+                                ; return $ if hasSpecificTemplate then Just (templatePath, []) else Nothing
+                                }
+                  ; return (FEAtomic mSpecificTemplatePath, iExp, isEditable, src, tgt)
+                  }
+              Just (Box _ mCl objects) -> 
+               do { let (isEditable, src, tgt) = getIsEditableSrcTgt iExp
+                  ; subObjs <- mapM (buildObject editableRels) objects
+                  ; return (FEBox mCl subObjs, iExp, isEditable, src, tgt)
+                  }
+              Just (InterfaceRef nm)   -> 
+                case filter (\rIfc -> name rIfc == nm) $ allIfcs of -- Follow interface ref
+                  []      -> fatal 44 $ "Referenced interface " ++ nm ++ " missing"
+                  (_:_:_) -> fatal 45 $ "Multiple declarations of referenced interface " ++ nm
+                  [i]     -> do { let editableRels' = editableRels `intersect` ifcParams i
+                                ; refObj <- buildObject editableRels' (ifcObj i)
+                                ; let comp = ECps (iExp, objExp refObj) 
+                                      -- Dont' normalize, to prevent unexpected effects (if X;Y = I then ((rel;X) ; (Y)) might normalize to rel)
+                                      (isEditable, src, tgt) = getIsEditableSrcTgt comp
+                                ; return (atomicOrBox refObj, comp, isEditable, src, tgt)
+                                } -- TODO: in Generics.php interface refs create an implicit box, which may cause problems for the new front-end
+
+        ; let navIfcs = [ NavInterface (name nIfc) nRoles -- only consider interfaces that share roles with the one we're building 
+                        | nIfc <- allIfcs
+                        , (source . objctx . ifcObj $ nIfc) == tgt
+                        , let nRoles = ifcRoles nIfc `intersect` ifcRoles ifc
+                        ]
+
+        ; return $ FEObject (name object) iExp' src tgt isEditable (isUni iExp') (isTot iExp') (isProp iExp') navIfcs aOrB
+        }
+      where getIsEditableSrcTgt expr = 
+              case getExpressionRelation expr of
+                Nothing                          -> (False,                    source expr, target expr)
+                Just (declSrc, decl, declTgt, _) -> (decl `elem` editableRels, declSrc,     declTgt    ) 
+                                                   -- if the expression is a relation, use the (possibly narrowed type) from getExpressionRelation
+
+------ Generate RouteProvider.js
+
+genRouteProvider :: FSpec -> [FEInterface] -> IO ()
+genRouteProvider fSpec ifcs =
+ do { --verboseLn (getOpts fSpec) $ show $ map name (interfaceS fSpec)
+    ; template <- readTemplate fSpec "RouteProvider.js"
+    ; let contents = renderTemplate template $
+                       setAttribute "contextName"         (fsName fSpec)
+                     . setAttribute "interfaceNames"      (map (escapeIdentifier . ifcName) ifcs)
+                     . setAttribute "ampersandVersionStr" ampersandVersionStr
+
+    ; writePrototypeFile fSpec ("app/RouteProvider.js") $ contents 
+    }
+    
+    
+------ Generate view html code
+
+genView_Interfaces :: FSpec -> [FEInterface] -> IO ()
+genView_Interfaces fSpec ifcs =
+ do { mapM_ (genView_Interface fSpec) $ ifcs
+    }
+
+genView_Interface :: FSpec -> FEInterface -> IO ()
+genView_Interface fSpec (FEInterface iName _ iExp iSrc iTgt roles editableRels obj) =
+ do { --verboseLn (getOpts fSpec) $ "\nTop-level interface: " ++ show iName ++ " [" ++ name iSrc ++ "*"++ name iTgt ++ "] "
+    ; lns <- genView_Object fSpec 0 obj
+    ; template <- readTemplate fSpec "views/Interface.html"
+    ; let contents = renderTemplate template $
+                       setAttribute "contextName"         (addSlashes $ fsName fSpec)
+                     . setAttribute "isTopLevel"          (name (source iExp) `elem` ["ONE", "SESSION"])
+                     . setAttribute "roles"               [ show r | r <- roles ] -- show string, since StringTemplate does not elegantly allow to quote and separate
+                     . setAttribute "editableRelations"   [ show $ escapeIdentifier (name r) | r <- editableRels ] -- show name, since StringTemplate does not elegantly allow to quote and separate
+                     . setAttribute "ampersandVersionStr" ampersandVersionStr
+                     . setAttribute "interfaceName"       (escapeIdentifier iName)
+                     . setAttribute "interfaceLabel"      iName -- no escaping for labels in templates needed
+                     . setAttribute "expAdl"              (showADL iExp)
+                     . setAttribute "source"              (escapeIdentifier $ name iSrc)
+                     . setAttribute "target"              (escapeIdentifier $ name iTgt)
+                     . setAttribute "contents"            (intercalate "\n" . indent 4 $ lns) -- intercalate, because unlines introduces a trailing \n
+
+    ; let filename = escapeIdentifier iName ++ ".html" -- filenames with spaces aren't a huge problem, but it's probably safer to prevent them
+    ; writePrototypeFile fSpec ("app/views" </> filename) $ contents 
+    }
+
+-- Helper data structure to pass attribute values to HStringTemplate
+data SubObjectAttr = SubObjAttr { subObjName :: String, subObjLabel :: String, isBLOB ::Bool
+                                , subObjContents :: String } deriving (Show, Data, Typeable)
+ 
+genView_Object :: FSpec -> Int -> FEObject -> IO [String]
+genView_Object fSpec depth obj@(FEObject nm oExp src tgt isEditable exprIsUni exprIsTot exprIsProp navInterfaces _) =
+  let atomicAndBoxAttrs :: StringTemplate String -> StringTemplate String
+      atomicAndBoxAttrs = setAttribute "isEditable" isEditable
+                        . setAttribute "exprIsUni"  exprIsUni
+                        . setAttribute "exprIsTot"  exprIsTot
+                        . setAttribute "exprIsProp" exprIsProp
+                        . setAttribute "name"       (escapeIdentifier nm)
+                        . setAttribute "label"      nm -- no escaping for labels in templates needed
+                        . setAttribute "expAdl"     (showADL oExp) 
+                        . setAttribute "source"     (escapeIdentifier $ name src)
+                        . setAttribute "target"     (escapeIdentifier $ name tgt)
+                    
+  in  case atomicOrBox obj of
+        FEAtomic mPrimTemplate ->
+         do { {-
+              verboseLn (getOpts fSpec) $ replicate depth ' ' ++ "ATOMIC "++show nm ++ 
+                                            " [" ++ name src ++ "*"++ name tgt ++ "], " ++
+                                            (if isEditable then "" else "not ") ++ "editable"
+              -}
+            -- For now, we choose specific template based on target concept. This will probably be too weak. 
+            -- (we might want a single concept to could have multiple presentations, e.g. BOOL as checkbox or as string)
+            --; putStrLn $ nm ++ ":" ++ show mPrimTemplate
+            ; let (templateFilename, viewAttrs) = fromMaybe ("views/Atomic.html", []) mPrimTemplate -- Atomic is the default template
+            ; template <- readTemplate fSpec templateFilename
+                    
+            --; verboseLn (getOpts fSpec) $ unlines [ replicate depth ' ' ++ "-NAV: "++ show n ++ " for "++ show rs 
+            --                                      | NavInterface n rs <- navInterfaces ]
+            ; let mNavInterface = case navInterfaces of -- TODO: do something with roles here. For now, simply use the first interface, if any.
+                                    []                      -> Nothing
+                                    NavInterface iName _ :_ -> Just iName
+                                                                                  
+            ; return $ lines $ renderTemplate template $ 
+                                 atomicAndBoxAttrs
+                               . setManyAttrib [(viewAttr, "{{row['@view']['"++viewAttr++"']}}") | viewAttr <- viewAttrs ] -- TODO: escape/protect
+                               . setAttribute "navInterface" (fmap escapeIdentifier mNavInterface)
+            }
+        FEBox mClass subObjs ->
+         do { {-
+              verboseLn (getOpts fSpec) $ replicate depth ' ' ++ "BOX" ++ maybe "" (\c -> "<"++c++">") mClass ++
+                                            " " ++ show nm ++ " [" ++ name src ++ "*"++ name tgt ++ "], " ++
+                                            (if isEditable then "" else "not ") ++ "editable"
+              -}
+            ; subObjAttrs <- mapM genView_SubObject subObjs
+                    
+            ; let clssStr = maybe "" (\cl -> "-" ++ cl) mClass
+            ; parentTemplate <- readTemplate fSpec $ "views/Box" ++ clssStr ++ ".html"
+            
+            ; return $ lines $ renderTemplate parentTemplate $ 
+                                 atomicAndBoxAttrs
+                               . setAttribute "isRoot"     (depth == 0)
+                               . setAttribute "subObjects" subObjAttrs
+            }
+  where genView_SubObject subObj = 
+         do { lns <- genView_Object fSpec (depth + 1) subObj
+            ; return SubObjAttr{ subObjName = escapeIdentifier $ objName subObj
+                               , subObjLabel = objName subObj -- no escaping for labels in templates needed
+                               , isBLOB = name (target $ objExp subObj) == "BLOB"
+                               , subObjContents = intercalate "\n" $ indent 8 lns
+                               -- Indentation is not context sensitive, so some templates will
+                               -- be indented a bit too much (we take the maximum necessary value now)
+                               } 
+            }
+
+            
+------ Generate controller JavaScript code
+
+genController_Interfaces :: FSpec -> [FEInterface] -> IO ()
+genController_Interfaces fSpec ifcs =
+ do { mapM_ (genController_Interface fSpec) $ ifcs
+    }
+
+genController_Interface :: FSpec -> FEInterface -> IO ()
+genController_Interface fSpec (FEInterface iName _ iExp iSrc iTgt roles editableRels obj) =
+ do { -- verboseLn (getOpts fSpec) $ "\nGenerate controller for " ++ show iName
+    ; let allObjs = flatten obj
+          allEditableNonPrimTargets = nub [ escapeIdentifier $ name (objTarget o) 
+                                        | o@FEObject { atomicOrBox = a@FEAtomic {} } <- allObjs
+                                        , objIsEditable o
+                                        , not . isJust $ objMPrimTemplate a
+                                        ]
+          containsEditable          = any objIsEditable allObjs
+          containsEditableNonPrim   = not $ null allEditableNonPrimTargets
+          containsDATE              = any (\o -> name (objTarget o) == "DATE" && objIsEditable o) allObjs
+          
+    ; template <- readTemplate fSpec "controllers/controller.js"
+    ; let contents = renderTemplate template $
+                       setAttribute "contextName"              (fsName fSpec)
+                     . setAttribute "isRoot"                   (name (source iExp) `elem` ["ONE", "SESSION"])
+                     . setAttribute "roles"                    [ show r | r <- roles ] -- show string, since StringTemplate does not elegantly allow to quote and separate
+                     . setAttribute "editableRelations"        [ show $ escapeIdentifier (name r) | r <- editableRels ] -- show name, since StringTemplate does not elegantly allow to quote and separate
+                     . setAttribute "editableNonPrimTargets"   allEditableNonPrimTargets
+                     . setAttribute "containsDATE"             containsDATE
+                     . setAttribute "containsEditable"         containsEditable
+                     . setAttribute "containsEditableNonPrim"  containsEditableNonPrim
+                     . setAttribute "ampersandVersionStr"      ampersandVersionStr
+                     . setAttribute "interfaceName"            (escapeIdentifier iName)
+                     . setAttribute "expAdl"                   (showADL iExp)
+                     . setAttribute "source"                   (escapeIdentifier $ name iSrc)
+                     . setAttribute "target"                   (escapeIdentifier $ name iTgt)
+
+    ; let filename = (escapeIdentifier iName) ++ ".js"
+    ; writePrototypeFile fSpec ("app/controllers" </> filename) $ contents 
+    }
+    
+    
+------ Utility functions
+
+-- data type to keep template and source file together for better errors
+data Template = Template (StringTemplate String) String
+
+-- TODO: better abstraction for specific template and fallback to default
+doesTemplateExist :: FSpec -> String -> IO Bool
+doesTemplateExist fSpec templatePath =
+ do { let absPath = getTemplateDir fSpec </> templatePath
+    ; doesFileExist absPath
+    }
+ 
+readTemplate :: FSpec -> String -> IO Template
+readTemplate fSpec templatePath =
+ do { let absPath = getTemplateDir fSpec </> templatePath
+    ; res <- readUTF8File $ absPath
+    ; case res of
+        Left err          -> error $ "Cannot read template file " ++ templatePath ++ "\n" ++ err
+        Right templateStr -> return $ Template (newSTMP templateStr) absPath
+    }
+
+-- having Bool attributes prevents us from using a [(String, String)] parameter for attribute settings
+renderTemplate :: Template -> (StringTemplate String -> StringTemplate String) -> String
+renderTemplate (Template template absPath) setAttrs =
+  let appliedTemplate = setAttrs template
+  in  case checkTemplateDeep appliedTemplate of
+             ([],  [],    []) -> render appliedTemplate
+             (parseErrs@(_:_), _, _)        -> templateError $ concat [ "Parse error in " ++ tmplt ++ " " ++ err ++ "\n" 
+                                                                      | (tmplt,err) <- parseErrs]
+             ([], attrs@(_:_), _)        -> templateError $ "Uninitialized template attributes: " ++ show attrs
+             ([], [], ts@(_:_)) -> templateError $ "Missing invoked templates: " ++ show ts -- should not happen as we don't invoke templates
+  where templateError msg = error $ "\n\n*** TEMPLATE ERROR in:\n" ++ absPath ++ "\n\n" ++ msg

+ src/Database/Design/Ampersand/Prototype/Generate.hs view
@@ -0,0 +1,617 @@+module Database.Design.Ampersand.Prototype.Generate (generateGenerics, generateCustomCss) where
+
+import Database.Design.Ampersand
+import Database.Design.Ampersand.Core.AbstractSyntaxTree
+import Prelude hiding (writeFile,readFile,getContents,exp)
+import Data.Function
+import Data.List
+import Data.Maybe
+import Control.Monad
+import System.FilePath
+import System.Directory
+import Database.Design.Ampersand.FSpec.SQL
+import Database.Design.Ampersand.FSpec.FSpecAux
+import Database.Design.Ampersand.FSpec.FSpec
+import Database.Design.Ampersand.Prototype.ProtoUtil
+import qualified Database.Design.Ampersand.Prototype.ValidateEdit as ValidateEdit 
+import Database.Design.Ampersand.Prototype.PHP (getTableName, signalTableSpec)
+import Control.Exception
+
+fatal :: Int -> String -> a
+fatal = fatalMsg "Generate"
+
+
+generateCustomCss :: FSpec -> IO ()
+generateCustomCss fSpec =
+ do { when (genStaticFiles (getOpts fSpec)) $
+        case customCssFile (getOpts fSpec) of
+          Just customCssFilePath ->
+           do { customCssContents <- readCustomCssFile customCssFilePath
+              ; writePrototypeFile fSpec generatedCustomCssPath customCssContents
+              }
+          Nothing -> -- If no css file is specified, we use <filename>.css, if it exists.
+           do { let dedicatedCSSPath = replaceExtension (fileName (getOpts fSpec)) "css"
+              ; dedicatedCSSExists <- doesFileExist dedicatedCSSPath
+              ; if dedicatedCSSExists then
+                 do { putStrLn $ "  Found " ++ dedicatedCSSPath ++ ", which will be used as Custom.css."
+                    ; customCssContents <- readCustomCssFile dedicatedCSSPath
+                    ; writePrototypeFile fSpec generatedCustomCssPath customCssContents
+                    }
+                else -- If not, we check whether there is a css/Custom.css in the prototype directory and create a default one if there isn't.
+                 do { customExists <- doesFileExist $ getGenericsDir fSpec </> generatedCustomCssPath
+                    ; if customExists
+                      then verboseLn (getOpts fSpec) $ "  File " ++ generatedCustomCssPath ++ " already exists."
+                      else do { verboseLn (getOpts fSpec) $ "  File " ++ generatedCustomCssPath ++ 
+                                                            " does not exist, creating default for Oblomilan style."
+                              ; writePrototypeFile fSpec generatedCustomCssPath "@import url(\"Oblomilan.css\");"
+                              }
+                    }
+              }
+    }
+  where
+    generatedCustomCssPath = "css/Custom.css"
+
+    readCustomCssFile f =
+      catch (readFile f)
+            (\e -> do let err = show (e :: IOException)
+                      _ <- fatal 75 ("ERROR: Cannot open custom css file ' " ++ f ++ "': " ++ err)
+                      return "")
+
+-- Generate Generics.php
+generateGenerics :: FSpec -> IO ()
+generateGenerics fSpec =
+ do { let filecontent = genPhp "Generate.hs" "Generics.php" genericsPhpContent
+--  ; verboseLn (getOpts fSpec) filecontent
+    ; writePrototypeFile fSpec "Generics.php" filecontent
+    }
+ where    
+    genericsPhpContent :: [String]
+    genericsPhpContent =
+      intercalate [""]
+        [ generateConstants fSpec
+        , generateDBstructQueries fSpec
+        , generateAllDefPopQueries fSpec
+        , generateSpecializations fSpec
+        , generateTableInfos fSpec
+        , generateRules fSpec
+        , generateConjuncts fSpec
+        , generateRoles fSpec
+        , generateViews fSpec
+        , generateInterfaces fSpec
+        ]
+        
+generateConstants :: FSpec -> [String]
+generateConstants fSpec =
+  [ "$versionInfo = "++showPhpStr ampersandVersionStr++";" -- so we can show the version in the php-generated html
+  , ""
+  , "$contextName = " ++ showPhpStr (fsName fSpec) ++ ";"
+  , ""
+  , "$dbName =  isset($isValidationSession) && $isValidationSession ? "++showPhpStr ValidateEdit.tempDbName++" : "++showPhpStr (dbName opts)++";"
+  , "// If this script is called with $isValidationSession == true, use the temporary db name instead of the normal one." 
+  , ""
+  , "$signalTableName = "++showPhpStr (getTableName signalTableSpec)++";"
+  , ""
+  , "$isDev = "++showPhpBool (development opts)++";"
+  , ""
+  , "$autoRefreshInterval = "++showPhpStr (show $ fromMaybe 0 $ autoRefresh opts)++";"
+  ]
+  where opts = getOpts fSpec
+  
+generateDBstructQueries :: FSpec -> [String]
+generateDBstructQueries fSpec =
+  [ "$allDBstructQueries ="
+  ]++lines ( "  array ( " ++ intercalate "\n        , " (map showPhpStr theSQLstatements))
+   ++
+  [          "        );"
+  ]
+  where
+    theSQLstatements :: [String]
+    theSQLstatements =
+       createTableStatements ++
+       [ "SET TRANSACTION ISOLATION LEVEL SERIALIZABLE"
+       ]
+    createTableStatements :: [String]
+    createTableStatements = 
+      map (intercalate "\n         ")
+      [ [ "CREATE TABLE "++ show "__SessionTimeout__"
+        , "   ( "++show "SESSION"++" VARCHAR(255) UNIQUE NOT NULL"
+        , "   , "++show "lastAccess"++" BIGINT NOT NULL"
+        , "   ) ENGINE=InnoDB DEFAULT CHARACTER SET UTF8"
+        ]
+      , [ "CREATE TABLE "++ show "__History__"
+        , "   ( "++show "Seconds"++" VARCHAR(255) DEFAULT NULL"
+        , "   , "++show "Date"++" VARCHAR(255) DEFAULT NULL"
+        , "   ) ENGINE=InnoDB DEFAULT CHARACTER SET UTF8"
+        ]
+      , [ "INSERT INTO "++show "__History__"++" ("++show "Seconds"++","++show "Date"++")"
+        , "   VALUES (UNIX_TIMESTAMP(NOW(6)), NOW(6))"
+        ]
+      , [ "CREATE TABLE "++ show "__all_signals__"
+        , "   ( "++show "conjId"++" VARCHAR(255) NOT NULL"
+        , "   , "++show "src"++" VARCHAR(255) NOT NULL"
+        , "   , "++show "tgt"++" VARCHAR(255) NOT NULL"
+        , "   ) ENGINE=InnoDB DEFAULT CHARACTER SET UTF8"
+        ]
+      ] ++ 
+      ( concatMap tableSpec2Queries [(plug2TableSpec p) | InternalPlug p <- plugInfos fSpec])
+     
+      where 
+        tableSpec2Queries :: TableSpecNew -> [String]
+        tableSpec2Queries ts = 
+         -- [ "DROP TABLE "++show (tsName ts)] ++
+          [ intercalate "\n           " $  
+                   ( tsCmnt ts ++ 
+                     ["CREATE TABLE "++show (tsName ts)] 
+                     ++ (map (uncurry (++)) 
+                            (zip (" ( ": repeat " , " ) 
+                                 (  map fld2sql (tsflds ts)
+                                 ++ tsKey ts
+                                 )
+                            )
+                        )
+                     ++ [" )"]
+                   )
+          ]
+        fld2sql :: SqlField -> String
+        fld2sql = fieldSpec2Str . fld2FieldSpec
+
+data TableSpecNew 
+  = TableSpec { tsCmnt :: [String]
+              , tsName :: String
+              , tsflds :: [SqlField]
+              , tsKey  :: [String]
+              , tsEngn :: String
+              }
+data FieldSpecNew
+  = FieldSpec { fsname :: String
+              , fstype :: String
+              , fsauto :: Bool
+              }
+fld2FieldSpec ::SqlField -> FieldSpecNew
+fld2FieldSpec fld 
+  = FieldSpec { fsname = name fld
+              , fstype = showSQL (fldtype fld)
+              , fsauto = fldauto fld 
+              }
+fieldSpec2Str :: FieldSpecNew -> String
+fieldSpec2Str fs = intercalate " "
+                    [ show (fsname fs)
+                    , fstype fs
+                    , if fsauto fs then " AUTO_INCREMENT" else " DEFAULT NULL"
+                    ] 
+plug2TableSpec :: PlugSQL -> TableSpecNew
+plug2TableSpec plug 
+  = TableSpec 
+     { tsCmnt = commentBlockSQL (["Plug "++name plug,"","fields:"]++map (\x->showADL (fldexpr x)++"  "++show (multiplicities $ fldexpr x)) (plugFields plug))
+     , tsName = name plug
+     , tsflds = plugFields plug
+     , tsKey  = case (plug, (head.plugFields) plug) of
+                 (BinSQL{}, _)   -> []
+                 (_,    primFld) ->
+                      case flduse primFld of
+                         TableKey isPrim _ -> [ (if isPrim then "PRIMARY " else "")
+                                                ++ "KEY ("++(show . fldname) primFld++")"
+                                        ]
+                         ForeignKey c  -> fatal 195 ("ForeignKey "++name c++"not expected here!")
+                         PlainAttr     -> []
+     , tsEngn = "InnoDB DEFAULT CHARACTER SET UTF8"
+     }
+
+commentBlockSQL :: [String] -> [String]
+commentBlockSQL xs = 
+   map ("-- "++) $ hbar ++ xs ++ hbar
+  where hbar = [replicate (maximum . map length $ xs) '-']
+  
+generateAllDefPopQueries :: FSpec -> [String]
+generateAllDefPopQueries fSpec =
+  [ "$allDefPopQueries ="
+  ]++lines ( "  array ( " ++ intercalate "\n        , " (map showPhpStr theSQLstatements))
+   ++
+  [          "        );"
+  ]
+  where
+    theSQLstatements
+      = fillSignalTable (initialConjunctSignals fSpec) ++
+        populateTablesWithPops
+        
+
+    fillSignalTable :: [(Conjunct, [Paire])] -> [String]
+    fillSignalTable [] = []
+    fillSignalTable conjSignals 
+     = [intercalate "\n           " $ 
+            [ "INSERT INTO "++show (getTableName signalTableSpec)
+            , "   ("++intercalate ", " (map show ["conjId","src","tgt"])++")"
+            ] ++ lines 
+              ( "VALUES " ++ intercalate "\n     , " 
+                  [ "(" ++intercalate ", " (map showAsValue [rc_id conj, srcPaire p, trgPaire p])++ ")" 
+                  | (conj, viols) <- conjSignals
+                  , p <- viols
+                  ]
+              )
+       ]
+    populateTablesWithPops :: [String]
+    populateTablesWithPops =
+      concatMap populatePlug [p | InternalPlug p <- plugInfos fSpec]
+      where
+        populatePlug :: PlugSQL -> [String]
+        populatePlug plug 
+          = case tblcontents (vgens fSpec) (initialPops fSpec) plug of
+             []  -> []
+             tblRecords 
+                 -> [intercalate "\n           " $ 
+                       [ "INSERT INTO "++show (name plug)
+                       , "   ("++intercalate ", " (map (show . fldname) (plugFields plug))++")"
+                       ] ++ lines
+                         ( "VALUES " ++ intercalate "\n     , " 
+                          [ "(" ++valuechain md++ ")" | md<-tblRecords]
+                         )
+                    ]
+         where
+           valuechain record 
+             = intercalate ", " 
+                 [case fld of 
+                    Nothing -> "NULL"
+                    Just str -> showAsValue str
+                 | fld <- record ]
+
+
+generateSpecializations :: FSpec -> [String]
+generateSpecializations fSpec =
+  [ "$allSpecializations = // transitive, so including specializations of specializations"
+  , "  array" ] ++
+  addToLastLine ";"
+    (indent 4 (blockParenthesize "(" ")" ","
+         [ [ showPhpStr (name cpt)++" => array ("++ intercalate ", " (map (showPhpStr . name) specializations) ++")" ]
+         | cpt <- concs fSpec, let specializations = smallerConcepts (vgens fSpec) cpt,  not ( null specializations) ])
+    )
+
+generateTableInfos :: FSpec -> [String]
+generateTableInfos fSpec =
+  [ "$allRelations ="
+  , "  array" ] ++
+  addToLastLine ";"
+    (indent 4 (blockParenthesize "(" ")" ","
+         [ [showPhpStr (showHSName decl)++" => array ( 'name'       => "++showPhpStr (name decl)
+                                                 ++ ", 'srcConcept' => "++showPhpStr (name (source decl))
+                                                 ++ ", 'tgtConcept' => "++showPhpStr (name (target decl))
+                                                 ++ ", 'table'      => "++showPhpStr (name table)
+                                                 ++ ", 'srcCol'     => "++showPhpStr (fldname srcCol)
+                                                 ++ ", 'tgtCol'     => "++showPhpStr (fldname tgtCol)
+                                                 ++ ", 'affectedInvConjunctIds' => array ("++ intercalate ", " (map (showPhpStr . rc_id) affInvConjs) ++")"
+                                                 ++ ", 'affectedSigConjunctIds' => array ("++ intercalate ", " (map (showPhpStr . rc_id) affSigConjs) ++")"
+                                                 ++ ")"]
+         | decl@Sgn{} <- allDecls fSpec  -- SJ 13 nov 2013: changed to generate all relations instead of just the ones used.
+         , let (table,srcCol,tgtCol) = getDeclarationTableInfo fSpec decl
+         , let affConjs = case lookup decl $ allConjsPerDecl fSpec of
+                 Nothing    -> []
+                 Just conjs -> conjs
+               affInvConjs = filterFrontEndInvConjuncts affConjs
+               affSigConjs = filterFrontEndSigConjuncts affConjs 
+         ])) ++
+  [ ""
+  , "$allConcepts = array"
+  ] ++
+  addToLastLine ";"
+    (indent 2 $
+       blockParenthesize "(" ")" ","
+         [ [ (showPhpStr.name) c++" => array"] ++
+           (indent 2 $
+              [ "( 'affectedInvConjunctIds' => array ("++ intercalate ", " (map (showPhpStr . rc_id) affInvConjs) ++")"
+              , ", 'affectedSigConjunctIds' => array ("++ intercalate ", " (map (showPhpStr . rc_id) affSigConjs) ++")"
+              , ", 'conceptTables' => array" ] ++
+              (indent 3
+                (blockParenthesize "(" ")" ","
+                  [ [ "array ( 'table' => "++(showPhpStr.name) table ++
+                            ", 'cols' => array ("++ intercalate ", " (map (showPhpStr . fldname) conceptFields) ++")" ++
+                           " )"
+                    ]
+                  -- get the concept tables (pairs of table and column names) for the concept and its generalizations and group them per table name
+                  | (table,conceptFields) <- groupOnTable . concatMap (lookupCpt fSpec) $ c : largerConcepts (vgens fSpec) c
+                  ])) ++
+              [ ")" ]
+           )
+         | c <- concs fSpec
+         , let affConjs = case lookup c $ allConjsPerConcept fSpec of
+                 Nothing    -> []
+                 Just conjs -> conjs
+               affInvConjs = filterFrontEndInvConjuncts affConjs
+               affSigConjs = filterFrontEndSigConjuncts affConjs 
+
+         ]
+    ) ++
+  [ ""
+  , "$tableColumnInfo ="
+  , "  array"
+  ] ++
+  addToLastLine ";"
+    (indent 4
+       (blockParenthesize "(" ")" ","
+         [ [ (showPhpStr.name) plug++" =>"
+           , "  array"
+           ] ++
+           indent 4
+              (blockParenthesize "(" ")" ","
+                [ [ (showPhpStr.fldname) field++ " => array ( 'concept' => "++(showPhpStr.name.target.fldexpr) field++
+                                                           ", 'unique' => " ++(showPhpBool.flduniq)            field++
+                                                           ", 'null' => "  ++ (showPhpBool.fldnull)            field++
+                                                           ")"
+                  ]
+                | field <- plugFields plug]
+              )
+         | InternalPlug plug <- plugInfos fSpec
+         ]
+     )  )
+ where groupOnTable :: [(PlugSQL,SqlField)] -> [(PlugSQL,[SqlField])]
+       groupOnTable tablesFields = [(t,fs) | (t:_, fs) <- map unzip . groupBy ((==) `on` fst) $ sortBy (\(x,_) (y,_) -> name x `compare` name y) tablesFields ]
+
+generateRules :: FSpec -> [String]
+generateRules fSpec =
+  [ "$allRules ="
+  , "  array"
+  ] ++
+  addToLastLine ";"
+    (indent 4
+      (blockParenthesize  "(" ")" ","
+         [ [ (showPhpStr.rrnm) rule ++ " =>"
+           , "  array ( 'name'          => "++(showPhpStr.rrnm)              rule
+           , "        , 'ruleAdl'       => "++(showPhpStr.showADL.rrexp)     rule
+           , "        , 'origin'        => "++(showPhpStr.show.rrfps)        rule
+           , "        , 'meaning'       => "++(showPhpStr.showMeaning)       rule
+           , "        , 'message'       => "++(showPhpStr.showMessage)       rule
+           , "        , 'srcConcept'    => "++(showPhpStr.name.source.rrexp) rule
+           , "        , 'tgtConcept'    => "++(showPhpStr.name.target.rrexp) rule
+           , "        , 'conjunctIds'   => array ("++intercalate ", " (map (showPhpStr . rc_id) conjs) ++")"
+           ] ++
+           ( if development (getOpts fSpec)
+             then [ "        // Rule Ampersand: "++escapePhpStr (showADL rExpr) 
+                  , "        , 'contentsSQL'   => " ++
+                                  let contentsExpr = conjNF (getOpts fSpec) rExpr
+                                  in  showPhpStr (prettySQLQuery fSpec 26 contentsExpr)
+                    -- with --dev, also generate sql for the rule itself (without negation) so it can be tested with
+                    -- php/Database.php?testRule=RULENAME
+                  ]
+             else [] ) ++                  
+           [ "        , 'pairView'      =>" -- a list of sql queries for the pair-view segments
+           , "            array"
+           ] ++
+           indent 14
+             (blockParenthesize "(" ")" ","
+               ((genMPairView.rrviol) rule
+             ) ) ++
+           [ "        )" ]
+         | (rule, conjs) <- allConjsPerRule fSpec
+         , let rExpr=rrexp rule
+         ]
+    ) )
+ where showMeaning rule = maybe "" aMarkup2String (meaning (fsLang fSpec) rule)
+       showMessage rule = case [ markup | markup <- rrmsg rule, amLang markup == fsLang fSpec ] of
+                            []    -> ""
+                            markup:_ -> aMarkup2String markup
+
+       genMPairView Nothing                  = []
+       genMPairView (Just (PairView pvsegs)) = map genPairViewSeg pvsegs
+
+       genPairViewSeg (PairViewText _ str)   = [ "array ( 'segmentType' => 'Text', 'Text' => " ++ showPhpStr str ++ ")" ]
+       genPairViewSeg (PairViewExp _ srcOrTgt exp) =
+         [ "array ( 'segmentType' => 'Exp'"
+         , "      , 'srcOrTgt' => "++showPhpStr (show srcOrTgt)
+         , "      , 'expTgt' => "++showPhpStr (show $ target exp)
+         , "      , 'expSQL' =>"
+         , "          " ++ showPhpStr (prettySQLQuery fSpec 33 exp)
+         , "      )"
+         ]
+
+generateConjuncts :: FSpec -> [String]
+generateConjuncts fSpec =
+  [ "$allConjuncts ="
+  , "  array"
+  ] ++
+  addToLastLine ";"
+     (indent 4
+       (blockParenthesize  "(" ")" ","
+         [ [ showPhpStr (rc_id conj) ++ " =>"
+           , "  array ( 'signalRuleNames' => array ("++ intercalate ", " signalRuleNames ++")"
+           , "        , 'invariantRuleNames' => array ("++ intercalate ", " invRuleNames ++")"
+                      -- the name of the rules that gave rise to this conjunct
+           ] ++
+           ( if verboseP (getOpts fSpec)
+             then   ["        // Normalization steps:"]
+                  ++["        // "++ls | ls<-(showPrf showADL . cfProof (getOpts fSpec)) violExpr]
+                  ++["        // "]
+             else   [] ) ++
+           ( if development (getOpts fSpec)
+             then [ "        // Conjunct Ampersand: "++escapePhpStr (showADL rExpr) ] ++
+                  [ "        // Normalized complement (== violationsSQL): " ] ++
+                  (lines ( "        // "++(showHS (getOpts fSpec) "\n        // ") violationsExpr))
+             else [] ) ++
+           [ "        , 'violationsSQL' => "++ showPhpStr (prettySQLQuery fSpec 36 violationsExpr)
+           , "        )"
+           ]
+         | conj<-vconjs fSpec
+         , let rExpr=rc_conjunct conj
+         , let signalRuleNames = [ showPhpStr $ name r | r <- rc_orgRules conj, isFrontEndSignal r ] 
+         , let invRuleNames    = [ showPhpStr $ name r | r <- rc_orgRules conj, isFrontEndInvariant  r ]
+         , let violExpr = notCpl rExpr
+         , let violationsExpr = conjNF (getOpts fSpec) violExpr
+         ]
+     ) )
+
+-- Because the signal/invariant condition appears both in generateConjuncts and generateInterface, we use
+-- two abstractions to guarantee the same implementation.
+isFrontEndInvariant :: Rule -> Bool
+isFrontEndInvariant r = not (isSignal r) && not (ruleIsInvariantUniOrInj r)
+
+isFrontEndSignal :: Rule -> Bool
+isFrontEndSignal r = isSignal r
+
+-- NOTE that results from filterFrontEndInvConjuncts and filterFrontEndSigConjuncts may overlap (conjunct appearing in both invariants and signals)
+-- and that because of extra condition in isFrontEndInvariant (not (ruleIsInvariantUniOrInj r)), some parameter conjuncts may not be returned
+-- as either inv or sig conjuncts (i.e. conjuncts that appear only in uni or inj rules) 
+filterFrontEndInvConjuncts :: [Conjunct] -> [Conjunct]
+filterFrontEndInvConjuncts conjs = filter (\c -> any isFrontEndInvariant $ rc_orgRules c) conjs
+
+filterFrontEndSigConjuncts :: [Conjunct] -> [Conjunct]
+filterFrontEndSigConjuncts conjs = filter (\c -> any isFrontEndSignal $ rc_orgRules c) conjs
+  
+generateRoles :: FSpec -> [String]
+generateRoles fSpec =
+  [ "$allRoles ="
+  , "  array"
+  ] ++
+  addToLastLine ";"
+    (indent 4
+      (blockParenthesize  "(" ")" ","
+         [ [ "array ( 'name' => "++showPhpStr (name role)
+           , "      , 'ruleNames' => array ("++ intercalate ", " ((map (showPhpStr . name . snd) . filter (maintainedByRole role) . fRoleRuls) fSpec) ++")"
+           , "      )" ]
+         | role <- fRoles fSpec ]
+    ) )
+  where maintainedByRole role (role',_) = role == role'
+
+generateViews :: FSpec -> [String]
+generateViews fSpec =
+  [ "//$allViews is sorted from spec to gen such that the first match for a concept will be the most specific (e.g. see DatabaseUtils.getView())."
+  , "$allViews ="
+  , "  array"
+  ] ++
+  addToLastLine ";"
+    (indent 4
+      (blockParenthesize  "(" ")" ","
+         [ [ "  array ( 'label' => "++showPhpStr label
+           , "        , 'concept' => "++showPhpStr (name cpt)
+           , "        , 'isDefault' => "++showPhpBool isDefault
+           , "        , 'segments' =>" -- a labeled list of sql queries for the view expressions
+           , "            array"
+           ] ++
+           indent 14 (blockParenthesize "(" ")" "," (map genViewSeg viewSegs)) ++
+           [ "        )" ]
+         | Vd _ label cpt isDefault  _ viewSegs <- [ v | c<-conceptsFromSpecificToGeneric, v <- vviews fSpec, vdcpt v==c ] --sort from spec to gen
+         ]
+    ) )
+ where genViewSeg (ViewText str)   = [ "array ( 'segmentType' => 'Text', 'Text' => " ++ showPhpStr str ++ ")" ]
+       genViewSeg (ViewHtml str)   = [ "array ( 'segmentType' => 'Html', 'Html' => " ++ showPhpStr str ++ ")" ]
+       genViewSeg (ViewExp objDef) = [ "array ( 'segmentType' => 'Exp'"
+                                     , "      , 'label' => " ++ showPhpStr (objnm objDef) ++ " // view exp: " ++ escapePhpStr (showADL $ objctx objDef) -- note: unlabeled exps are labeled by (index + 1)
+                                     , "      , 'expSQL' =>"
+                                     , "          " ++ showPhpStr (prettySQLQuery fSpec 33 (objctx objDef))
+                                     , "      )"
+                                   ]
+       conceptsFromSpecificToGeneric = concatMap reverse (kernels fSpec)
+
+generateInterfaces :: FSpec -> [String]
+generateInterfaces fSpec =
+  [ "$allInterfaceObjects ="
+  , "  array"
+  ] ++
+  addToLastLine ";"
+     (indent 4
+       (blockParenthesize  "(" ")" ","
+         (map (generateInterface fSpec) (interfaceS fSpec ++ interfaceG fSpec))
+     ) )
+
+generateInterface :: FSpec -> Interface -> [String]
+generateInterface fSpec interface =
+  let roleStr = case ifcRoles interface of []    -> " for all roles"
+                                           rolez -> " for role"++ (if length rolez == 1 then "" else "s") ++" " ++ intercalate ", " (map name (ifcRoles interface))
+      arrayKey | newFrontend $ getOpts fSpec = escapeIdentifier $ name interface -- For new front-end only, index on escaped name (id)
+               | otherwise                   = name interface                    -- otherwise, use normal name to prevent breakage on old prototypes
+  in  ["// Top-level interface " ++ name interface ++ roleStr  ++ ":"
+      , showPhpStr arrayKey ++ " => " 
+      ] ++
+  indent 2 (genInterfaceObjects fSpec (ifcParams interface) (Just $ topLevelFields) 1 (ifcObj interface))
+  where topLevelFields = -- for the top-level interface object we add the following fields (saves us from adding an extra interface node to the php data structure)
+          [ "      , 'interfaceRoles' => array (" ++ intercalate ", " (map (showPhpStr.name) $ ifcRoles interface) ++")" 
+          , "      , 'invConjunctIds' => array ("++intercalate ", " (map (showPhpStr . rc_id) $ invConjuncts) ++")"
+          , "      , 'sigConjunctIds' => array ("++intercalate ", " (map (showPhpStr . rc_id) $ sigConjuncts) ++")"
+          ]
+        invConjuncts = [ c | c <- ifcControls interface, any isFrontEndInvariant $ rc_orgRules c ] -- NOTE: these two
+        sigConjuncts = [ c | c <- ifcControls interface, any isFrontEndSignal    $ rc_orgRules c ] --       may overlap
+
+genInterfaceObjects :: FSpec -> [Declaration] -> Maybe [String] -> Int -> ObjectDef -> [String]
+genInterfaceObjects fSpec editableRels mTopLevelFields depth object =
+     [ "array ( 'name'  => "++ showPhpStr (name object)
+     , "      , 'id'    => " ++ show (escapeIdentifier $ name object) -- only for new front-end
+     , "      , 'label' => " ++ showPhpStr (name object)              -- only for new front-end
+     ]
+  ++ maybe [] (\viewId -> ["      , 'viewId' => " ++ showPhpStr viewId]) mViewId 
+  ++ (if verboseP (getOpts fSpec)  -- previously, this included the condition        objctx object /= normalizedInterfaceExp
+      then    ["      // Normalization steps:"]
+           ++ ["      // "++ls | ls<-(showPrf showADL.cfProof (getOpts fSpec).objctx) object] -- let's hope that none of the names in the relation contains a newline
+           ++ ["      //"]
+      else    []
+     )
+  ++ ["      // Normalized interface expression (== expressionSQL): "++escapePhpStr (showADL normalizedInterfaceExp) ]
+  ++ ["      // normalizedInterfaceExp = " ++ show normalizedInterfaceExp | development (getOpts fSpec) ]
+             -- escape for the pathological case that one of the names in the relation contains a newline
+  ++ fromMaybe [] mTopLevelFields -- declare extra fields if this is a top level interface object
+  ++ case mEditableDecl of
+           Just (decl, isFlipped) ->
+             [ "      , 'relation' => "++showPhpStr (showHSName decl) ++ " // this interface represents a declared relation"
+             , "      , 'relationIsEditable' => "++ showPhpBool (decl `elem` editableRels) 
+             , "      , 'relationIsFlipped' => "++showPhpBool isFlipped ] ++
+             if isFlipped 
+             then [ "      , 'min' => "++ if isSur decl then "'One'" else "'Zero'"
+                  , "      , 'max' => "++ if isInj decl then "'One'" else "'Many'" ]
+             else [ "      , 'min' => "++ if isTot decl then "'One'" else "'Zero'" 
+                  , "      , 'max' => "++ if isUni decl then "'One'" else "'Many'" ] 
+           Nothing ->
+             [ "      , 'relation' => '' // this interface expression does not represent a declared relation"
+             , "      , 'relationIsFlipped' => ''"
+             ] 
+  ++ [ "      , 'srcConcept' => "++showPhpStr (name srcConcept) -- NOTE: these are src and tgt of the expression, not necessarily the relation (if there is one), 
+     , "      , 'tgtConcept' => "++showPhpStr (name tgtConcept) -- which may be flipped.
+     , "      , 'exprIsUni'     => " ++ showPhpBool (isUni normalizedInterfaceExp) -- We could encode these by creating min/max also for non-editable,
+     , "      , 'exprIsTot'     => " ++ showPhpBool (isTot normalizedInterfaceExp) -- but this is more in line with the new front-end templates.
+     , "      , 'exprIsProp'    => " ++ showPhpBool (isProp normalizedInterfaceExp) 
+     , "      , 'expressionSQL' => " ++ showPhpStr (prettySQLQuery fSpec (22+14*depth) normalizedInterfaceExp)
+     ] 
+  ++ generateMSubInterface fSpec editableRels depth (objmsub object)
+  ++ [ "      )"
+     ]
+ where mViewId = case objmView object of
+                   Just vId -> Just vId
+                   Nothing  -> case getDefaultViewForConcept fSpec tgtConcept of
+                                 Just Vd{vdlbl=vId} -> Just vId
+                                 Nothing            -> Nothing
+       normalizedInterfaceExp = conjNF (getOpts fSpec) $ objctx object
+       (srcConcept, tgtConcept, mEditableDecl) =
+         case getExpressionRelation normalizedInterfaceExp of
+           Just (src, decl, tgt, isFlipped) ->
+             (src, tgt, Just (decl, isFlipped))
+           Nothing -> (source normalizedInterfaceExp, target normalizedInterfaceExp, Nothing) -- fall back to typechecker type
+
+generateMSubInterface :: FSpec -> [Declaration] -> Int -> Maybe SubInterface -> [String]
+generateMSubInterface fSpec editableRels depth subIntf =
+  case subIntf of
+    Nothing                -> [ "      // No subinterfaces" ]
+    Just (InterfaceRef nm) -> [ "      // InterfaceRef"
+                              , "      , 'refSubInterface' => " ++ showPhpStr nm
+                              , "      , 'refSubInterfaceId' => " ++ showPhpStr (escapeIdentifier nm) -- only for new front-end
+                              ]
+    Just (Box _ cl objects) -> [ "      // Box" ++ (maybe "" (\c -> "<"++c++">") cl)
+                               , "      , 'boxSubInterfaces' =>"
+                               , "          array"
+                               ] ++
+                               indent 12
+                                 (blockParenthesize "(" ")" ","
+                                   (map (genInterfaceObjects fSpec editableRels Nothing (depth + 1)) objects))
+
+-- utils
+
+-- generatorModule is the Haskell module responsible for generation, makes it easy to track the origin of the php code
+genPhp :: String -> String -> [String] -> String
+genPhp generatorModule moduleName contentLines = unlines $
+  [ "<?php"
+  , "// module "++moduleName++" generated by "++generatorModule
+  , "// "++ampersandVersionStr
+  ] ++ replicate 2 "" ++ contentLines ++
+  [ "?>"
+  ]
+showAsValue :: String -> String
+showAsValue str = "'"++f str++"'"
+  where f :: String -> String
+        f str'= 
+          case str' of
+            []        -> []
+            ('\'':cs) -> "\\\'"++ f cs  --This is required to ensure that the result of showValue will be a proper singlequoted string.
+            (c:cs)    -> c : f cs

+ src/Database/Design/Ampersand/Prototype/Installer.hs view
@@ -0,0 +1,102 @@+module Database.Design.Ampersand.Prototype.Installer
+  (installerDBstruct,installerDefPop,
+   createTablesPHP,populateTablesPHP) where
+
+import Database.Design.Ampersand
+import Database.Design.Ampersand.Prototype.ProtoUtil
+import Database.Design.Ampersand.Prototype.PHP
+
+--fatal :: Int -> String -> a
+--fatal = fatalMsg "Installer"
+
+installerDBstruct :: FSpec -> String
+installerDBstruct fSpec = unlines $
+      ["<?php"
+      , "// Try to connect to the database"
+      , ""
+      , "include \"dbSettings.php\";"
+      , ""
+      , "$DB_name='"++addSlashes (dbName (getOpts fSpec))++"';"
+      , "$DB_link = mysqli_connect($DB_host,$DB_user,$DB_pass);"
+      , "// Check connection"
+      , "if (mysqli_connect_errno()) {"
+      , "  die(\"Failed to connect to MySQL: \" . mysqli_connect_error());"
+      , "}"
+      , ""
+      ]++setSqlModePHP++
+      [ "// Drop the database if it exists"
+      , "$sql=\"DROP DATABASE $DB_name\";"
+      , "mysqli_query($DB_link,$sql);"
+      , "// Don't bother about the error if the database didn't exist..."
+      , ""
+      , "// Create the database"
+      , "$sql=\"CREATE DATABASE $DB_name DEFAULT CHARACTER SET UTF8\";"
+      , "if (!mysqli_query($DB_link,$sql)) {"
+      , "  die(\"Error creating the database: \" . mysqli_error($DB_link));"
+      , "  }"
+      , ""
+      , "// Connect to the freshly created database"
+      , "$DB_link = mysqli_connect($DB_host,$DB_user,$DB_pass,$DB_name);"
+      , "// Check connection"
+      , "if (mysqli_connect_errno()) {"
+      , "  die(\"Failed to connect to the database: \" . mysqli_connect_error());"
+      , "  }"
+      , ""
+      ]++setSqlModePHP++
+      createTablesPHP fSpec ++
+      [ "mysqli_query($DB_link,'SET TRANSACTION ISOLATION LEVEL SERIALIZABLE');"
+      , "?>"
+      ]
+
+--installerTriggers :: FSpec -> String
+--installerTriggers _ = unlines $
+--      [ "<?php"
+--      , ""
+--      , ""
+--      , "// Array for trigger queries that need to be installed"
+--      , "$queries = array();"
+--      , ""
+--      , ""
+--      ] ++ [] -- something like:     map unlines [ trigger tablename query | ]
+--       ++
+--      [ "$queries[] = \"CREATE TRIGGER etc\";"
+--      , ""
+--      , ""
+--      , ""
+--      , ""
+--      , "// Execute queries"
+--      , "foreach ($queries as $query){"
+--      , " print $query.\"<br/>\";"
+--      , " // $db->Exe($query); "
+--      , " // print($db->error());"
+--      , ""
+--      , "}"
+--      , "?>"
+--      ]
+--  where
+--      trigger tablename query
+--       = [ "// Trigger for DELETE Atom or Pair in function in Concept table"
+--         , "$queries['delete_"++tablename++"']"
+--         , " = \"CREATE TRIGGER `delete_"++tablename++"` BEFORE DELETE ON `"++tablename++"`"
+--         , "    FOR EACH ROW"
+--         , "    BEGIN "
+--         , "        DELETE FROM <other table> WHERE <other table>.<column name> = OLD.<column name>; "
+--         , "    END\";"
+--         ]
+
+installerDefPop :: FSpec -> String
+installerDefPop fSpec = unlines $
+      ["<?php"
+      , "// Connect to the database"
+      , "include \"dbSettings.php\";"
+      , ""
+      , "$DB_link = mysqli_connect($DB_host,$DB_user,$DB_pass,$DB_name);"
+      , "// Check connection"
+      , "if (mysqli_connect_errno()) {"
+      , "  die(\"Failed to connect to the database: \" . mysqli_connect_error());"
+      , "  }"
+      , "$error=false;"
+      ] ++setSqlModePHP++
+      populateTablesPHP fSpec ++
+      ["?>"
+      ]

+ src/Database/Design/Ampersand/Prototype/ObjBinGen.hs view
@@ -0,0 +1,74 @@+{-# LANGUAGE CPP #-}
+module Database.Design.Ampersand.Prototype.ObjBinGen (generatePhp, doGenAtlas, writeStaticFiles) where
+
+import Database.Design.Ampersand.Prototype.Installer           (installerDBstruct,installerDefPop)
+import Database.Design.Ampersand.Prototype.ProtoUtil
+import Database.Design.Ampersand.Prototype.Apps
+import Control.Monad
+import System.FilePath
+import System.Directory
+import qualified Data.ByteString.Char8 as BS
+import Database.Design.Ampersand.Prototype.CoreImporter
+import Prelude hiding (writeFile,readFile,getContents)
+import Database.Design.Ampersand.Prototype.StaticFiles_Generated
+import Database.Design.Ampersand.Prototype.PHP
+
+generatePhp :: FSpec -> IO()
+generatePhp fSpec =
+ do { verboseLn (getOpts fSpec) "---------------------------"
+    ; verboseLn (getOpts fSpec) "Generating php Object files with Ampersand"
+    ; verboseLn (getOpts fSpec) "---------------------------"
+    ; writePrototypeFile fSpec "InstallerDBstruct.php"     (installerDBstruct fSpec)
+--    ; writePrototypeFile fSpec "InstallerTriggers.php"     (installerTriggers fSpec)
+    ; writePrototypeFile fSpec "InstallerDefPop.php"       (installerDefPop fSpec)
+
+    ; let dbSettingsFilePath = getGenericsDir fSpec </> "dbSettings.php"
+    ; dbSettingsExists <- doesFileExist dbSettingsFilePath
+    -- we generate a dbSettings.php only if it does not exist already.
+    ; if dbSettingsExists
+      then verboseLn (getOpts fSpec) "  Using existing dbSettings.php."
+      else do { verboseLn (getOpts fSpec) "  Writing dbSettings.php."
+              ; writePrototypeFile fSpec dbSettingsFilePath dbsettings
+              }
+    }
+   where
+    dbsettings = unlines $
+       [ "<?php"
+       , ""
+       , "global $DB_host,$DB_user,$DB_pass;"
+       , "$DB_host='"++addSlashes (sqlHost (getOpts fSpec))++"';"
+       , "$DB_user='"++addSlashes (sqlLogin (getOpts fSpec))++"';"
+       , "$DB_pass='"++addSlashes (sqlPwd (getOpts fSpec))++"';"
+       , ""
+       , "$DB_link=mysqli_connect($DB_host, $DB_user, $DB_pass)"
+       , "      or exit(\"Error connecting to the database: username / password are probably incorrect.\");"
+       , ""
+       ]++setSqlModePHP++
+       [ "?>"
+       ]
+
+doGenAtlas :: FSpec -> IO()
+doGenAtlas fSpec =
+ do { verboseLn (getOpts fSpec) "Installing the Atlas application:"
+    ; verboseLn (getOpts fSpec) ("Importing "++show (importfile (getOpts fSpec))++" into namespace "++ show (namespace (getOpts fSpec)) ++" of the Atlas ...")
+    ; verboseLn (getOpts fSpec) ("The atlas application should have been installed in " ++ show (dirPrototype (getOpts fSpec)) ++ ".")
+    ; fillAtlas fSpec
+    }
+
+writeStaticFiles :: Options -> IO()
+writeStaticFiles opts =
+  if genStaticFiles opts
+  then sequence_ [ writeStaticFile opts sf 
+                 | sf@SF{isNewFrontend=isNew} <- allStaticFiles, isNew == newFrontend opts
+                 ]
+  else verboseLn opts "Skipping static files (because of command line argument)"
+
+writeStaticFile :: Options -> StaticFile -> IO()
+writeStaticFile opts sf =
+  do { createDirectoryIfMissing True (takeDirectory (absFilePath opts sf))
+     ; write (absFilePath opts sf) (contentString sf)
+     }
+ where write a b = BS.writeFile a (BS.pack b)
+
+absFilePath :: Options -> StaticFile -> FilePath
+absFilePath opts sf = combine (dirPrototype opts) (filePath sf)

+ src/Database/Design/Ampersand/Prototype/PHP.hs view
@@ -0,0 +1,308 @@+module Database.Design.Ampersand.Prototype.PHP 
+         ( executePHPStr, executePHP, showPHP, sqlServerConnectPHP, createTempDbPHP, setSqlModePHP
+         , evaluateExpSQL, performQuery
+         , createTablesPHP, populateTablesPHP, populateTablesWithPopsPHP, plug2TableSpec
+         , dropplug, historyTableSpec, sessionTableSpec, signalTableSpec, TableSpec, getTableName) where
+
+import Prelude hiding (exp)
+import Control.Exception
+import Control.Monad
+import Data.List
+import System.Process
+import System.IO hiding (hPutStr,hGetContents)
+import System.Directory
+import Database.Design.Ampersand hiding (putStr, origin)
+import Database.Design.Ampersand.Prototype.ProtoUtil
+import Database.Design.Ampersand.FSpec.SQL
+
+
+fatal :: Int -> String -> a
+fatal = fatalMsg "PHP"
+
+createTablesPHP :: FSpec -> [String]
+createTablesPHP fSpec =
+        [ "/*** Create new SQL tables ***/"
+        , ""
+        ] ++
+        concatMap createTablePHP [sessionTableSpec, historyTableSpec] ++
+        [ "$time = explode(' ', microTime()); // copied from DatabaseUtils setTimestamp"
+        , "$microseconds = substr($time[0], 2,6);"
+        , "$seconds =$time[1].$microseconds;"
+        , "date_default_timezone_set(\"Europe/Amsterdam\");"
+        -- to prevent a php warning TODO: check if this is ok when Ampersand is used in different timezones
+        , "$date = date(\"j-M-Y, H:i:s.\").$microseconds;"
+        , "mysqli_query($DB_link, \"INSERT INTO `__History__` (`Seconds`,`Date`) VALUES ('$seconds','$date')\");"
+        , "if($err=mysqli_error($DB_link)) {"
+        , "  $error=true; echo $err.'<br />';"
+        , "}"
+        , ""
+        ] ++setSqlModePHP++
+        createTablePHP signalTableSpec ++
+        [ ""
+        , "//// Number of plugs: " ++ show (length (plugInfos fSpec))
+        ]
+        -- Create all plugs
+        ++ concatMap (createTablePHP . plug2TableSpec) [p | InternalPlug p <- plugInfos fSpec]
+
+--                 (headerCmmnt,tableName,crflds,engineOpts)
+type TableSpec = (String,String,[String],String)
+
+getTableName :: TableSpec -> String
+getTableName (_,nm,_,_) = nm
+
+createTablePHP :: TableSpec -> [String]
+createTablePHP (headerCmmnt,tableName,crflds,engineOpts) =
+  [ headerCmmnt
+  -- Drop table if it already exists
+  , "if($columns = mysqli_query($DB_link, "++showPhpStr ("SHOW COLUMNS FROM `"++tableName++"`")++")){"
+  , "    mysqli_query($DB_link, "++showPhpStr ("DROP TABLE `"++tableName++"`")++");"
+  , "}"
+  ] ++
+  [ "mysqli_query($DB_link,\"CREATE TABLE `"++tableName++"`"] ++
+  [ replicate 23 ' ' ++ [pref] ++ " " ++ fld | (pref, fld) <- zip ('(' : repeat ',') crflds ] ++
+  [ replicate 23 ' ' ++ ") ENGINE=" ++engineOpts ++ "\");"]++
+  [ "if($err=mysqli_error($DB_link)) {"
+  , "  $error=true; echo $err.'<br />';"
+  , "}"
+  , "" 
+  ]++setSqlModePHP
+
+
+plug2TableSpec :: PlugSQL -> TableSpec
+plug2TableSpec plug
+ = ( unlines $ commentBlock (["Plug "++name plug,"","fields:"]++map (\x->showADL (fldexpr x)++"  "++show (multiplicities $ fldexpr x)) (plugFields plug))
+   , name plug
+   , [ quote (fldname f)++" " ++ showSQL (fldtype f) ++ (if fldauto f then " AUTO_INCREMENT" else " DEFAULT NULL")
+     | f <- plugFields plug ]++
+      case (plug, (head.plugFields) plug) of
+           (BinSQL{}, _)   -> []
+           (_,    primFld) ->
+                case flduse primFld of
+                   TableKey isPrim _ -> [ (if isPrim then "PRIMARY " else "")
+                                          ++ "KEY (`"++fldname primFld++"`)"
+                                        ]
+                   ForeignKey c  -> fatal 195 ("ForeignKey "++name c++"not expected here!")
+                   PlainAttr     -> []
+   , "InnoDB DEFAULT CHARACTER SET UTF8")
+
+signalTableSpec :: TableSpec
+signalTableSpec =
+  ( "// Signal table"
+  , "__all_signals__"
+  , [ "`conjId` VARCHAR(255) NOT NULL"
+    , "`src` VARCHAR(255) NOT NULL"
+    , "`tgt` VARCHAR(255) NOT NULL" ]
+  , "InnoDB DEFAULT CHARACTER SET UTF8"
+  )
+
+sessionTableSpec :: TableSpec
+sessionTableSpec
+ = ( "// Session timeout table"
+   , "__SessionTimeout__"
+   , [ "`SESSION` VARCHAR(255) UNIQUE NOT NULL"
+     , "`lastAccess` BIGINT NOT NULL" ]
+   , "InnoDB DEFAULT CHARACTER SET UTF8" )
+
+historyTableSpec :: TableSpec
+historyTableSpec
+ = ( "// Timestamp table"
+   , "__History__"
+   , [ "`Seconds` VARCHAR(255) DEFAULT NULL"
+     , "`Date` VARCHAR(255) DEFAULT NULL" ]
+   , "InnoDB DEFAULT CHARACTER SET UTF8" )
+
+populateTablesPHP :: FSpec -> [String]
+populateTablesPHP fSpec =
+  fillSignalTable (initialConjunctSignals fSpec) ++
+  populateTablesWithPopsPHP fSpec (initialPops fSpec)
+  where
+    fillSignalTable []          = []
+    fillSignalTable conjSignals =
+      [ "mysqli_query($DB_link, "++showPhpStr ("INSERT INTO "++ quote (getTableName signalTableSpec)
+                                                                    ++" (`conjId`, `src`, `tgt`)"
+                                              ++phpIndent 24++"VALUES " ++ 
+                                              intercalate (phpIndent 29++", ") 
+                                                [ "(" ++sqlConjId++", "++sqlAtomQuote (srcPaire p)++", "++sqlAtomQuote (trgPaire p)++")" 
+                                                | (conj, viols) <- conjSignals
+                                                , let sqlConjId = "'" ++ rc_id conj ++ "'" -- conjunct id's do not need escaping
+                                                , p <- viols
+                                                ])++"\n"++
+        "            );"
+      , "if($err=mysqli_error($DB_link)) { $error=true; echo $err.'<br />'; }"
+      ]
+
+populateTablesWithPopsPHP :: FSpec -> [Population] -> [String]
+populateTablesWithPopsPHP fSpec pops =
+  concatMap populatePlugPHP [p | InternalPlug p <- plugInfos fSpec]
+  where
+    populatePlugPHP plug
+         = case tblcontents (vgens fSpec) pops plug of
+               [] -> []
+               tblRecords -> ( "mysqli_query($DB_link, "++showPhpStr ("INSERT INTO "++quote (name plug)
+                                                           ++" ("++intercalate "," [quote (fldname f) |f<-plugFields plug]++")"
+                                                           ++phpIndent 17++"VALUES " ++ intercalate (phpIndent 22++", ") [ "(" ++valuechain md++ ")" | md<-tblRecords]
+                                                           ++phpIndent 16 )
+                                        ++");"
+                             ):
+                             ["if($err=mysqli_error($DB_link)) { $error=true; echo $err.'<br />'; }"]
+     where
+        valuechain record = intercalate ", " [case fld of Nothing -> "NULL" ; Just str -> sqlAtomQuote str | fld<-record]
+
+
+dropplug :: PlugSQL -> String
+dropplug plug = "DROP TABLE "++quote (name plug)++""
+
+sqlServerConnectPHP :: FSpec -> [String]
+sqlServerConnectPHP fSpec =
+  [ "// Try to connect to the database"
+  , "global $DB_host,$DB_user,$DB_pass;"
+  , "$DB_host='"++addSlashes (sqlHost (getOpts fSpec))++"';"
+  , "$DB_user='"++addSlashes (sqlLogin (getOpts fSpec))++"';"
+  , "$DB_pass='"++addSlashes (sqlPwd (getOpts fSpec))++"';"
+  
+  , "$DB_link = mysqli_connect($DB_host,$DB_user,$DB_pass);"
+  , "// Check connection"
+  , "if (mysqli_connect_errno()) {"
+  , "  die(\"Failed to connect to MySQL: \" . mysqli_connect_error());"
+  , "}"
+  , ""
+  ]++setSqlModePHP
+
+createTempDbPHP :: String -> [String]
+createTempDbPHP dbNm =
+      [ "$DB_name='"++addSlashes dbNm++"';"
+      , "// Drop the database if it exists"
+      , "$sql=\"DROP DATABASE $DB_name\";"
+      , "mysqli_query($DB_link,$sql);"
+      , "// Don't bother about the error if the database didn't exist..."
+      , ""
+      , "// Create the database"
+      , "$sql=\"CREATE DATABASE $DB_name DEFAULT CHARACTER SET UTF8\";"
+      , "if (!mysqli_query($DB_link,$sql)) {"
+      , "  die(\"Error creating the database: \" . mysqli_error($DB_link));"
+      , "  }"
+      , ""
+      , "// Connect to the freshly created database"
+      , "$DB_link = mysqli_connect($DB_host,$DB_user,$DB_pass,$DB_name);"
+      , "// Check connection"
+      , "if (mysqli_connect_errno()) {"
+      , "  die(\"Failed to connect to the database: \" . mysqli_connect_error());"
+      , "  }"
+      , ""
+      ]++setSqlModePHP
+
+
+-- evaluate normalized exp in SQL
+evaluateExpSQL :: FSpec -> String -> Expression -> IO [(String,String)]
+evaluateExpSQL fSpec dbNm exp =
+  fmap sort (performQuery (getOpts fSpec) dbNm violationsQuery)
+ where violationsExpr = conjNF (getOpts fSpec) exp
+       violationsQuery = prettySQLQuery fSpec 26 violationsExpr
+
+performQuery :: Options -> String -> String -> IO [(String,String)]
+performQuery opts dbNm queryStr =
+ do { queryResult <- (executePHPStr . showPHP) php
+    ; if "Error" `isPrefixOf` queryResult -- not the most elegant way, but safe since a correct result will always be a list
+      then do verboseLn opts{verboseP=True} ("\n******Problematic query:\n"++queryStr++"\n******")
+              fatal 141 $ "PHP/SQL problem: "++queryResult
+      else case reads queryResult of
+             [(pairs,"")] -> return pairs
+             _            -> fatal 143 $ "Parse error on php result: "++show queryResult
+    }
+   where
+    php =
+      [ "// Try to connect to the database"
+      , "$DB_name='"++addSlashes dbNm++"';"
+      , "global $DB_host,$DB_user,$DB_pass;"
+      , "$DB_host='"++addSlashes (sqlHost opts)++"';"
+      , "$DB_user='"++addSlashes (sqlLogin opts)++"';"
+      , "$DB_pass='"++addSlashes (sqlPwd opts)++"';"
+      , "$DB_link = mysqli_connect($DB_host,$DB_user,$DB_pass,$DB_name);"
+      , "// Check connection"
+      , "if (mysqli_connect_errno()) {"
+      , "  die(\"Error: Failed to connect to $DB_name: \" . mysqli_connect_error());"
+      , "  }"
+      , ""
+      ]++setSqlModePHP++
+      [ "$sql="++showPhpStr queryStr++";"
+      , "$result=mysqli_query($DB_link,$sql);"
+      , "if(!$result)"
+      , "  die('Error '.($ernr=mysqli_errno($DB_link)).': '.mysqli_error($DB_link).'(Sql: $sql)');"
+      , "$rows=Array();"
+      , "  while ($row = mysqli_fetch_array($result)) {"
+      , "    $rows[]=$row;"
+      , "    unset($row);"
+      , "  }"
+      , "echo '[';"
+      , "for ($i = 0; $i < count($rows); $i++) {"
+      , "  if ($i==0) echo ''; else echo ',';"
+      , "  echo '(\"'.addslashes($rows[$i]['src']).'\", \"'.addslashes($rows[$i]['tgt']).'\")';"
+      , "}"
+      , "echo ']';"
+      ]
+
+-- call the command-line php with phpStr as input
+executePHPStr :: String -> IO String
+executePHPStr phpStr =
+ do { tempdir <- catch getTemporaryDirectory
+                       (\e -> do let err = show (e :: IOException)
+                                 hPutStr stderr ("Warning: Couldn't find temp directory. Using current directory : " ++ err)
+                                 return ".")
+
+    ; (tempPhpFile, temph) <- openTempFile tempdir "phpInput"
+    ; hPutStr temph phpStr
+    ; hClose temph
+    ; results <- executePHP Nothing tempPhpFile []
+    ; removeFile tempPhpFile
+    ; return results
+    }
+    
+executePHP :: Maybe String -> String -> [String] -> IO String
+executePHP mWorkingDir phpPath phpArgs =
+ do { let cp = CreateProcess
+                { cmdspec       = RawCommand "php" $ phpPath : phpArgs
+                , cwd           = mWorkingDir
+                , env           = Just [("TERM","dumb")] -- environment
+                , std_in        = Inherit
+                , std_out       = CreatePipe
+                , std_err       = CreatePipe
+                , close_fds     = False -- no need to close all other file descriptors
+                , create_group  = False
+                , delegate_ctlc = False -- don't let php handle ctrl-c
+                }
+
+    ; (_, mStdOut, mStdErr, _) <- createProcess cp
+    ; outputStr <-
+        case (mStdOut, mStdErr) of
+          (Nothing, _) -> fatal 44 "no output handle"
+          (_, Nothing) -> fatal 45 "no error handle"
+          (Just stdOutH, Just stdErrH) ->
+           do { --putStrLn "done"
+              ; errStr <- hGetContents stdErrH
+              ; seq (length errStr) $ return ()
+              ; hClose stdErrH
+              ; unless (null errStr) $
+                  putStrLn $ "Error during PHP execution:\n" ++ errStr
+              ; outputStr' <- hGetContents stdOutH --and fetch the results from the output pipe
+              ; seq (length outputStr') $ return ()
+              ; hClose stdOutH
+              ; return outputStr'
+              }
+--    ; putStrLn $ "Results:\n" ++ outputStr
+    ; return outputStr
+    }
+
+showPHP :: [String] -> String
+showPHP phpLines = unlines $ ["<?php"]++phpLines++["?>"]
+
+
+-- | php code snippet to set the sql_mode
+setSqlModePHP :: [String]
+setSqlModePHP = 
+       [ "$sql=\"SET SESSION sql_mode = 'ANSI,TRADITIONAL'\";" -- ANSI because of the syntax of the generated SQL
+                                                               -- TRADITIONAL because of some more safety
+       , "if (!mysqli_query($DB_link,$sql)) {"
+       , "  die(\"Error setting sql_mode: \" . mysqli_error($DB_link));"
+       , "  }"
+       , ""
+       ]

+ src/Database/Design/Ampersand/Prototype/ProtoUtil.hs view
@@ -0,0 +1,170 @@+{-# LANGUAGE FlexibleInstances #-}
+module Database.Design.Ampersand.Prototype.ProtoUtil
+         ( writePrototypeFile, getGenericsDir
+         , copyDirRecursively, copyDeepFile, removeAllDirectoryFiles, getProperDirectoryContents
+         , escapeIdentifier,commentBlock,strReplace
+         , addSlashes
+         , indentBlock,addToLast
+         , indentBlockBetween,quote,sqlAtomQuote
+         , phpIndent,showPhpStr,escapePhpStr,showPhpBool
+         ) where
+ 
+import Prelude hiding (putStrLn, readFile, writeFile)
+import Data.Char
+import Data.List
+import System.Directory
+import System.FilePath
+import Database.Design.Ampersand.Basics
+import Database.Design.Ampersand.FSpec
+import Database.Design.Ampersand.Misc.Options (verboseLn) -- TODO: verboseLn shouldn't be in Options
+import qualified Database.Design.Ampersand.Misc.Options as Opts
+
+fatal :: Int -> String -> a
+fatal = fatalMsg "ProtoUtil"
+
+writePrototypeFile :: FSpec -> String -> String -> IO ()
+writePrototypeFile fSpec relFilePath content =
+ do { verboseLn (getOpts fSpec) ("  Generating "++relFilePath)
+    ; let filePath = getGenericsDir fSpec </> relFilePath
+    ; createDirectoryIfMissing True (takeDirectory filePath)
+    ; writeFile filePath content
+    }
+
+getGenericsDir :: FSpec -> String
+getGenericsDir fSpec = 
+  let protoDir = Opts.dirPrototype (getOpts fSpec)
+  in  if (Opts.newFrontend $ getOpts fSpec) then protoDir </> "generics" else protoDir
+
+-- Copy entire directory tree from srcBase/ to tgtBase/, overwriting existing files, but not emptying existing directories.
+-- NOTE: tgtBase specifies the copied directory target, not its parent
+copyDirRecursively :: FilePath -> FilePath -> IO ()
+copyDirRecursively srcBase tgtBase = copy ""
+  where copy fileOrDirPth = 
+         do { let srcPath = srcBase </> fileOrDirPth
+                  tgtPath = tgtBase </> fileOrDirPth
+            ; isDir <- doesDirectoryExist srcPath
+            ; if isDir then 
+               do { createDirectoryIfMissing True tgtPath
+                  ; fOrDs <- getProperDirectoryContents srcPath
+                  ; mapM_ (\fOrD -> copy $ fileOrDirPth </> fOrD) fOrDs
+                  }
+              else
+                copyFile srcPath tgtPath -- directory will exist, so no need for copyDeepFile
+            }
+            
+-- Copy file while creating all subdirectories on the target path (if non-existent)
+copyDeepFile :: FilePath -> FilePath -> IO ()
+copyDeepFile srcPath tgtPath =
+ do { createDirectoryIfMissing True (takeDirectory tgtPath)
+    ; copyFile srcPath tgtPath
+    }
+
+-- Remove all files in directory dirPath, but don't enter subdirectories (for which a warning is emitted.)
+removeAllDirectoryFiles :: FilePath -> IO ()
+removeAllDirectoryFiles dirPath =
+ do { dirContents <- getProperDirectoryContents dirPath
+    ; mapM_ removeDirectoryFile dirContents 
+    }
+  where removeDirectoryFile path = 
+         do { let absPath = dirPath </> path
+            ; isDir <- doesDirectoryExist absPath
+            ; if isDir then
+                putStrLn $ "WARNING: directory '"++dirPath++"' contains a subdirectory '"++path++"' which is not cleared."
+              else
+                removeFile absPath
+            }
+     
+getProperDirectoryContents :: FilePath -> IO [String]
+getProperDirectoryContents pth = fmap (filter (`notElem` [".","..",".svn"])) $
+                                   getDirectoryContents pth
+
+
+quote :: String->String
+quote [] = []
+quote ('`':s) = '`':s  -- do nothing if already quoted
+quote s = "`"++s++"`"
+--   quote s = "`"++quo s++"`"
+--    where quo ('`':s')  = "\\`" ++ quo s'
+--          quo ('\\':s') = "\\\\" ++ quo s'
+--          quo (c:s')    = c: quo s'
+--          quo []       = []
+-- See http://stackoverflow.com/questions/11321491/when-to-use-single-quotes-double-quotes-and-backticks
+sqlAtomQuote :: String->String
+sqlAtomQuote s = "'"++sAQ s++"'"
+ where sAQ ('\'':s') = "\\'" ++ sAQ s'
+       sAQ ('\\':s') = "\\\\" ++ sAQ s'
+       sAQ (c:s')    = c: sAQ s'
+       sAQ []       = []
+
+commentBlock :: [String]->[String]
+commentBlock ls = ["/*"++replicate lnth '*'++"*\\"]
+                     ++ ["* "++strReplace "*/" "**" line++replicate (lnth - length line) ' '++" *" | line <- ls]
+                     ++ ["\\*"++replicate lnth '*'++"*/"]
+   where
+     lnth = foldl max 0 (map length ls)
+indentBlock :: Int -> [String] -> [String]
+indentBlock i = map (replicate i ' ' ++)
+
+-- | will put the block after the first string, and put the second after the block
+-- | If the block is just 1 line, indentBlockBetween will return just 1 line as well
+indentBlockBetween :: String -- ^ precedes the block
+                   -> String -- ^ comes at the end of the block
+                   -> [String] -- ^ the block itself, (will be indented)
+                   -> String -- ^ result
+indentBlockBetween pre post [] = pre++post
+indentBlockBetween pre post [s] = pre++s++post
+indentBlockBetween pre post block
+ = intercalate (phpIndent (length pre)) ((pre++head block):(init rest++[last rest++post]))
+ where  rest = tail block
+
+strReplace :: String -> String -> String -> String
+strReplace _ _ "" = ""
+strReplace "" _ str = str
+strReplace src dst inp
+    = process inp
+      where
+        n = length src
+        process "" = ""
+        process st@(c:cs)
+          | src `isPrefixOf` st = dst ++ process (drop n st)
+          | otherwise           = c:process cs
+
+phpIndent :: Int -> String
+phpIndent i
+ | i < 0     = " " --space instead of \n
+ | otherwise = '\n':replicate i ' '
+
+-- Create an identifier that does not start with a digit and consists only of upper/lowercase ascii letters, underscores, and digits.
+-- This function is injective.
+escapeIdentifier :: String -> String
+escapeIdentifier ""      = "_EMPTY_"
+escapeIdentifier (c0:cs) = encode False c0 ++ concatMap (encode True) cs
+  where encode allowNum c | isAsciiLower c || isAsciiUpper c || allowNum && isDigit c = [c]
+                          | c == '_'  = "__" -- shorthand for '_' to improve readability
+                          | otherwise = "_" ++ show (ord c) ++ "_"
+
+addSlashes :: String -> String
+addSlashes ('\'': cs) = "\\'"++addSlashes cs
+addSlashes ('"': cs) = "\\\""++addSlashes cs
+addSlashes ('\\': cs) = "\\\\"++addSlashes cs
+addSlashes (c:cs) = c:addSlashes cs
+addSlashes "" = ""
+
+addToLast :: [a] -> [[a]] -> [[a]]
+addToLast _ [] = fatal 109 "addToLast: empty list"
+addToLast s as = init as++[last as++s]
+
+showPhpStr :: String -> String
+showPhpStr str = "'"++escapePhpStr str++"'"
+
+-- NOTE: we assume a single quote php string, so $ and " are not escaped
+escapePhpStr :: String -> String
+escapePhpStr ('\'':s) = "\\'" ++ escapePhpStr s
+escapePhpStr ('\\':s) = "\\\\" ++ escapePhpStr s
+escapePhpStr (c:s)    = c: escapePhpStr s
+escapePhpStr []       = []
+-- todo: escape everything else (unicode, etc)
+
+showPhpBool :: Bool -> String
+showPhpBool b = if b then "true" else "false"
+

+ src/Database/Design/Ampersand/Prototype/StaticFiles_Generated.hs view
file too large to diff
+ src/Database/Design/Ampersand/Prototype/ValidateEdit.hs view
@@ -0,0 +1,159 @@+module Database.Design.Ampersand.Prototype.ValidateEdit where
+
+import Prelude hiding (putStr, putStrLn)
+import Data.List
+import Data.Maybe
+import System.FilePath hiding (isValid)
+import Database.Design.Ampersand
+import Database.Design.Ampersand.Basics
+import Database.Design.Ampersand.Prototype.PHP
+import Database.Design.Ampersand.FSpec.SQL
+import qualified Database.Design.Ampersand.Misc.Options as Opts
+
+fatal :: Int -> String -> a
+fatal = fatalMsg "Prototype.ValidateEdit"
+
+
+tempDbName :: String
+tempDbName = "ampersand_temporaryeditvalidationdb"
+
+validateEditScript :: FSpec -> [Population] -> [Population] -> [Char] -> IO Bool
+validateEditScript fSpec beforePops afterPops editScriptPath =
+ do { mFileContents <- readUTF8File editScriptPath
+    ; case mFileContents of
+        Left err -> error $ "ERROR reading file " ++ editScriptPath ++ ":\n" ++ err
+        Right editScript ->
+         do { --putStrLn $ "Population before edit operations:\n" ++ show beforePops
+            ; --putStrLn $ "Expected population after edit operations:\n" ++ show afterPops
+            ; putStrLn $ "Edit script:\n" ++ editScript
+            
+            ; createTempDatabase fSpec beforePops
+            ; let phpDir = Opts.dirPrototype (getOpts fSpec) </> "php"
+            ; let phpScript = "ValidateEdit.php"
+            ; putStrLn $ "Executing php script "++ phpDir </> phpScript
+            ; _ <- executePHP (Just phpDir) phpScript [editScript] -- TODO: escape
+            
+            ; let expectedConceptTables  = [ (c,atoms) | PCptPopu c atoms <- afterPops ]
+            ; let expectedRelationTables = [ (d,pairs) | PRelPopu d pairs <- afterPops ]
+            ; let actualConcepts = [ c | c<- allConcepts fSpec, c /= ONE, name c /= "SESSION" ] -- TODO: are these the right concepts and decls?
+            ; let actualRelations = allDecls fSpec            --
+            ; actualConceptTables <- mapM (getSqlConceptTable fSpec) actualConcepts
+            ; actualRelationTables <- mapM (getSqlRelationTable fSpec) actualRelations
+            ; let commonConcepts = getCommons expectedConceptTables actualConceptTables
+            ; let commonRelations = getCommons expectedRelationTables actualRelationTables
+            
+            ; putStrLn $ "\n--- Validation results ---\n" 
+            ; putStrLn $ "Actual concept tables:\n" ++ unlines [ name c ++ ": " ++ show atoms | (c,atoms) <- actualConceptTables ] 
+            ; putStrLn $ "Actual relations:\n" ++ unlines [ name d ++ ": " ++ show pairs | (d,pairs) <- actualRelationTables ]
+
+            ; putStrLn $ "Expected concept tables:\n" ++ unlines [ name c ++ ": " ++ show atoms | (c,atoms) <- expectedConceptTables ] 
+            ; putStrLn $ "Expected relations:\n" ++ unlines [ name d ++ ": " ++ show pairs | (d,pairs) <- expectedRelationTables ] 
+
+            ; let conceptDiffs  = showDiff "Actual population" "concepts" (map fst expectedConceptTables) (map fst actualConceptTables)
+            ; let relationDiffs = showDiff "Actual population" "relations" (map fst expectedRelationTables) (map fst actualRelationTables)
+            
+            ; let commonConceptDiffs  = concat [ showDiff (name c) "atoms" expAtoms resAtoms | (c, expAtoms, resAtoms) <- commonConcepts ]
+            ; let commonRelationDiffs = concat [ showDiff (name r) "pairs" expPairs resPairs | (r, expPairs, resPairs) <- commonRelations ]
+
+            ; putStrLn $ "\n--- Validation summary ---\n" 
+            
+            ; if null conceptDiffs 
+              then putStrLn "Expected and actual populations contain the same concepts"
+              else putStrLn $ unlines $ conceptDiffs
+            ; putStrLn ""
+            ; if null relationDiffs 
+              then putStrLn "Expected and actual populations contain the same relations"
+              else putStrLn $ unlines $ relationDiffs
+            ; putStrLn ""            
+            ; if null commonConceptDiffs 
+              then putStrLn "Common concepts are equal"
+              else putStrLn $ unlines $ "Differences for common concepts:"  : commonConceptDiffs 
+            ; putStrLn ""            
+            ; if null commonRelationDiffs
+              then putStrLn "Common relations are equal"
+              else putStrLn $ unlines $ "Differences for common relations:" : commonRelationDiffs 
+            
+            ; let isValid = null $ conceptDiffs ++ relationDiffs ++ commonConceptDiffs ++ commonRelationDiffs
+            ; putStrLn $ "\nValidation " ++ if isValid then "was successful." else "failed."
+            ; return  isValid
+            }
+    }
+
+createTempDatabase :: FSpec -> [Population] -> IO ()
+createTempDatabase fSpec pops =
+ do { _ <- executePHPStr . showPHP $ sqlServerConnectPHP fSpec ++
+                                     createTempDbPHP tempDbName ++
+                                     createTablesPHP fSpec ++
+                                     populateTablesWithPopsPHP fSpec pops
+    ; return ()
+    }
+
+getSqlConceptTable :: FSpec -> A_Concept -> IO (A_Concept, [String])
+getSqlConceptTable fSpec c =
+ do { -- to prevent needing a unary query function, we add a dummy NULL column and use `src` and `tgt` as column names (in line with what performQuery expects)
+      let query = case lookupCpt fSpec c of
+                    []                      -> fatal 58  "No concept table for concept \"" ++ name c ++ "\""
+                    (table,conceptField):_ -> "SELECT DISTINCT `" ++ fldname conceptField ++ "` as `src`, NULL as `tgt`"++
+                                              " FROM `" ++ name table ++ "`" ++
+                                              " WHERE `" ++ fldname conceptField ++ "` IS NOT NULL"
+    --; putStrLn $ "Query for concept " ++ name c ++ ":" ++ query 
+    ; atomsDummies <- performQuery (getOpts fSpec) tempDbName query
+    ; return (c, map fst atomsDummies)
+    }
+
+getSqlRelationTable :: FSpec -> Declaration -> IO (Declaration, [Paire])
+getSqlRelationTable fSpec d =
+ do { let query = prettySQLQuery fSpec 0 d
+ 
+    --; putStrLn $ "Query for decl " ++ name d ++ ":" ++ query 
+    ; pairs <- performQuery (getOpts fSpec) tempDbName query
+    ; return (d, [mkPair src tgt | (src,tgt) <-pairs])
+    }
+-- TODO: are we going to use this data type?
+
+type EditScript = [SQLEditOp]
+
+data SQLEditOp = SQLAddToConcept { atomNm :: String, conceptNm :: String }
+               | SQLDelete { relationNm :: String, relationIsFlipped :: Bool
+                           , parentAtomNm :: String, childAtomNm :: String }
+               | SQLUpdate { relationNm :: String, relationIsFlipped :: Bool
+                           , parentAtomNm :: String, parentConceptNm ::String
+                           , childAtomNm :: String, childConceptNm ::String
+                           , parentOrChild :: ParentOrChild, originalAtomNm :: String 
+                           }
+
+data ParentOrChild = Parent | Child deriving Show
+
+{- JSON for edit commands from Database.PHP:
+
+ { dbCmd: 'addToConcept', atom:atom, concept:concept }
+
+ { dbCmd: 'update', relation:relation, isFlipped:relationIsFlipped
+ , parentAtom:parentAtom, parentConcept:parentConcept
+ , childAtom:childAtom, childConcept:childConcept
+ , parentOrChild:parentOrChild, originalAtom:originalAtom
+ }
+
+ { dbCmd: 'delete', relation:relation, isFlipped:relationIsFlipped
+ , parentAtom:parentAtom, childAtom:childAtom
+ } 
+ 
+-}
+
+-- Utils
+
+getCommons :: Eq a => [(a,bs)] -> [(a,bs)] -> [(a,bs,bs)]
+getCommons elts1 elts2 = catMaybes
+  [ case find (\(a',_)-> a' == a) elts2 of
+      Just (_,bs2) -> Just (a, bs1, bs2)
+      Nothing      -> Nothing 
+  | (a,bs1) <- elts1 
+  ]
+  
+showDiff :: (Eq a, Show a) => String -> String -> [a] -> [a] -> [String]
+showDiff entityStr elementsStr expected actual =
+  let unexpected = actual \\ expected
+      missing    = expected \\ actual
+  in  [ "!! " ++ entityStr ++ " is missing expected " ++ elementsStr ++ ": " ++ show missing | not . null $ missing ] ++
+      [ "!! " ++ entityStr ++ " has unexpected " ++ elementsStr ++ ": " ++ show unexpected | not . null $ unexpected ]
+

+ src/Database/Design/Ampersand/Prototype/ValidateSQL.hs view
@@ -0,0 +1,127 @@+module Database.Design.Ampersand.Prototype.ValidateSQL (validateRulesSQL) where
+
+import Prelude hiding (exp)
+import Data.List
+import Control.Monad
+import System.Exit
+import System.IO hiding (hPutStr,hGetContents)
+import Database.Design.Ampersand hiding (putStr, origin)
+import Database.Design.Ampersand.Prototype.Installer
+import Database.Design.Ampersand.Prototype.PHP
+
+{-
+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.
+-}
+
+--fatal :: Int -> String -> a
+--fatal = fatalMsg "ValidateSQL"
+
+tempDbName :: String
+tempDbName = "ampersand_temporaryvalidationdb"
+
+validateRulesSQL :: FSpec -> IO Bool
+validateRulesSQL fSpec =
+ do { when (any (not.isSignal.fst) (allViolations fSpec))
+        (do { putStrLn "The population would violate invariants. Could not generate your database."
+            ; exitWith $ ExitFailure 10
+                 })
+    ; hSetBuffering stdout NoBuffering
+
+    ; putStrLn "Initializing temporary database"
+    ; createTempDatabase fSpec
+
+    ; let allExps = getAllInterfaceExps fSpec ++
+                    getAllRuleExps fSpec ++
+                    getAllPairViewExps fSpec ++
+                    getAllIdExps fSpec ++
+                    getAllViewExps fSpec
+
+    ; putStrLn $ "Number of expressions to be validated: "++show (length allExps)
+    ; results <- mapM (validateExp fSpec) allExps
+
+--    ; putStrLn "\nRemoving temporary database"
+--    ; removeTempDatabase (getOpts fSpec)
+
+    ; case [ ve | (ve, False) <- results] of
+        [] -> do { putStrLn "\nValidation successful.\nWith the provided populations, all generated SQL code has passed validation."
+                 ; return True
+                 }
+        ves -> do { putStrLn ( "\n\nValidation error. The following expressions failed validation:\n" ++
+                               unlines (map showVExp ves)
+                             )
+                  ; return False
+                  }
+    }
+
+-- functions for extracting all expressions from the context
+
+getAllInterfaceExps :: FSpec -> [ValidationExp]
+getAllInterfaceExps fSpec = concat [ getObjExps (name ifc) $ ifcObj ifc
+                                   | ifc <- interfaceS fSpec ++ interfaceG fSpec ]
+ where getObjExps iName objDef = (objctx objDef, "interface " ++ show iName) :
+                                 concatMap (getObjExps iName) (attributes objDef)
+
+-- we check the complement of the rule, since that is the expression evaluated in the prototype
+getAllRuleExps :: FSpec -> [ValidationExp]
+getAllRuleExps fSpec = map getRuleExp $ vrules fSpec ++ grules fSpec
+ where getRuleExp rule = (notCpl (rrexp rule), "rule "++show (name rule))
+
+getAllPairViewExps :: FSpec -> [ValidationExp]
+getAllPairViewExps fSpec = concatMap getPairViewExps $ vrules fSpec ++ grules fSpec
+ where getPairViewExps r@Ru{rrviol = Just (PairView pvsegs)} =
+         [ (exp, "violation view for rule "++show (name r)) | PairViewExp _ _ exp <- pvsegs ]
+       getPairViewExps _    = []
+
+getAllIdExps :: FSpec -> [ValidationExp]
+getAllIdExps fSpec = concatMap getIdExps $ vIndices fSpec
+ where getIdExps identity = [ (objctx objDef, "identity "++show (name identity))
+                            | IdentityExp objDef <- identityAts identity ]
+
+getAllViewExps :: FSpec -> [ValidationExp]
+getAllViewExps fSpec = concatMap getViewExps $ vviews fSpec
+ where getViewExps view = [ (objctx objDef, "view "++show (name view))
+                          | ViewExp objDef <- vdats view ]
+
+type ValidationExp = (Expression, String)
+-- a ValidationExp is an expression together with the place in the context where we
+-- obtained it from (e.g. rule/interface/..)
+showVExp :: ShowADL a => (a, String) -> String
+showVExp (exp, origin) = "Origin: "++origin++", expression: "++showADL exp
+
+-- validate a single expression and report the results
+validateExp :: FSpec -> ValidationExp -> IO (ValidationExp, Bool)
+validateExp _  vExp@(EDcD{}, _)   = -- skip all simple relations
+ do { putStr "."
+    ; return (vExp, True)
+    }
+validateExp fSpec vExp@(exp, origin) =
+ do { --putStr $ "Checking "++origin ++": expression = "++showADL exp
+    ; violationsSQL <- fmap sort . evaluateExpSQL fSpec tempDbName $ exp
+    ; let violationsAmp = sort [(srcPaire p, trgPaire p) | p <- fullContents (vgens fSpec) (initialPops fSpec) exp]
+
+    ; if violationsSQL == violationsAmp
+      then
+       do { putStr "." -- ++show violationsSQL
+          ; return (vExp, True)
+          }
+      else
+       do { putStr $ "Checking "++origin ++": expression = "++showADL exp
+          ; putStrLn "\nMismatch between SQL and Ampersand"
+          ; putStrLn $ showVExp vExp
+          ; putStrLn $ "SQL violations:\n"++show violationsSQL
+          ; putStrLn $ "Ampersand violations:\n" ++ show violationsAmp
+          ; return (vExp, False)
+          }
+    }
+
+createTempDatabase :: FSpec -> IO ()
+createTempDatabase fSpec =
+ do { _ <- executePHPStr . showPHP $ sqlServerConnectPHP fSpec ++
+                                     createTempDbPHP tempDbName ++
+                                     createTablesPHP fSpec ++
+                                     populateTablesPHP fSpec
+    ; return ()
+    }
+ 

+ src/Main.hs view
@@ -0,0 +1,132 @@+module Main where
+
+import Control.Monad
+import Control.Applicative
+import Data.List
+import Data.Function (on)
+import System.FilePath        (combine)
+import System.Exit
+import Prelude hiding (putStr,readFile,writeFile)
+import Database.Design.Ampersand.Prototype.ObjBinGen   (generatePhp, doGenAtlas, writeStaticFiles)
+import Database.Design.Ampersand.Prototype.Apps.RAP    (atlas2context, atlas2populations)
+import Database.Design.Ampersand
+import Database.Design.Ampersand.Prototype.GenBericht  (doGenBericht)
+import Database.Design.Ampersand.Prototype.Generate    (generateGenerics, generateCustomCss)
+import Database.Design.Ampersand.Prototype.GenFrontend (doGenFrontend, clearTemplateDirs)
+import Database.Design.Ampersand.Prototype.ValidateSQL (validateRulesSQL)
+import Database.Design.Ampersand.Prototype.ValidateEdit
+
+main :: IO ()
+main =
+ do opts <- getOptions
+    if showVersion opts || showHelp opts
+    then mapM_ putStr (helpNVersionTexts ampersandVersionStr opts)
+    else do gFSpec <- createFSpec opts
+            case gFSpec of
+              Errors err    -> do putStrLn "Error(s) found:"
+                                  mapM_ putStrLn (intersperse  (replicate 30 '=') (map showErr err))
+                                  exitWith $ ExitFailure 10
+              Checked fSpec -> do generateAmpersandOutput fSpec
+                                  generateProtoStuff      fSpec
+
+generateProtoStuff :: FSpec -> IO ()
+generateProtoStuff fSpec
+  | Just nm <- validateEdit (getOpts fSpec) =
+      do { verboseLn (getOpts fSpec) "Validating edit operations:"
+         ; gBeforePops <- getPopulationsFrom (getOpts fSpec) $ nm ++ ".before.pop"
+         ; gAfterPops <- getPopulationsFrom (getOpts fSpec) $ nm ++ ".after.pop"
+         ; case (,) <$> gBeforePops <*> gAfterPops of
+              Errors err -> do putStrLn "Error(s) found in before/after populations:"
+                               mapM_ putStrLn (intersperse  (replicate 30 '=') (map showErr err))
+                               exitWith $ ExitFailure 10
+              Checked (beforePops, afterPops) ->
+               do { isValid <- validateEditScript fSpec beforePops afterPops (nm++".edit.json")
+                  ; unless isValid (exitWith (ExitFailure 30))
+                  }
+         }
+  | validateSQL (getOpts fSpec) =
+      do { verboseLn (getOpts fSpec) "Validating SQL expressions..."
+         ; isValid <- validateRulesSQL fSpec
+         ; unless isValid (exitWith (ExitFailure 30))
+         }
+  | export2adl (getOpts fSpec) && fileformat (getOpts fSpec)==Just Adl1Format =
+      do { verboseLn (getOpts fSpec) "Exporting Atlas DB content to .adl-file..."
+         ; cx<-atlas2context (getOpts fSpec) fSpec
+         ; writeFile (combine (dirOutput (getOpts fSpec)) (outputfile (getOpts fSpec))) (showADL cx)
+         ; verboseLn (getOpts fSpec) $ "Context written to " ++ combine (dirOutput (getOpts fSpec)) (outputfile (getOpts fSpec)) ++ "."
+         }
+  | export2adl (getOpts fSpec) && fileformat (getOpts fSpec)==Just Adl1PopFormat =
+      do { verboseLn (getOpts fSpec) "Exporting Atlas DB content to .pop-file..."
+         ; cxstr<-atlas2populations fSpec
+         ; writeFile (combine (dirOutput (getOpts fSpec)) (outputfile (getOpts fSpec))) cxstr
+         ; verboseLn (getOpts fSpec) $ "Population of context written to " ++ combine (dirOutput (getOpts fSpec)) (outputfile (getOpts fSpec)) ++ "."
+         }
+  | otherwise =
+      do { when (genPrototype (getOpts fSpec)) $ doGenProto fSpec
+         ; when (genBericht (getOpts fSpec))   $ doGenBericht fSpec
+         ; case testRule (getOpts fSpec) of
+             Just ruleName -> ruleTest fSpec ruleName
+             Nothing       -> return ()
+    ; when ((not . null $ allViolations fSpec) && (development (getOpts fSpec) || theme (getOpts fSpec)==StudentTheme)) $
+        verboseLn (getOpts fSpec) "\nWARNING: There are rule violations (see above)."
+    ; verboseLn (getOpts fSpec) "Done."  -- if there are violations, but we generated anyway (ie. with --dev or --theme=student), issue a warning
+    }
+
+doGenProto :: FSpec -> IO ()
+doGenProto fSpec =
+ do { verboseLn (getOpts fSpec) "Checking on rule violations..."
+    ; reportViolations (allViolations fSpec)
+    ; reportSignals (initialConjunctSignals fSpec)
+    ; if (not . null) (allViolations fSpec) && not (development (getOpts fSpec)) && theme (getOpts fSpec)/=StudentTheme
+      then do { putStrLn "\nERROR: No prototype generated because of rule violations.\n(Compile with --dev to generate a prototype regardless of violations)"
+              ; exitWith $ ExitFailure 40
+              }
+      else do { verboseLn (getOpts fSpec) "Generating prototype..."
+
+              ; when (newFrontend (getOpts fSpec)) $
+                  clearTemplateDirs fSpec
+                  
+              ; writeStaticFiles (getOpts fSpec)
+              ; generatePhp fSpec
+              ; generateGenerics fSpec
+              
+              ; if (newFrontend (getOpts fSpec)) then
+                  doGenFrontend fSpec
+                else
+                  generateCustomCss fSpec
+              
+              ; when (genAtlas (getOpts fSpec)) $ doGenAtlas fSpec
+              ; verboseLn (getOpts fSpec) "\n"
+              
+              ; verboseLn (getOpts fSpec) $ "Prototype files have been written to " ++ dirPrototype (getOpts fSpec)
+              }
+    }
+ where reportViolations []    = verboseLn (getOpts fSpec) "No violations found."
+       reportViolations viols =
+         let ruleNamesAndViolStrings = [ (name r, showADL p) | (r,p) <- viols ]
+         in  putStrLn $ intercalate "\n"
+                          [ "Violations of rule "++show r++":\n"++ concatMap (\(_,p) -> "- "++ p ++"\n") rps
+                          | rps@((r,_):_) <- groupBy (on (==) fst) $ sort ruleNamesAndViolStrings
+                          ]
+                          
+       reportSignals []        = verboseLn (getOpts fSpec) "No signals for the initial population."
+       reportSignals conjViols = verboseLn (getOpts fSpec) $ "Signals for initial population:\n" ++ intercalate "\n"
+         [ "Conjunct: " ++ showADL (rc_conjunct conj) ++ "\n- " ++
+             showADL viols
+         | (conj, viols) <- conjViols
+         ]
+
+ruleTest :: FSpec -> String -> IO ()
+ruleTest fSpec ruleName =
+ case [ rule | rule <- grules fSpec ++ vrules fSpec, name rule == ruleName ] of
+   [] -> putStrLn $ "\nRule test error: rule "++show ruleName++" not found."
+   (rule:_) -> do { putStrLn $ "\nContents of rule "++show ruleName++ ": "++showADL (rrexp rule)
+                  ; putStrLn $ showContents rule
+                  ; let rExpr = rrexp rule
+                  ; let ruleComplement = rule { rrexp = notCpl (EBrk rExpr) }
+                  ; putStrLn $ "\nViolations of "++show ruleName++" (contents of "++showADL (rrexp ruleComplement)++"):"
+                  ; putStrLn $ showContents ruleComplement
+                  }
+ where showContents rule = let pairs = [ "("++srcPaire v++"," ++trgPaire v++")" | (r,vs) <- allViolations fSpec, r == rule, v <- vs]
+                           in  "[" ++ intercalate ", " pairs ++ "]"
+              
− src/exec/Main.hs 
@@ -1,20 +0,0 @@-{-# OPTIONS_GHC -Wall #-}-module Main where--import Control.Monad-import System.Exit-import Prelude hiding (readFile,writeFile)-import Data.List (intersperse)-import DatabaseDesign.Ampersand (getOptions, showErr, showVersion, showHelp, helpNVersionTexts, ampersandVersionStr, createFspec, Guarded(..), generateAmpersandOutput)--main :: IO ()-main =- do flags <- getOptions-    if showVersion flags || showHelp flags-    then mapM_ putStr (helpNVersionTexts ampersandVersionStr flags)-    else do gFspec <- createFspec flags-            case gFspec of-              Errors err -> do Prelude.putStrLn $ "Error(s) found:"-                               mapM_ putStrLn (intersperse  (replicate 30 '=') (map showErr err))-                               exitWith $ ExitFailure 10-              Checked fspc -> generateAmpersandOutput flags fspc
− src/lib/DatabaseDesign/Ampersand.hs 
@@ -1,111 +0,0 @@-{-# OPTIONS_GHC -Wall #-}
-module DatabaseDesign.Ampersand
-   ( -- Data Constructors:
-     A_Context
-   , P_Context(..), P_Population(..), PairView(..), PairViewSegment(..), SrcOrTgt(..), P_Rule(..), Term(..), TermPrim(..), P_Sign(..), P_Concept(..), P_Declaration(..), P_Pattern(..), P_Gen(..)
-   , P_Markup(..), PRef2Obj(..), PPurpose(..), PMeaning(..), Meta(..), MetaObj(..)
-   , A_Concept(..), A_Gen(..)
-   , Sign(..), ConceptDef(..), ConceptStructure(..)
-   , Activity(..)
-   , AMeaning(..)
-   , Quad(..), RuleClause(..)
-   , Fswitchboard(..), ECArule(..), Event(..), InsDel(..) -- (required for --haskell output)
-   , Pattern(..)
-   , Declaration(..)
-   , IdentityDef(..)
-   , ViewDef(..)
-   , IdentitySegment(..)
-   , ViewSegment(..)
-   , Expression(..)
-   , Population(..)
-   , Fspc(..), concDefs
-   , PlugSQL(..), SqlField(..), SqlType(..), PlugInfo(..)
-   , PAclause(..)
-   , Rule(..)
-   , Process(..) , FProcess(..)
-   , Prop(..), RuleOrigin(..)
-   , Lang(..)
-   , SqlFieldUsage(..)
-   , DnfClause(..), Clauses(..)
-   , Options(..), DocTheme(..)
-   , Picture(..), writePicture , PictureReq(..), makePicture
-   , FilePos(..), Origin(..), Pos(Pos)
-   , FPA(..), FPcompl(..)
-   , mkPair
-   -- * Classes:
-   , Association(..), flp
-   , Collection(..)
-   , Identified(..)
-   , ProcessStructure(..)
-   , ObjectDef(..)
-   , Relational(..)
-   , Interface(..)
-   , SubInterface(..)
-   , Object(..)
-   , Plugable(..)
-   , Motivated(..)
-   , Traced(..)
-   , Language(..)
-   , FPAble(..)
-   , ShowHS(..), ShowHSName(..), haskellIdentifier
-   -- * Functions on concepts
-   , (<==>),meet,join,sortWith,atomsOf
-   , smallerConcepts, largerConcepts, rootConcepts
-   -- * Functions on relations
-   -- * Functions on rules
-   -- * Functions on expressions:
-   , conjNF, disjNF, simplify
-   , cfProof,dfProof,nfProof,normPA
-   , lookupCpt
-   , showPrf
-   , notCpl, isCpl, isPos, isNeg, foldrMapExpression
-      , (.==.), (.|-.), (./\.), (.\/.), (.-.), (./.), (.\.), (.<>.), (.:.), (.!.), (.*.)
-   , deMorganERad, deMorganECps, deMorganEUni, deMorganEIsc
-   , exprUni2list, exprIsc2list, exprCps2list, exprRad2list, exprPrd2list
-   -- * Functions with plugs:
-   , plugFields, tblcontents, plugpath, fldauto, requires, requiredFields, isPlugIndex
-   -- * Parser related stuff
-   , parseADL1pExpr, CtxError 
-   , createFspec
-   , getGeneralizations, getSpecializations
-    -- * Type checking and calculus
-   , Guarded(..), pCtx2aCtx
-   , makeFspec
-    -- * Generators of output
-   , generateAmpersandOutput
-   -- * Prettyprinters
-   , ShowADL(..), showSQL, showSign
-   -- * Functions with Options
-   , getOptions
-   , verboseLn, verbose
-   , FileFormat(..),helpNVersionTexts
-   -- * Other functions
-   , eqCl, showErr, unCap,upCap,escapeNonAlphaNum, fatalMsg
-   , ampersandVersionStr, ampersandVersionWithoutBuildTimeStr
-   , DatabaseDesign.Ampersand.Basics.putStr
-   , DatabaseDesign.Ampersand.Basics.hGetContents
-   , DatabaseDesign.Ampersand.Basics.hPutStr
-   , DatabaseDesign.Ampersand.Basics.hPutStrLn
-   , DatabaseDesign.Ampersand.Basics.readFile
-   , DatabaseDesign.Ampersand.Basics.writeFile
-   -- * Stuff that should probably not be in the prototype
-   , A_Markup(..), blocks2String, aMarkup2String, PandocFormat(..), Meaning(..)
-   , rulefromProp
-   , fullContents, Paire, srcPaire,trgPaire
-   , Purpose(..), ExplObj(..)
-   )
-where
-import DatabaseDesign.Ampersand.Core.AbstractSyntaxTree
-import DatabaseDesign.Ampersand.Fspec.Fspec
-import DatabaseDesign.Ampersand.Fspec.FPA
-import DatabaseDesign.Ampersand.ADL1 
-import DatabaseDesign.Ampersand.Classes
-import DatabaseDesign.Ampersand.Basics 
-import DatabaseDesign.Ampersand.Fspec
-import DatabaseDesign.Ampersand.Input
-import DatabaseDesign.Ampersand.Misc
-import DatabaseDesign.Ampersand.Components 
-import DatabaseDesign.Ampersand.ADL1.Expression (isPos,isNeg,foldrMapExpression)
-import DatabaseDesign.Ampersand.Fspec.ToFspec.NormalForms
-import DatabaseDesign.Ampersand.InputProcessing
-import DatabaseDesign.Ampersand.ADL1.P2A_Converters
− src/lib/DatabaseDesign/Ampersand/ADL1.hs 
@@ -1,65 +0,0 @@-{-# OPTIONS_GHC -Wall #-}
-module DatabaseDesign.Ampersand.ADL1 (module X) 
-where
-import DatabaseDesign.Ampersand.Core.ParseTree as X (
-           PPurpose(..), PRef2Obj(..)
-         , Paire, Pairs, mkPair , srcPaire, trgPaire
-         , Label(..)
-         , FilePos(..), Origin(..), Pos(..), Traced(..)
-         , Prop(..)
-         , P_Concept(..)
-         , P_Sign(..)
-         , P_Context(..)
-         , Meta(..)
-         , MetaObj(..)
-         , P_Process(..), P_RoleRelation(..), RoleRule(..)
-         , P_Pattern(..)
-         , PairView(..), PairViewSegment(..)
-         , SrcOrTgt(..)
-         , P_Rule(..)
-         , P_IdentDef(..), P_IdentSegment(..)
-         , P_ViewDef, P_ViewSegment
-         , P_Population(..)
-         , P_ObjectDef
-         , P_Interface(..)
-         , P_SubInterface
-         , Term(..)
-         , TermPrim(..)
-         , P_Gen(..)
-         , P_Declaration(..)
-         , ConceptDef(..)
-         , gen_concs
-         )
-import DatabaseDesign.Ampersand.Core.AbstractSyntaxTree as X  (
-          A_Concept(..)
-         ,Sign(..),showSign,GenR()
-         , (<==>),meet,join
-         ,A_Context(..),Process(..)
-         ,Association(..)
-         ,Expression(..)
-         ,A_Gen(..)
-         ,IdentityDef(..)
-         ,IdentitySegment(..)
-         ,ViewDef(..)
-         ,ViewSegment(..)
-         ,ObjectDef(..)
-         ,SubInterface(..)
-         ,Declaration(..),decusr
-         ,Interface(..)
-         ,Pattern(..)
-         ,Rule(..)
-         ,RuleType(..)
-         ,RoleRelation(..)
-         ,Population(..)
-         ,Purpose(..), ExplObj(..)
-         , (.==.), (.|-.), (./\.), (.\/.), (.-.), (./.), (.\.), (.<>.), (.:.), (.!.), (.*.)
-         )
-import DatabaseDesign.Ampersand.ADL1.Expression as X
-         ( notCpl, isCpl, deMorganERad, deMorganECps, deMorganEUni, deMorganEIsc
-         , exprIsc2list, exprUni2list, exprCps2list, exprRad2list, exprPrd2list
-         , insParentheses)
-import DatabaseDesign.Ampersand.ADL1.ECArule as X (
-         isAll, isCHC, isBlk, isNop, isDo, eventsFrom)
-import DatabaseDesign.Ampersand.ADL1.Rule as X (
-          rulefromProp, ruleviolations
-         ,consequent,antecedent,hasantecedent)

− src/lib/DatabaseDesign/Ampersand/ADL1/Disambiguate.hs 
@@ -1,219 +0,0 @@-{-# OPTIONS_GHC -Wall -XFlexibleInstances -XDataKinds #-}-{-# LANGUAGE RelaxedPolyRec #-}-module DatabaseDesign.Ampersand.ADL1.Disambiguate(disambiguate, gc, DisambPrim(..)) where-import DatabaseDesign.Ampersand.Core.ParseTree-import DatabaseDesign.Ampersand.Core.AbstractSyntaxTree hiding (sortWith, maxima, greatest)-import DatabaseDesign.Ampersand.Basics (Identified(name), fatalMsg)-import Prelude hiding (head, sequence, mapM)-import Control.Applicative-import Data.Traversable-import qualified Data.Set as Set--disambiguate :: (Traversable d, Disambiguatable d) =>-                (a -> (TermPrim, DisambPrim)) -- disambiguation function-                -> d a -- object to be disambiguated-                -> d (TermPrim, DisambPrim) -- disambiguated object-disambiguate termPrimDisAmb x = fixpoint disambiguationStep (Change (fmap termPrimDisAmb x) False)--fatal :: Int -> String -> a-fatal = fatalMsg "ADL1.Disambiguate"--findConceptOrONE :: String -> A_Concept-findConceptOrONE "ONE" = ONE-findConceptOrONE x = findConcept x---- TODO: Can we use Uniplate in place of disambiguatable?--findConcept :: String -> A_Concept--- SJC: ONE should be tokenized, so it cannot occur as a string--- especially because we require that concepts are identifiable by their name--- hence if this line would change the semantics, we have either--- (1) made a programming error in the call of findConcept (in which case you should call findConceptOrONE instead)--- (2) made an error in the tokenizer/parser-findConcept "ONE" = fatal 200 "ONE is not a valid name for a concept"-findConcept x = PlainConcept {cptnm = x}--class Disambiguatable d where-  disambInfo :: d (TermPrim,DisambPrim)-   -> ( [(DisambPrim,SrcOrTgt)], [(DisambPrim,SrcOrTgt)] ) -- the inferred types (from the environment = top down)-   -> ( d ((TermPrim,DisambPrim), ([(DisambPrim,SrcOrTgt)],[(DisambPrim,SrcOrTgt)])) -- only the environment for the term (top down)-      , ( [(DisambPrim,SrcOrTgt)], [(DisambPrim,SrcOrTgt)] ) -- the inferred type, bottom up (not including the environment, that is: not using the second argument: prevent loops!)-      )--instance Disambiguatable P_Rule where-  disambInfo (P_Ru nm expr fps mean msg Nothing) x-   = (P_Ru nm exp' fps mean msg Nothing, rt)-   where (exp',rt) = disambInfo expr x-  disambInfo (P_Ru nm expr fps mean msg (Just viol)) x-   = (P_Ru nm exp' fps mean msg (Just viol'), rt)-   where (exp',rt) = disambInfo expr x-         (PairViewTerm viol',_) -- SJ 20131123: disambiguation does not depend on the contents of this pairview, but must come from outside...-          = (disambInfo (PairViewTerm viol) rt)-instance Disambiguatable PairViewTerm where-  disambInfo (PairViewTerm (PairView lst)) x-   = (PairViewTerm (PairView [pv' | pv <- lst, let (PairViewSegmentTerm pv',_) = disambInfo (PairViewSegmentTerm pv) x])-     , ([],[])) -- unrelated-instance Disambiguatable PairViewSegmentTerm where-  disambInfo (PairViewSegmentTerm (PairViewText s)) _ = (PairViewSegmentTerm (PairViewText s), ([],[]))-  disambInfo (PairViewSegmentTerm (PairViewExp st a)) (sr,tg) = (PairViewSegmentTerm (PairViewExp st res), rt)-    where t = case st of-               Src -> sr-               Tgt -> tg-          (res,rt) = disambInfo a (t,[])-instance Disambiguatable P_ViewD where-  disambInfo (P_Vd { vd_pos = o-                   , vd_lbl = s-                   , vd_cpt = c-                   , vd_ats = a-                   }) _ = (P_Vd o s c (map (\x -> fst (disambInfo x (c',[]))) a), (c',[]))-   where c' = [(Known (EDcI (pCpt2aCpt c)),Src)]--instance Disambiguatable P_ViewSegmt where-  disambInfo (P_ViewText a) _ = (P_ViewText a,([],[]))-  disambInfo (P_ViewHtml a) _ = (P_ViewHtml a,([],[]))-  disambInfo (P_ViewExp a) i = (P_ViewExp a',r)-    where (a',r) = disambInfo a i--instance Disambiguatable P_SubIfc where-  disambInfo (P_InterfaceRef a b) _   = (P_InterfaceRef a b,([],[]))-  disambInfo (P_Box o []   ) _        = (P_Box o [],([],[]))-  disambInfo (P_Box o (a:lst)) (x,_)  = (P_Box o (a':lst'),(r++nxt,[]))-   where (a', (r,_))            = disambInfo a (nxt++x,[])-         (P_Box _ lst',(nxt,_)) = disambInfo (P_Box o lst) (x++r,[])--instance Disambiguatable P_ObjDef where-  disambInfo (P_Obj a b c -- term/expression-                        d -- (potential) subobject-                        f)-                        (r,_) -- from the environment, only the source is important-   = (P_Obj a b c' d' f, (r0,[]) -- only source information should be relevant-     )-    where-     (d', (r1,_))-      = case d of-           Nothing -> (Nothing,([],[]))-           Just si -> (\(x,y)->(Just x,y)) $ disambInfo si (r2,[])-     (c', (r0,r2))-      = disambInfo c (r,r1)-instance Disambiguatable Term where-  disambInfo (PFlp o a  ) (ia1,ib1) = ( PFlp o a', (ib2,ia2) )-   where (a', (ia2,ib2)) = disambInfo a (ib1, ia1)-  disambInfo (PCpl o a  ) (ia1,ib1) = ( PCpl o a', (ia2,ib2) )-   where (a', (ia2,ib2)) = disambInfo a (ia1, ib1)-  disambInfo (PBrk o a  ) (ia1,ib1) = ( PBrk o a', (ia2,ib2) )-   where (a', (ia2,ib2)) = disambInfo a (ia1, ib1)-  disambInfo (PKl0 o a  ) (ia1,ib1) = ( PKl0 o a', (ia2++ib2,ia2++ib2) )-   where (a', (ia2,ib2)) = disambInfo a (ia1++ib1, ia1++ib1)-  disambInfo (PKl1 o a  ) (ia1,ib1) = ( PKl1 o a', (ia2++ib2,ia2++ib2) )-   where (a', (ia2,ib2)) = disambInfo a (ia1++ib1, ia1++ib1)-  disambInfo (Pequ o a b) (ia1,ib1) = ( Pequ o a' b', (ia2++ia3, ib2++ib3) )-   where (a', (ia2,ib2)) = disambInfo a (ia1++ia3, ib1++ib3)-         (b', (ia3,ib3)) = disambInfo b (ia1++ia2, ib1++ib2)-  disambInfo (Pimp o a b) (ia1,ib1) = ( Pimp o a' b', (ia2++ia3, ib2++ib3) )-   where (a', (ia2,ib2)) = disambInfo a (ia1++ia3, ib1++ib3)-         (b', (ia3,ib3)) = disambInfo b (ia1++ia2, ib1++ib2)-  disambInfo (PIsc o a b) (ia1,ib1) = ( PIsc o a' b', (ia2++ia3, ib2++ib3) )-   where (a', (ia2,ib2)) = disambInfo a (ia1++ia3, ib1++ib3)-         (b', (ia3,ib3)) = disambInfo b (ia1++ia2, ib1++ib2)-  disambInfo (PUni o a b) (ia1,ib1) = ( PUni o a' b', (ia2++ia3, ib2++ib3) )-   where (a', (ia2,ib2)) = disambInfo a (ia1++ia3, ib1++ib3)-         (b', (ia3,ib3)) = disambInfo b (ia1++ia2, ib1++ib2)-  disambInfo (PDif o a b) (ia1,ib1) = ( PDif o a' b', (ia2++ia3, ib2++ib3) )-   where (a', (ia2,ib2)) = disambInfo a (ia1++ia3, ib1++ib3)-         (b', (ia3,ib3)) = disambInfo b (ia1++ia2, ib1++ib2)-  disambInfo (PLrs o a b) (ia1,ib1) = ( PLrs o a' b', (ia, ib) )-   where (a', (ia,ic1)) = disambInfo a (ia1,ic2)-         (b', (ib,ic2)) = disambInfo b (ib1,ic1)-  disambInfo (PRrs o a b) (ia1,ib1) = ( PRrs o a' b', (ia, ib) )-   where (a', (ic1,ia)) = disambInfo a (ic2,ia1)-         (b', (ic2,ib)) = disambInfo b (ic1,ib1)-  disambInfo (PDia o a b) (ia1,ib1) = ( PDia o a' b', (ia, ib) )-   where (a', (ia,ic1)) = disambInfo a (ia1,ic2)-         (b', (ib,ic2)) = disambInfo b (ib1,ic1)-  disambInfo (PCps o a b) (ia1,ib1) = ( PCps o a' b', (ia, ib) )-   where (a', (ia,ic1)) = disambInfo a (ia1,ic2)-         (b', (ic2,ib)) = disambInfo b (ic1,ib1)-  disambInfo (PRad o a b) (ia1,ib1) = ( PRad o a' b', (ia, ib) )-   where (a', (ia,ic1)) = disambInfo a (ia1,ic2)-         (b', (ic2,ib)) = disambInfo b (ic1,ib1)-  disambInfo (PPrd o a b) (ia1,ib1) = ( PPrd o a' b', (ia, ib) )-   where (a', (ia,ic1)) = disambInfo a (ia1,ic2)-         (b', (ic2,ib)) = disambInfo b (ic1,ib1)-  disambInfo (Prim (a,b)) st = (Prim ((a,b), st), ([(b,Src)], [(b,Tgt)]) )--data DisambPrim- = Rel [Expression]- | Ident- | Vee- | Mp1 String- | Known Expression deriving Show  -- Here, deriving Show serves debugging purposes only.---- get concept:-gc :: Association expr => SrcOrTgt -> expr -> String-gc Src e = name (source e)-gc Tgt e = name (target e)--disambiguationStep :: (Disambiguatable d, Traversable d) => d (TermPrim, DisambPrim) -> Change (d (TermPrim, DisambPrim))-disambiguationStep x = traverse performUpdate withInfo- where (withInfo, _) = disambInfo x ([],[])--performUpdate :: ((t, DisambPrim),-                     ([(DisambPrim, SrcOrTgt)], [(DisambPrim, SrcOrTgt)]))-                     -> Change (t, DisambPrim)-performUpdate ((t,unkn), (srcs',tgts'))- = case unkn of-     Known _ -> pure (t,unkn)-     Rel xs  -> determineBySize (\x -> if length x == length xs then pure (Rel xs) else impure (Rel x))-                ((findMatch' (mustBeSrc,mustBeTgt) xs `orWhenEmpty` findMatch' (mayBeSrc,mayBeTgt) xs)-                 `orWhenEmpty` xs)-     Ident   -> determineBySize suggest (map (\a -> EDcI (findConceptOrONE a)) (Set.toList possibleConcs))-     Mp1 s   -> determineBySize suggest (map (\a -> EMp1 s (findConceptOrONE a)) (Set.toList possibleConcs)) -- SJ20140211 @SJC: TODO hier moeten wellicht SESSION atomen worden uitgesloten. Kun jij deze TODO oplossen en verwijderen?-     Vee     -> determineBySize (const (pure unkn))-                  [EDcV (Sign (findConceptOrONE a) (findConceptOrONE b)) | a<-Set.toList mustBeSrc, b<-Set.toList mustBeTgt]- where-   suggest [] = pure unkn-   suggest lst = impure (Rel lst) -- TODO: find out whether it is equivalent to put "pure" here (which could be faster).-   possibleConcs = (mustBeSrc `isc` mustBeTgt) `orWhenEmptyS`-                   (mustBeSrc `uni` mustBeTgt) `orWhenEmptyS`-                   (mayBeSrc  `isc` mayBeTgt ) `orWhenEmptyS`-                   (mayBeSrc  `uni` mayBeTgt )-   findMatch' (a,b) = findMatch (Set.toList a,Set.toList b)-   findMatch ([],[]) _ = []-   findMatch ([],tgts) lst-    = [x | x<-lst, gc Tgt x `elem` tgts]-   findMatch (srcs,[]) lst-    = [x | x<-lst, gc Src x `elem` srcs]-   findMatch (srcs,tgts) lst-    = [x | x<-lst, gc Src x `elem` srcs, gc Tgt x `elem` tgts]-   mustBeSrc = mustBe srcs'-   mustBeTgt = mustBe tgts'-   mayBeSrc = mayBe srcs'-   mayBeTgt = mayBe tgts'-   mustBe xs = Set.fromList [gc sot x | (Known x, sot) <- xs]-   mayBe  xs = Set.fromList [gc sot x | (Rel x' , sot) <- xs, x<-x']-   orWhenEmptyS a b = if (Set.null a) then b else a-   orWhenEmpty a b = if (null a) then b else a-   determineBySize _   [a] = impure (t,Known a)-   determineBySize err lst = fmap ((,) t) (err lst)-   impure x = Change x False-   isc = Set.intersection-   uni = Set.union--pCpt2aCpt :: P_Concept -> A_Concept-pCpt2aCpt pc-    = case pc of-        PCpt{} -> findConcept (p_cptnm pc)-        P_Singleton -> ONE   --data Change a = Change a Bool-instance Functor Change where- fmap f (Change a b) = Change (f a) b-instance Applicative Change where- (<*>) (Change f b) (Change a b2) = Change (f a) (b && b2)- pure a = Change a True--fixpoint :: (a -> Change a) -- function for computing a fixpoint-         -> (Change a) -- has the fixpoint been reached?-         -> a-fixpoint _ (Change a True)  = a-fixpoint f (Change a False) = fixpoint f (f a)
− src/lib/DatabaseDesign/Ampersand/ADL1/ECArule.hs 
@@ -1,76 +0,0 @@-{-# OPTIONS_GHC -Wall #-}
-module DatabaseDesign.Ampersand.ADL1.ECArule ( isAll
-                                             , isCHC
-                                             , isBlk
-                                             , isNop
-                                             , isDo
-                                             , eventsFrom
-                                             )
-where
-import DatabaseDesign.Ampersand.Core.AbstractSyntaxTree
-import DatabaseDesign.Ampersand.Fspec.Fspec
-import DatabaseDesign.Ampersand.Basics     (fatalMsg)
-
-  --   Ampersand derives the process logic from the static logic by interpreting an expression in relation algebra as an invariant.
-  --   So how does Ampersand derive dynamic behaviour from static rules? An example may clarify this:
-  --   Suppose you have large shoes that do not fit through your trousers in any way.
-  --   Does this have any consequences for the process of dressing in the morning?
-  --   Well sure it has!
-  --   Since your shoes won't fit through your trousers, you must first put on your trousers, and then put on your shoes.
-  --   So the order of putting on trousers and putting on shoes is dictated by the (static) fact that your shoes are too big to fit through your trousers.
-  --   When undressing, the order is reversed: you must take off your shoes before taking off your trousers.
-  --   This example ilustrates how the order of activities is restricted by an invariant property.
-  --   So it is possible to derive some dynamic behaviour from static properties.
-  --   The following datatypes form a process algebra.
-fatal :: Int -> String -> a
-fatal = fatalMsg "ADL1.ECArule"
-
-
-isAll :: PAclause -> Bool
-isAll ALL{} = True
-isAll _     = False
-  
-isCHC :: PAclause -> Bool
-isCHC CHC{} = True
-isCHC _     = False
-  
-isBlk :: PAclause -> Bool
-isBlk Blk{} = True
-isBlk _     = False
-  
-isNop :: PAclause -> Bool
-isNop Nop{} = True
-isNop _     = False
-  
-isDo :: PAclause -> Bool
-isDo Do{}   = True
-isDo _      = False
-
-{-
-             | Do  { paSrt :: InsDel                     -- do Insert or Delete
-                    , paTo :: Declaration                 -- into toExpr    or from toExpr
-                    , paDelta :: Expression               -- delta
-                    , paMotiv :: [(Expression,[Rule] )]
- 
-              | New { paCpt :: A_Concept                  -- make a new instance of type c
-                    , paCl :: String->PAclause            -- to be done after creating the concept
-                    , paMotiv :: [(Expression,[Rule] )]
-                    }
-              | Rmv { paCpt :: A_Concept                  -- Remove an instance of type c
-                    , paCl :: String->PAclause            -- to be done afteremoving the concept
-                    , paMotiv :: [(Expression,[Rule] )]
-                    }
--}
- 
--- | eventsFrom is written for constructing switchboard diagrams.
-eventsFrom :: PAclause -> [Event]   -- gather all Do's from a PAclause
-eventsFrom p@CHC{}          = concatMap eventsFrom (paCls p)
-eventsFrom p@GCH{}          = concatMap eventsFrom [ paClause | (_,_,paClause)<-paGCls p]
-eventsFrom p@ALL{}          = concatMap eventsFrom (paCls p)
-eventsFrom (Do tOp dcl _ _) = [On tOp dcl]
-eventsFrom p@New{}          = On Ins (Isn (paCpt p)): eventsFrom (paCl p "x")
-eventsFrom p@Rmv{}          = On Del (Isn (paCpt p)): eventsFrom (paCl p "x")
-eventsFrom Nop{}            = []
-eventsFrom Blk{}            = []
-eventsFrom Let{}            = fatal 56 "eventsFrom not defined for `Let` constructor of PAclause"
-eventsFrom Ref{}            = fatal 57 "eventsFrom not defined for `Ref` constructor of PAclause"

− src/lib/DatabaseDesign/Ampersand/ADL1/Expression.hs 
@@ -1,220 +0,0 @@-{-# OPTIONS_GHC -Wall #-}
-{-# LANGUAGE TypeSynonymInstances , OverlappingInstances #-}
-module DatabaseDesign.Ampersand.ADL1.Expression (
-                       subst
-                      ,foldlMapExpression,foldrMapExpression
-                      ,primitives,isMp1, isEEps
-                      ,isPos,isNeg, deMorganERad, deMorganECps, deMorganEUni, deMorganEIsc, notCpl, isCpl
-                      ,exprIsc2list, exprUni2list, exprCps2list, exprRad2list, exprPrd2list
-                      ,insParentheses)
-where
-import DatabaseDesign.Ampersand.Basics (uni)
-import DatabaseDesign.Ampersand.Core.AbstractSyntaxTree
---import Debug.Trace
-
--- fatal :: Int -> String -> a
--- fatal = fatalMsg "ADL1.Expression"
-
--- | subst is used to replace each occurrence of a relation
---   with an expression. The parameter expr will therefore be applied to an
---   expression of the form Erel rel.
-subst :: (Declaration,Expression) -> Expression -> Expression
-subst (decl,expr) = subs
-     where
-       subs (EEqu (l,r)) = EEqu (subs l,subs r)
-       subs (EImp (l,r)) = EImp (subs l,subs r)
-       subs (EIsc (l,r)) = EIsc (subs l,subs r)
-       subs (EUni (l,r)) = EUni (subs l,subs r)
-       subs (EDif (l,r)) = EDif (subs l,subs r)
-       subs (ELrs (l,r)) = ELrs (subs l,subs r)
-       subs (ERrs (l,r)) = ERrs (subs l,subs r)
-       subs (EDia (l,r)) = EDia (subs l,subs r)
-       subs (ECps (l,r)) = ECps (subs l,subs r)
-       subs (ERad (l,r)) = ERad (subs l,subs r)
-       subs (EPrd (l,r)) = EPrd (subs l,subs r)
-       subs (EKl0 e    ) = EKl0 (subs e)
-       subs (EKl1 e    ) = EKl1 (subs e)
-       subs (EFlp e    ) = EFlp (subs e)
-       subs (ECpl e    ) = ECpl (subs e)
-       subs (EBrk e)     = EBrk (subs e)
-       subs e@(EDcD d  ) | d==decl   = expr
-                         | otherwise = e
-       subs e@EDcI{}     = e
-       subs e@EEps{}     = e
-       subs e@EDcV{}     = e
-       subs e@EMp1{}     = e
-
-foldlMapExpression :: (a -> r -> a) -> (Declaration->r) -> a -> Expression -> a
-foldlMapExpression f = foldrMapExpression f' where f' x y = f y x
-
-foldrMapExpression :: (r -> a -> a) -> (Declaration->r) -> a -> Expression -> a
-foldrMapExpression f g a (EEqu (l,r)) = foldrMapExpression f g (foldrMapExpression f g a l) r
-foldrMapExpression f g a (EImp (l,r)) = foldrMapExpression f g (foldrMapExpression f g a l) r
-foldrMapExpression f g a (EIsc (l,r)) = foldrMapExpression f g (foldrMapExpression f g a l) r
-foldrMapExpression f g a (EUni (l,r)) = foldrMapExpression f g (foldrMapExpression f g a l) r
-foldrMapExpression f g a (EDif (l,r)) = foldrMapExpression f g (foldrMapExpression f g a l) r
-foldrMapExpression f g a (ELrs (l,r)) = foldrMapExpression f g (foldrMapExpression f g a l) r
-foldrMapExpression f g a (ERrs (l,r)) = foldrMapExpression f g (foldrMapExpression f g a l) r
-foldrMapExpression f g a (EDia (l,r)) = foldrMapExpression f g (foldrMapExpression f g a l) r
-foldrMapExpression f g a (ECps (l,r)) = foldrMapExpression f g (foldrMapExpression f g a l) r
-foldrMapExpression f g a (ERad (l,r)) = foldrMapExpression f g (foldrMapExpression f g a l) r
-foldrMapExpression f g a (EPrd (l,r)) = foldrMapExpression f g (foldrMapExpression f g a l) r
-foldrMapExpression f g a (EKl0 e)     = foldrMapExpression f g a                         e
-foldrMapExpression f g a (EKl1 e)     = foldrMapExpression f g a                         e
-foldrMapExpression f g a (EFlp e)     = foldrMapExpression f g a                         e
-foldrMapExpression f g a (ECpl e)     = foldrMapExpression f g a                         e
-foldrMapExpression f g a (EBrk e)     = foldrMapExpression f g a                         e
-foldrMapExpression f g a (EDcD d)     = f (g d) a
-foldrMapExpression _ _ a  EDcI{}      = a
-foldrMapExpression _ _ a  EEps{}      = a
-foldrMapExpression _ _ a  EDcV{}      = a
-foldrMapExpression _ _ a  EMp1{}      = a
-
-primitives :: Expression -> [Expression]
-primitives expr =
-  case expr of
-    (EEqu (l,r)) -> primitives l `uni` primitives r
-    (EImp (l,r)) -> primitives l `uni` primitives r
-    (EIsc (l,r)) -> primitives l `uni` primitives r
-    (EUni (l,r)) -> primitives l `uni` primitives r
-    (EDif (l,r)) -> primitives l `uni` primitives r
-    (ELrs (l,r)) -> primitives l `uni` primitives r
-    (ERrs (l,r)) -> primitives l `uni` primitives r
-    (EDia (l,r)) -> primitives l `uni` primitives r
-    (ECps (l,r)) -> primitives l `uni` primitives r
-    (ERad (l,r)) -> primitives l `uni` primitives r
-    (EPrd (l,r)) -> primitives l `uni` primitives r
-    (EKl0 e)     -> primitives e
-    (EKl1 e)     -> primitives e
-    (EFlp e)     -> primitives e
-    (ECpl e)     -> primitives e
-    (EBrk e)     -> primitives e
-    EDcD{}       -> [expr]
-    EDcI{}       -> [expr]
-    EEps{}       -> []  -- Since EEps is inserted for typing reasons only, we do not consider it a primitive..
-    EDcV{}       -> [expr]
-    EMp1{}       -> [expr]
-
--- | The rule of De Morgan requires care with respect to the complement.
---   The following function provides a function to manipulate with De Morgan correctly.
-deMorganERad :: Expression -> Expression
-deMorganERad (ECpl (ERad (l,r)))
-  = notCpl (deMorganERad l) .:. notCpl (deMorganERad r)
-deMorganERad (ERad (l,r))
-  = notCpl (notCpl (deMorganERad l) .:. notCpl (deMorganERad r))
-deMorganERad e = e
-deMorganECps :: Expression -> Expression
-deMorganECps (ECpl (ECps (l,r)))
-  = notCpl (deMorganECps l) .!. notCpl (deMorganECps r)
-deMorganECps (ECps (l,r))
-  = notCpl (notCpl (deMorganECps l) .!. notCpl (deMorganECps r))
-deMorganECps e = e
-deMorganEUni :: Expression -> Expression
-deMorganEUni (ECpl (EUni (l,r)))
-  = notCpl (deMorganEUni l) ./\. notCpl (deMorganEUni r)
-deMorganEUni (EUni (l,r))
-  = notCpl (notCpl (deMorganEUni l) ./\. notCpl (deMorganEUni r))
-deMorganEUni e = e
-deMorganEIsc :: Expression -> Expression
-deMorganEIsc (ECpl (EIsc (l,r)))
-  = notCpl (deMorganEIsc l) .\/. notCpl (deMorganEIsc r)
-deMorganEIsc (EIsc (l,r))
-  = notCpl (notCpl (deMorganEIsc l) .\/. notCpl (deMorganEIsc r))
-deMorganEIsc e = e
-
-notCpl :: Expression -> Expression
-notCpl (ECpl e) = e
-notCpl e = ECpl e
-
-isCpl :: Expression -> Bool
-isCpl (ECpl{}) = True
-isCpl _ = False
-
-isPos :: Expression -> Bool
-isPos (ECpl{}) = False
-isPos _ = True
-isNeg :: Expression -> Bool
-isNeg = not . isPos 
-
-isMp1 :: Expression -> Bool
-isMp1 EMp1{} = True
-isMp1 _ = False
-
-isEEps :: Expression -> Bool
-isEEps EEps{} = True
-isEEps _ = False
-
-exprIsc2list, exprUni2list, exprCps2list, exprRad2list, exprPrd2list :: Expression -> [Expression]
-exprIsc2list (EIsc (l,r)) = exprIsc2list l++exprIsc2list r
-exprIsc2list r            = [r]
-exprUni2list (EUni (l,r)) = exprUni2list l++exprUni2list r
-exprUni2list r            = [r]
-exprCps2list (ECps (l,r)) = exprCps2list l++exprCps2list r
-exprCps2list r            = [r]
-exprRad2list (ERad (l,r)) = exprRad2list l++exprRad2list r
-exprRad2list r            = [r]
-exprPrd2list (EPrd (l,r)) = exprPrd2list l++exprPrd2list r
-exprPrd2list r            = [r]
-
-insParentheses :: Expression -> Expression
-insParentheses expr = insPar 0 expr
-   where
-     wrap :: Integer -> Integer -> Expression -> Expression
-     wrap i j e' = if i<=j then e' else EBrk (insPar 0 e')
-     insPar :: Integer -> Expression -> Expression
-     insPar i  (EEqu (l,r)) = wrap i 0 (insPar 1 l .==. insPar 1 r)
-     insPar i  (EImp (l,r)) = wrap i 0 (insPar 1 l .|-. insPar 1 r)
-     insPar i x@EIsc{}      = wrap i 2 (foldr1 (./\.) [insPar 3 e | e<-exprIsc2list x ])
-     insPar i x@EUni{}      = wrap i 2 (foldr1 (.\/.) [insPar 3 e | e<-exprUni2list x ])
-     insPar i  (EDif (l,r)) = wrap i 4 (insPar 5 l .-. insPar 5 r)
-     insPar i  (ELrs (l,r)) = wrap i 6 (insPar 7 l ./. insPar 7 r)
-     insPar i  (ERrs (l,r)) = wrap i 6 (insPar 7 l .\. insPar 7 r)
-     insPar i  (EDia (l,r)) = wrap i 6 (insPar 7 l .<>. insPar 7 r)
-     insPar i x@ECps{}      = wrap i 8 (foldr1 (.:.) [insPar 9 e | e<-exprCps2list x ])
-     insPar i x@ERad{}      = wrap i 8 (foldr1 (.!.) [insPar 9 e | e<-exprRad2list x ])
-     insPar i x@EPrd{}      = wrap i 8 (foldr1 (.*.) [insPar 9 e | e<-exprPrd2list x ])
-     insPar _  (EKl0 e)     = EKl0 (insPar 10 e)
-     insPar _  (EKl1 e)     = EKl1 (insPar 10 e)
-     insPar _  (EFlp e)     = EFlp (insPar 10 e)
-     insPar _  (ECpl e)     = ECpl (insPar 10 e)
-     insPar i  (EBrk e)     = insPar i e
-     insPar _  x            = x
-
-{-
-   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
--}
-

− src/lib/DatabaseDesign/Ampersand/ADL1/Lattices.hs 
@@ -1,297 +0,0 @@-{-# OPTIONS_GHC -Wall -XFlexibleInstances #-}-module DatabaseDesign.Ampersand.ADL1.Lattices (findExact,findSubsets,optimize1,Op1EqualitySystem,addEquality,emptySystem,FreeLattice(..),getGroups,isInSystem) where-import qualified Data.IntMap as IntMap-import qualified Data.Map as Map-import qualified Data.Set as Set-import qualified Data.IntSet as IntSet-import Data.List (sort, partition)---- optimisations possible for the EqualitySystem(s):--- (1) apply optimize1 inline, that is: don't use EqualitySystem but use ES1 instead--- (2) include the transitively dependent rules recursively-data EqualitySystem a- = ES (Map.Map a Int) -- whatever this is a system of-      (IntMap.IntMap  -- map for: whenever you encounter this element i in your set y-         [( IntSet.IntSet -- when you find this set (that is: if it is a subset of y)-          , IntSet.IntSet -- add this set-          )]-      )--emptySystem :: EqualitySystem a-emptySystem = ES Map.empty IntMap.empty--isInSystem :: (Ord a) => Op1EqualitySystem a -> a -> Bool-isInSystem (ES1 t _ _) a = Map.member a t---- | getGroups: create groups of concepts (type variable: concept).---   1. Each concept is in precisely one group.---   2. Two concepts are in the same group if there is a path of classify-rules between those concepts.---   The purpose of this is to know whether two concepts are comparable or not. Atoms of concepts within a group can be compared.---   Atoms of concepts in different groups may never be compared.-getGroups :: (Ord concept, SetLike set) => Op1EqualitySystem concept -> [set concept]-getGroups (ES1 tran _ imap)- = [fromList [a | (a,i) <- Map.toList tran, not . IntSet.null $ IntSet.intersection i r] | r <- IntMap.elems res]- where-   iml :: [(Int,[(IntSet.IntSet,IntSet.IntSet)])]-   iml = IntMap.toList imap-   (_, _, res) = foldr getLists (0, IntMap.empty, IntMap.empty) ([(IntSet.insert a (IntSet.union b c)) | (a,bc) <- iml, (b,c)<-bc] ++ Map.elems tran)-   getLists :: IntSet.IntSet -> (Int, IntMap.IntMap Int, IntMap.IntMap (IntSet.IntSet)) -> (Int, IntMap.IntMap Int, IntMap.IntMap (IntSet.IntSet))-   getLists im (acc, allElems, rev) -- TODO: this might be made more efficiently by using Array as the last element-    = if not (IntMap.null overlap) then-       (acc, newElems, newRev)-      else (acc+1, IntMap.union (IntMap.fromSet (const acc) im) allElems, IntMap.insert acc im rev)-    where-      overlap = IntMap.intersection allElems (IntMap.fromSet id im) -- overlap between im and the previously treated elements-      oldKeys = IntMap.elems overlap -- sets to which the overlapping items belong-      newKey = head oldKeys -- get any key name-      oldKeySet = IntSet.fromList oldKeys -- remove duplicates, provide efficient lookup-      -- newRev' is all items that will remain the same-      -- newItm' is all (old) items that must be renamed-      ~(newItm', newRev') = IntMap.partitionWithKey (\k _ -> IntSet.member k oldKeySet) rev-      newItm :: IntSet.IntSet-      newItm = IntSet.unions (im : IntMap.elems newItm') -- all -      newRev = IntMap.insert newKey newItm newRev'-      newElems = IntMap.union (IntMap.fromSet (const newKey) newItm) allElems -- overwrites some of the allElems items with the new key--findExact :: (Ord a, SetLike x) => Op1EqualitySystem a -> FreeLattice a -> x a -- returns the empty set on a failure-findExact = findWith lookupInRevMap (\x -> fromList [x])-findSubsets :: (Ord a, SetLike x) => Op1EqualitySystem a -> FreeLattice a -> [x a] -- returns a list of largest subsets-findSubsets = findWith findSubsetInRevMap (\x -> [fromList [x]])--findWith :: Ord a-  => ([Int] -> RevMap a -> b) -- Function that finds the normalized form-  -> (a -> b)                   -- Shorthand in case the FreeLattice does not need to go through the translation process-  -> Op1EqualitySystem a        -- system in which the FreeLattice elements can be found-  -> FreeLattice a              -- the FreeLattice that needs translation-  -> b-findWith f f2 es@(ES1 _ back _) trmUnsimplified-  = case trm of-     Atom x -> f2 x-     _ -> f (IntSet.toList (case trm' of-                       Just t -> intersections (map it t)-                       Nothing -> IntSet.empty-                     )-            ) back-  where it = simplifySet es-        intersections [] = IntSet.empty-        intersections x = foldr1 IntSet.intersection x-        trm' = latticeToTranslatable es trm-        trm = simpl trmUnsimplified-        simpl (Meet a b)-          = case (simpl a, simpl b) of-             (Atom a', Atom b') | a'==b' -> Atom a'-             (a',b') -> Meet a' b'-        simpl (Join a b)-          = case (simpl a, simpl b) of-             (Atom a', Atom b') | a'==b' -> Atom a'-             (a',b') -> Join a' b'-        simpl (Atom x) = Atom x--simplifySet :: Op1EqualitySystem t -> IntSet.IntSet -> IntSet.IntSet-simplifySet (ES1 _ _ imap) x = imapTranslate imap x IntSet.empty--latticeToTranslatable :: Ord a => Op1EqualitySystem a -> FreeLattice a -> Maybe [IntSet.IntSet]-latticeToTranslatable (ES1 m _ _) lt = t lt- where-   t (Atom a)   = do{r<-Map.lookup a m;return [r]}-   t (Meet a b) = do{a'<-t a;b'<- t b;return [IntSet.union ta tb | ta <- a', tb <- b']}-   t (Join a b) = do{a'<-t a;b'<- t b;return (a'++b')}-   ---- how to lookup something in a RevMap (Precondition: list is sorted!)-lookupInRevMap :: (Ord a, SetLike x) => [Int] -> RevMap a -> x a-lookupInRevMap [] (RevMap st _) = fromSet st-lookupInRevMap (a:as) (RevMap _ mp)- = case IntMap.lookup a mp of-    Nothing -> slEmpty-    Just rm -> lookupInRevMap as rm---- a bit slower: suppose we could not find our element in the RevMap, we find all subsets of it (as a RevMap)-findSubsetAsRevMap :: (Ord a) => [Int] -> RevMap a -> RevMap a-findSubsetAsRevMap [] (RevMap st _) = RevMap st IntMap.empty-findSubsetAsRevMap lst (RevMap st mp)- = RevMap st (IntMap.fromList [ (l, rm)-                              | (l, rst) <- listAndRest lst-                              , (Just mp') <- [IntMap.lookup l mp]-                              , let rm@(RevMap st2 mp2) = findSubsetAsRevMap rst mp'-                              , not (Set.null st2 && IntMap.null mp2)-                              ] )---- fins the largest subsets! (endpoints only)-findSubsetInRevMap :: (Ord a, SetLike x) => [Int] -> RevMap a -> [x a]-findSubsetInRevMap lst rm = largestSubset (findSubsetAsRevMap lst rm)--largestSubset :: (Ord a, SetLike x) => RevMap a -> [x a]-largestSubset i- = elimSubsets (endPoints i)- where elimSubsets ((a,v):as) = v : elimSubsets (filter (\x -> not (IntSet.isSubsetOf (fst x) a)) as)-       elimSubsets [] = []--endPoints :: (Ord a, SetLike x) => RevMap a -> [(IntSet.IntSet,x a)]-endPoints (RevMap st im)- = if (IntMap.null im) then (if slNull st then [] else [(IntSet.empty,fromSet st)]) else concatMap endPoints' (IntMap.toList im)- where endPoints' (i,rm) = map addi (endPoints rm)-        where addi (lst,elm) = (IntSet.insert i lst,elm)--listAndRest :: [t] -> [(t, [t])]-listAndRest [] = []-listAndRest (a:rst) = (a,rst):listAndRest rst---data RevMap a- = RevMap (Set.Set a) -- all elements equivalent to this point in the map-          (IntMap.IntMap (RevMap a)) -- recursive-          deriving Show--data Op1EqualitySystem a- = ES1 (Map.Map a (IntSet.IntSet))-       (RevMap a)-       (IntMap.IntMap  -- map for: whenever you encounter this element i in your set y-         [( IntSet.IntSet -- when you find this set (that is: if it is a subset of y)-          , IntSet.IntSet -- add this set-          )]-       )---- TODO: this function can be optimised a lot-reverseMap :: (Ord a) => [(a,[Int])] -> RevMap a-reverseMap lst- = RevMap (Set.fromList (map fst empties)) (buildMap rest)- where-   (empties,rest) = partition (null . snd) lst-   buildMap [] = IntMap.empty-   buildMap o@((_,~(f:_)):_)-     = IntMap.insert f (reverseMap (map tail2 h)) (buildMap tl)-     where tail2 (a,b) = (a, tail b)-           (h,tl) = partition ((== f) . head . snd) o-     -optimize1 :: Ord a => EqualitySystem a -> Op1EqualitySystem a-optimize1 (ES oldmap oldimap)- = ES1 newmap-       (reverseMap (Map.toList (Map.map IntSet.toList newmap)))-       (IntMap.mapMaybe maybeMapper     oldimap)- where notEmpty [] = Nothing-       notEmpty a = Just a-       maybeMapper :: [(IntSet.IntSet,IntSet.IntSet)] -> Maybe [(IntSet.IntSet,IntSet.IntSet)]-       maybeMapper x = notEmpty [ (s1,imapTranslate oldimap s2 (IntSet.empty)) -                                | (s1,s2) <- x-                                , not (IntSet.null s1)-                                , not (IntSet.null s2)-                                ]-       newmap = Map.map (\x -> imapTranslate oldimap (IntSet.singleton x) (IntSet.empty)) oldmap--addEquality :: (Ord a, SetLike x) => (x a, x a) -> EqualitySystem a -> EqualitySystem a-addEquality (set1, set2) eqSys0- = addEquality' eqSys2 ns1 ns2- where-   (eqSys1, ns1) = translateWith eqSys0 set1-   (eqSys2, ns2) = translateWith eqSys1 set2--addEquality' :: Ord a => EqualitySystem a -> IntSet.IntSet -> IntSet.IntSet -> EqualitySystem a-addEquality' ~(ES nms imap) set1 set2- = ES nms (addRule (addRule imap set1 set1 uni) set2 (IntSet.difference set2 set1) uni)- where-   uni = IntSet.union set1 set2-   addRule :: IntMap.IntMap [(IntSet.IntSet, IntSet.IntSet)] -> IntSet.IntSet -> IntSet.IntSet -> IntSet.IntSet -> IntMap.IntMap [(IntSet.IntSet, IntSet.IntSet)]-   addRule oldimap origSet triggers newSet-    = foldl updateMapForTrigger oldimap (IntSet.toList triggers)-    where dif = IntSet.difference newSet origSet-          updateMapForTrigger :: IntMap.IntMap [(IntSet.IntSet, IntSet.IntSet)] -> Int -> IntMap.IntMap [(IntSet.IntSet, IntSet.IntSet)]-          updateMapForTrigger mp trigger-           = IntMap.insertWith (++) trigger [(IntSet.delete trigger origSet, dif)] mp--translateWith :: (Ord a, SetLike x) => EqualitySystem a -> x a -> (EqualitySystem a, IntSet.IntSet)-translateWith ~(ES nomenclature imap) inSet- = ( ES newNomenclature imap-   , IntSet.fromList$ map (newNomenclature Map.!) (getList inSet)-   )- where-  newNomenclature-   = foldr (\x y -> if Map.member x y then y else Map.insert x (Map.size y) y) nomenclature (getList inSet)--imapTranslate :: IntMap.IntMap [(IntSet.IntSet, IntSet.IntSet)] -> IntSet.IntSet -> IntSet.IntSet -> IntSet.IntSet-imapTranslate imap tds doneSet- = case IntSet.minView tds of-    Nothing -> doneSet-    Just (todo,set) -> imapTranslate imap (newSet todo set) (IntSet.insert todo doneSet)- where-  newSet todo set-   = case IntMap.lookup todo imap of-       Nothing -> set-       Just lst -> IntSet.unions (set:[IntSet.difference tl doneSet | (fl,tl) <- lst, IntSet.isSubsetOf fl doneSet])--data FreeLattice a- = Join (FreeLattice a) (FreeLattice a)- | Meet (FreeLattice a) (FreeLattice a)- | Atom a- -instance SetLike [] where-  fromList = id-  fromSet = Set.toList-  toSet = Set.fromList-  getList = id-  slUnion a b = mrgUnion a b-  slIsect a b = mrgIsect a b-  slFold = foldl-  slNull = null-  slSize = length--instance SetLike Set.Set where-  slIsect = Set.intersection-  slUnion = Set.union-  slEmpty = Set.empty-  slUnions = Set.unions-  slMap = Set.map-  getList = Set.toList-  fromList = Set.fromList-  fromSet = id-  isElemOf = Set.member-  slFold f = Set.fold (flip f)-  slNull = Set.null-  slSize = Set.size-  slInsert = Set.insert-  toSet = id--class SetLike x where -- I dislike having to put Ord everywhere, is there another way? (Without including a in the class)-  slIsect :: Ord a => x a -> x a -> x a-  slUnion :: Ord a => x a -> x a -> x a-  getList :: Ord a => x a -> [a]-  fromList :: Ord a => [a] -> x a-  fromSet :: Ord a => Set.Set a -> x a-  slMap :: (Ord a,Ord b) => (a -> b) -> x a -> x b-  slMap f = fromList . nub' . sort . (map f) . getList-  slEmpty :: Ord a => x a-  slEmpty = fromList []-  slUnions :: Ord a => [x a] -> x a-  slUnions = foldr slUnion slEmpty-  isElemOf :: Ord a => a -> x a -> Bool-  isElemOf e mp = (e `elem` getList mp)-  slFold :: Ord b => (a -> b -> a) -> a -> x b -> a-  slFold f u xs = foldl f u (getList xs)-  slSize :: Ord a => x a -> Int-  slSize = length . getList-  slNull :: Ord a => x a -> Bool-  slNull = null . getList-  slInsert :: Ord a => a -> x a -> x a-  slInsert x = slUnion (fromList [x])-  toSet :: Ord a => x a -> Set.Set a-  --nub' :: Eq a => [a] -> [a]-nub' (a:b:bs) | a == b = nub' (b:bs)-              | otherwise = a:nub' (b:bs)-nub' rst = rst--mrgUnion :: (Ord a) => [a] -> [a] -> [a]-mrgUnion (a:as) (b:bs) | a<b       = a:mrgUnion as (b:bs)-                       | a==b      = a:mrgUnion as bs-                       | otherwise = b:mrgUnion (a:as) bs-mrgUnion a b = a ++ b -- since either a or b is the empty list-{-# SPECIALIZE mrgUnion :: [Int] -> [Int] -> [Int] #-}--mrgIsect :: (Ord a) => [a] -> [a] -> [a]-mrgIsect (a:as) (b:bs) | a<b       = mrgIsect as (b:bs)-                       | a==b      = b: mrgIsect as bs-                       | otherwise = mrgIsect (a:as) bs-mrgIsect _ _ = [] -- since either a or b is the empty list-{-# SPECIALIZE mrgIsect :: [Int] -> [Int] -> [Int] #-}-
− src/lib/DatabaseDesign/Ampersand/ADL1/P2A_Converters.hs 
@@ -1,683 +0,0 @@-{-# OPTIONS_GHC -Wall -XFlexibleInstances -XDataKinds #-}
-{-# LANGUAGE RelaxedPolyRec #-}
-module DatabaseDesign.Ampersand.ADL1.P2A_Converters ( pCtx2aCtx, showErr, Guarded(..) )
-where
-import DatabaseDesign.Ampersand.ADL1.Disambiguate
-import DatabaseDesign.Ampersand.Core.ParseTree -- (P_Context(..), A_Context(..))
-import DatabaseDesign.Ampersand.Input.ADL1.CtxError
-import DatabaseDesign.Ampersand.ADL1.Lattices
-import DatabaseDesign.Ampersand.Core.AbstractSyntaxTree hiding (sortWith, maxima, greatest)
-import DatabaseDesign.Ampersand.Classes.ViewPoint hiding (interfaces,gens)
-import DatabaseDesign.Ampersand.Classes.ConceptStructure
-import DatabaseDesign.Ampersand.Basics (Identified(name), fatalMsg)
-import DatabaseDesign.Ampersand.Misc
-import Prelude hiding (head, sequence, mapM)
-import Control.Applicative
-import Data.Traversable
-import qualified Data.Set as Set
-import qualified Data.Map as Map
-import Data.Maybe
-import Data.List(nub)
-
-head :: [a] -> a
-head [] = fatal 30 "head must not be used on an empty list!"
-head (a:_) = a
-
-fatal :: Int -> String -> a
-fatal = fatalMsg "ADL1.P2A_Converters"
-
-newtype SignOrd = SignOrd Sign
-instance Ord SignOrd where
-  compare (SignOrd (Sign a b)) (SignOrd (Sign c d)) = compare (name a,name b) (name c,name d)
-instance Eq SignOrd where
-  (==) (SignOrd (Sign a b)) (SignOrd (Sign c d)) = (name a,name b) == (name c,name d)
-
-pCtx2aCtx :: P_Context -> Guarded A_Context
-pCtx2aCtx pCtx = finalChecksOnAContext <?> pCtx2aCtx' pCtx 
-  where 
-    finalChecksOnAContext :: A_Context -> Guarded A_Context
-    finalChecksOnAContext ctx = checkUniqueRuleNames
-      where
-        checkUniqueRuleNames 
-          = case uniqueNames (udefrules ctx) of 
-              Checked _   -> Checked ctx
-              Errors err  -> Errors err
-
-
-pCtx2aCtx' :: P_Context -> Guarded A_Context
-pCtx2aCtx' 
- PCtx { ctx_nm     = n1
-      , ctx_pos    = n2
-      , ctx_lang   = lang
-      , ctx_markup = pandocf
-      , ctx_thms   = p_themes       --  The themes that are specified by the user to be documented.
-      , ctx_pats   = p_patterns     --  The patterns defined in this context
-      , ctx_PPrcs  = p_processes    --  The processes as defined by the parser
-      , ctx_rs     = p_rules        --  All user defined rules in this context, but outside patterns and outside processes
-      , ctx_ds     = p_declarations --  The relations declared in this context, outside the scope of patterns
-      , ctx_cs     = p_conceptdefs  --  The concept definitions defined in this context, outside the scope of patterns
-      , ctx_ks     = p_identdefs    --  The identity definitions defined in this context, outside the scope of patterns
-      , ctx_vs     = p_viewdefs     --  The view definitions defined in this context, outside the scope of patterns
-      , ctx_gs     = p_gens         --  The gen definitions defined in this context, outside the scope of patterns
-      , ctx_ifcs   = p_interfaces   --  The interfaces defined in this context, outside the scope of patterns
-      , ctx_ps     = p_purposes     --  The purposes defined in this context, outside the scope of patterns
-      , ctx_pops   = p_pops         --  The populations defined in this context, but outside patterns and outside processes
-      , ctx_sql    = p_sqldefs      --  user defined sqlplugs, taken from the Ampersand script
-      , ctx_php    = p_phpdefs      --  user defined phpplugs, taken from the Ampersand script
-      , ctx_metas  = p_metas        --  generic meta information (name/value pairs) that can be used for experimenting without having to modify the adl syntax
-      }
- = (\pats procs rules identdefs viewdefs interfaces purposes udpops sqldefs phpdefs
-     -> ACtx{ ctxnm = n1
-            , ctxpos = n2
-            , ctxlang = deflangCtxt
-            , ctxmarkup = deffrmtCtxt
-            , ctxthms = p_themes
-            , ctxpats = pats
-            , ctxprocs = procs
-            , ctxrs = rules
-            , ctxds = ctxDecls
-            , ctxpopus = nub (udpops++dclPops++mp1Pops rules++mp1Pops pats++mp1Pops procs++mp1Pops identdefs++mp1Pops viewdefs++mp1Pops interfaces)
-            , ctxcds = allConceptDefs
-            , ctxks = identdefs
-            , ctxvs = viewdefs
-            , ctxgs = map pGen2aGen p_gens
-            , ctxgenconcs = map (map castConcept) (concGroups ++ map (:[]) soloConcs)
-            , ctxifcs = interfaces
-            , ctxps = purposes
-            , ctxsql = sqldefs
-            , ctxphp = phpdefs
-            , ctxmetas = p_metas
-            }
-    ) <$> traverse pPat2aPat p_patterns            --  The patterns defined in this context
-      <*> traverse pProc2aProc p_processes         --  The processes defined in this context
-      <*> traverse (pRul2aRul [] n1) p_rules       --  All user defined rules in this context, but outside patterns and outside processes
-      <*> traverse pIdentity2aIdentity p_identdefs --  The identity definitions defined in this context, outside the scope of patterns
-      <*> traverse pViewDef2aViewDef p_viewdefs    --  The view definitions defined in this context, outside the scope of patterns
-      <*> traverse pIfc2aIfc p_interfaces          --  The interfaces defined in this context, outside the scope of patterns
-      <*> traverse pPurp2aPurp p_purposes          --  The purposes of objects defined in this context, outside the scope of patterns
-      <*> traverse pPop2aPop p_pops                --  [Population]
-      <*> traverse pObjDef2aObjDef p_sqldefs       --  user defined sqlplugs, taken from the Ampersand script
-      <*> traverse pObjDef2aObjDef p_phpdefs       --  user defined phpplugs, taken from the Ampersand script
-  where
-    -- story about genRules and genLattice
-    -- the genRules is a list of equalities between concept sets, in which every set is interpreted as a conjunction of concepts
-    -- the genLattice is the resulting optimized structure
-    genRules = [ ( Set.singleton (name (gen_spc x)), Set.fromList (map name (gen_concs x)))
-               | x <- p_gens ++ concatMap pt_gns p_patterns ++ concatMap procGens p_processes
-               ]
-    genLattice :: Op1EqualitySystem String
-    genLattice = optimize1 (foldr addEquality emptySystem genRules)
-    
-    concGroups :: [[String]]
-    concGroups = getGroups genLattice
-    allConcs :: Set.Set String
-    allConcs = Set.fromList (map (name . source) decls ++ map (name . target) decls)
-    soloConcs :: [String]
-    soloConcs = filter (not . isInSystem genLattice) (Set.toList allConcs)
-    
-    deflangCtxt = fromMaybe English lang  -- explanation: if lang==Nothing, then English, if lang==Just l then l
-    deffrmtCtxt = fromMaybe ReST pandocf
-
-    (decls,dclPops)= unzip dps
-    (ctxDecls,_ ) = unzip ctxDecls'
-    dps = ctxDecls'++patDecls++patProcs
-    ctxDecls' = [ pDecl2aDecl n1         deflangCtxt deffrmtCtxt pDecl | pDecl<-p_declarations ] --  The relations declared in this context, outside the scope of patterns
-    patDecls  = [ pDecl2aDecl (name pat) deflangCtxt deffrmtCtxt pDecl | pat<-p_patterns, pDecl<-pt_dcs pat ] --  The relations declared in all patterns within this context.
-    patProcs  = [ pDecl2aDecl (name prc) deflangCtxt deffrmtCtxt pDecl | prc<-p_processes, pDecl<-procDcls prc ] --  The relations declared in all processes within this context.
-      
-    declMap = Map.map groupOnTp (Map.fromListWith (++) [(name d,[d]) | d <- decls])
-      where groupOnTp lst = Map.fromListWith accumDecl [(SignOrd$ sign d,d) | d <- lst]
-    findDecls x = Map.findWithDefault Map.empty x declMap
-    findDecl o x = getOneExactly o . Map.elems $ findDecls x
-    findDeclsTyped x tp = Map.findWithDefault [] (SignOrd tp) (Map.map (:[]) (findDecls x))
-    findDeclTyped o x tp = getOneExactly o (findDeclsTyped x tp)
-    -- accumDecl is the function that combines two relations into one
-    -- meanings, for instance, two should get combined into a list of meanings, et cetera
-    -- positions are combined
-    -- TODO
-    accumDecl :: Declaration -> Declaration -> Declaration
-    accumDecl a _ = a
-    
-    pDecl2aDecl :: 
-         String         -- The name of the pattern
-      -> Lang           -- The default language 
-      -> PandocFormat   -- The default pandocFormat
-      -> P_Declaration -> (Declaration, Population)
-    pDecl2aDecl patNm defLanguage defFormat pd
-     = let dcl = Sgn { decnm   = dec_nm pd
-                     , decsgn  = pSign2aSign (dec_sign pd)
-                     , decprps = dec_prps pd
-                     , decprps_calc = Nothing  --decprps_calc in an A_Context are still the user-defined only. prps are calculated in adl2fspec.
-                     , decprL  = dec_prL pd
-                     , decprM  = dec_prM pd
-                     , decprR  = dec_prR pd
-                     , decMean = pMean2aMean defLanguage defFormat (dec_Mean pd)
-                     , decfpos = dec_fpos pd 
-                     , deciss  = True
-                     , decusr  = True
-                     , decpat  = patNm
-                     , decplug = dec_plug pd
-                     }
-       in (dcl, PRelPopu { popdcl = dcl, popps = dec_popu pd})
-    
-    pSign2aSign :: P_Sign -> Sign
-    pSign2aSign (P_Sign src tgt) = Sign (pCpt2aCpt src) (pCpt2aCpt tgt)
-
-    pGen2aGen :: P_Gen -> A_Gen
-    pGen2aGen pg@PGen{}
-       = Isa{gengen = pCpt2aCpt (gen_gen pg)
-            ,genspc = pCpt2aCpt (gen_spc pg)
-            }
-    pGen2aGen pg@P_Cy{}
-       = IsE { genrhs = map pCpt2aCpt (gen_rhs pg)
-             , genspc = pCpt2aCpt (gen_spc pg)
-             }
-
-    castSign :: String -> String -> Sign
-    castSign a b = Sign (castConcept a) (castConcept b)
-
-{- SJ20140216: The function castConcept is used in the type system, but looks similar to pCpt2aCpt.
-   However, castConcept makes an erroneous concept, which we should prevent in the first place.
-   So it seems castConcept should be removed if possible, and pCpt2aCpt should be doing all the work. 
--}
-    leastConcept :: A_Concept -> String -> A_Concept
-    leastConcept c str
-     = case (name c `elem` leastConcepts, str `elem` leastConcepts) of
-         (True, _) -> c
-         (_, True) -> castConcept str
-         (_, _)    -> fatal 178 ("Either "++name c++" or "++str++" should be a subset of the other." )
-       where
-         leastConcepts = findExact genLattice (Atom (name c) `Meet` (Atom str))
-    castConcept :: String -> A_Concept
-    castConcept "ONE" = ONE
-    castConcept x
-     = PlainConcept {cptnm = x}
-
-    pCpt2aCpt :: P_Concept -> A_Concept
-    pCpt2aCpt pc
-        = case pc of
-            PCpt{} -> PlainConcept { cptnm = p_cptnm pc}
-            P_Singleton -> ONE   
-
-    pPop2aPop :: P_Population -> Guarded Population
-    pPop2aPop P_CptPopu { p_cnme = cnm, p_popas = ps }
-     = pure PCptPopu{ popcpt = castConcept cnm, popas = ps }
-    pPop2aPop orig@(P_RelPopu { p_rnme = rnm, p_popps = ps })
-     = fmap (\dcl -> PRelPopu { popdcl = dcl, popps = ps})
-            (findDecl orig rnm)
-    pPop2aPop orig@(P_TRelPop { p_rnme = rnm, p_type = tp, p_popps = ps })
-     = fmap (\dcl -> PRelPopu { popdcl = dcl, popps = ps})
-            (findDeclTyped orig rnm (pSign2aSign tp))
-    
-    pObjDef2aObjDef :: P_ObjectDef -> Guarded ObjectDef
-    pObjDef2aObjDef x = fmap fst (typecheckObjDef tpda)
-     where tpda = disambiguate termPrimDisAmb x
-     
-    pViewDef2aViewDef :: P_ViewDef -> Guarded ViewDef
-    pViewDef2aViewDef x = typecheckViewDef tpda
-     where tpda = disambiguate termPrimDisAmb x
-     
-    typecheckViewDef :: P_ViewD (TermPrim, DisambPrim) -> Guarded ViewDef
-    typecheckViewDef
-       o@(P_Vd { vd_pos = orig
-            , vd_lbl = lbl -- String
-            , vd_cpt = cpt -- Concept
-            , vd_ats = pvs -- view segment
-            })
-     = (\vdts
-        -> Vd { vdpos = orig
-              , vdlbl = lbl
-              , vdcpt = pCpt2aCpt cpt
-              , vdats = vdts
-              })
-       <$> traverse (typeCheckViewSegment o) pvs
-    
-    typeCheckViewSegment :: (P_ViewD a) -> (P_ViewSegmt (TermPrim, DisambPrim)) -> Guarded ViewSegment
-    typeCheckViewSegment o P_ViewExp{ vs_obj = ojd }
-     = (\(obj,b) -> case findExact genLattice (mIsc c (name (source (objctx obj)))) of
-                      [] -> mustBeOrdered o o (Src,(source (objctx obj)),obj)
-                      r  -> if b || c `elem` r then pure (ViewExp obj{objctx = addEpsilonLeft c r (name (source (objctx obj))) (objctx obj)})
-                            else mustBeBound (origin obj) [(Tgt,objctx obj)]
-       ) <?> typecheckObjDef ojd
-     where c = name (vd_cpt o)
-    typeCheckViewSegment _ P_ViewText { vs_txt = txt } = pure$ ViewText txt
-    typeCheckViewSegment _ P_ViewHtml { vs_htm = htm } = pure$ ViewHtml htm
-    
-    typecheckObjDef :: (P_ObjDef (TermPrim, DisambPrim)) -> Guarded (ObjectDef, Bool)
-    typecheckObjDef o@(P_Obj { obj_nm = nm
-                             , obj_pos = orig
-                             , obj_ctx = ctx
-                             , obj_msub = subs
-                             , obj_strs = ostrs
-                             })
-     = (\(expr,subi)
-        -> case subi of
-            Nothing -> pure (obj expr Nothing)
-            Just (InterfaceRef s) -> pure (obj expr (Just$InterfaceRef s)) --TODO: check type!
-            Just b@(Box c _)
-              -> case findExact genLattice (mjoin (name c) (gc Tgt (fst expr))) of
-                    [] -> mustBeOrdered o (Src,c,((\(Just x)->x) subs)) (Tgt,target (fst expr),(fst expr))
-                    r  -> if (name c) `elem` r
-                          then pure (obj (addEpsilonRight' (name c) (fst expr), snd expr) (Just$ b))
-                          else mustBeBound (origin o) [(Tgt,fst expr)]
-       ) <?> ((,) <$> typecheckTerm ctx <*> maybeOverGuarded pSubi2aSubi subs)
-     where
-      obj (e,(sr,_)) s
-       = ( Obj { objnm = nm
-               , objpos = orig
-               , objctx = e
-               , objmsub = s
-               , objstrs = ostrs
-               }, sr)
-    addEpsilonLeft :: String -> [String] -> String -> Expression -> Expression
-    addEpsilonLeft a b c e
-     = if a==c then (if c `elem` b then e else fatal 200 "b == c must hold: the concept of the epsilon relation should be equal to the intersection of its source and target")
-               else if c/=name (source e) then fatal 202 ("addEpsilonLeft glues erroneously: c="++show c++"  and e="++show e++".")
-                    else EEps (castConcept (head b)) (castSign a c) .:. e
-    addEpsilonLeft',addEpsilonRight' :: String -> Expression -> Expression
-    addEpsilonLeft' a e
-     = if a==name (source e) then e else EEps (leastConcept (source e) a) (castSign a (name (source e))) .:. e
-    addEpsilonRight' a e
-     = if a==name (target e) then e else e .:. EEps (leastConcept (target e) a) (castSign (name (target e)) a)
-    addEpsilon :: String -> String -> Expression -> Expression
-    addEpsilon s t e
-     = (if s==name (source e) then id else (EEps (leastConcept (source e) s) (castSign s (name (source e))) .:.)) $
-       (if t==name (target e) then id else (.:. EEps (leastConcept (target e) t) (castSign (name (target e)) t))) e
-    
-    pSubi2aSubi :: (P_SubIfc (TermPrim, DisambPrim)) -> Guarded SubInterface
-    pSubi2aSubi (P_InterfaceRef _ s) = pure (InterfaceRef s)
-    pSubi2aSubi o@(P_Box _ []) = hasNone [] o
-    pSubi2aSubi o@(P_Box _ l)
-     = (\lst -> case findExact genLattice (foldr1 Join (map (Atom . name . source . objctx . fst) lst)) of
-                  [] -> mustBeOrderedLst o [(source (objctx a),Src, a) | (a,_) <- lst]
-                  r -> case [ objctx a
-                            | (a,False) <- lst
-                            , not ((name . source . objctx $ a) `elem` r)
-                            ] of
-                            [] -> pure (Box (castConcept (head r)) (map fst lst))
-                            lst' -> mustBeBound (origin o) [(Src,expr)| expr<-lst']
-       ) <?> (traverse typecheckObjDef l <* uniqueNames l)
-    
-    
-    typecheckTerm :: Term (TermPrim, DisambPrim) -> Guarded (Expression, (Bool, Bool))
-    typecheckTerm tct
-     = case tct of
-         Prim (t,v) -> (\x -> (x, case t of
-                                   PVee _ -> (False,False)
-                                   _ -> (True,True)
-                                   )) <$> pDisAmb2Expr (t,v)
-         Pequ _ a b -> binary  (.==.) (MBE (Src,fst) (Src,snd), MBE (Tgt,fst) (Tgt,snd)) <?> ((,)<$>tt a<*>tt b) 
-         Pimp _ a b -> binary  (.|-.) (MBG (Src,snd) (Src,fst), MBG (Tgt,snd) (Tgt,fst)) <?> ((,)<$>tt a<*>tt b)
-         PIsc _ a b -> binary  (./\.) (ISC (Src,fst) (Src,snd), ISC (Tgt,fst) (Tgt,snd)) <?> ((,)<$>tt a<*>tt b)
-         PUni _ a b -> binary  (.\/.) (UNI (Src,fst) (Src,snd), UNI (Tgt,fst) (Tgt,snd)) <?> ((,)<$>tt a<*>tt b)
-         PDif _ a b -> binary  (.-.)  (MBG (Src,fst) (Src,snd), MBG (Tgt,fst) (Tgt,snd)) <?> ((,)<$>tt a<*>tt b)
-         PLrs _ a b -> binary' (./.)  (MBG (Tgt,snd) (Tgt,fst)) ((Src,fst),(Src,snd)) Tgt Tgt <?> ((,)<$>tt a<*>tt b)
-         PRrs _ a b -> binary' (.\.)  (MBG (Src,fst) (Src,snd)) ((Tgt,fst),(Tgt,snd)) Src Src <?> ((,)<$>tt a<*>tt b)
-         PDia _ a b -> binary' (.<>.) (ISC (Tgt,fst) (Src,snd)) ((Src,fst),(Tgt,snd)) Tgt Src <?> ((,)<$>tt a<*>tt b) -- MBE would have been correct, but too restrictive
-         PCps _ a b -> binary' (.:.)  (ISC (Tgt,fst) (Src,snd)) ((Src,fst),(Tgt,snd)) Tgt Src <?> ((,)<$>tt a<*>tt b)
-         PRad _ a b -> binary' (.!.)  (MBE (Tgt,fst) (Src,snd)) ((Src,fst),(Tgt,snd)) Tgt Src <?> ((,)<$>tt a<*>tt b) -- Using MBE instead of ISC allows the programmer to use De Morgan
-         PPrd _ a b -> (\((x,(s,_)),(y,(_,t))) -> (x .*. y, (s,t))) <$> ((,)<$>tt a<*>tt b)
-         PKl0 _ a   -> unary   EKl0   (UNI (Src, id) (Tgt, id), UNI (Src, id) (Tgt, id)) <?> tt a
-         PKl1 _ a   -> unary   EKl1   (UNI (Src, id) (Tgt, id), UNI (Src, id) (Tgt, id)) <?> tt a
-         PFlp _ a   -> (\(x,(s,t)) -> ((EFlp x), (t,s))) <$> tt a
-         PCpl _ a   -> (\(x,_) -> (ECpl x,(False,False))) <$> tt a
-         PBrk _ e   -> (\(x,t) -> (EBrk x,t)) <$> tt e
-     where
-      o = origin (fmap fst tct)
-      tt = typecheckTerm
-      -- SJC: Here is what binary, binary' and unary do:
-      -- (1) Create an expression, the combinator for this is given by its first argument
-      -- (2) Fill in the corresponding type-checked terms to that expression
-      -- (3) For binary' only: fill in the intermediate concept too
-      -- (4) Fill in the type of the new expression
-      -- For steps (3) and (4), you can use the `TT' data type to specify the new type, and what checks should occur:
-      -- If you don't know what to use, try MBE: it is the strictest form.
-      -- In the steps (3) and (4), different type errors may arise:
-      -- If the type does not exist, this yields a type error.
-      -- Some types may be generalized, while others may not.
-      -- When a type may be generalized, that means that the value of the expression does not change if the type becomes larger
-      -- When a type may not be generalized:
-      --   the type so far is actually just an estimate
-      --   it must be bound by the context to something smaller, or something as big
-      --   a way to do this, is by using (V[type] /\ thingToBeBound)
-      -- More details about generalizable types can be found by looking at "deriv1".
-      binary :: (Expression -> Expression->Expression) -- combinator
-             -> ( TT ( SrcOrTgt
-                     , ( (Expression, (Bool, Bool))
-                       , (Expression, (Bool, Bool))
-                       ) -> (Expression, (Bool, Bool))
-                     )
-                , TT ( SrcOrTgt
-                     , ( (Expression, (Bool, Bool))
-                       , (Expression, (Bool, Bool))
-                       ) -> (Expression, (Bool, Bool))
-                     )
-                ) -- simple instruction on how to derive the type
-             -> ((Expression,(Bool,Bool)), (Expression,(Bool,Bool))) -- expressions to feed into the combinator after translation
-             -> Guarded (Expression,(Bool,Bool))
-      binary  cbn     tp (e1,e2) = wrap (fst e1,fst e2) <$> deriv tp (e1,e2)
-        where
-         wrap (expr1,expr2) ((src,b1), (tgt,b2)) = (cbn (addEpsilon src tgt expr1) (addEpsilon src tgt expr2), (b1, b2))
-      unary   cbn     tp e1      = wrap (fst e1) <$> deriv tp e1
-        where
-         wrap expr  ((src,b1), (tgt,b2))  = (cbn (addEpsilon src tgt expr), (b1, b2))
-      binary' cbn preConcept tp side1 side2 (e1,e2) = wrap (fst e1,fst e2) <$> deriv1 o (fmap (resolve (e1,e2)) preConcept) <*> deriv' tp (e1,e2)
-        where
-         wrap (expr1,expr2) (cpt,_) ((_,b1), (_,b2))
-          = (cbn (lrDecide side1 expr1) (lrDecide side2 expr2), (b1, b2))
-            where lrDecide side e = case side of Src -> addEpsilonLeft' cpt e; Tgt -> addEpsilonRight' cpt e
-      deriv (t1,t2) es = (,) <$> deriv1 o (fmap (resolve es) t1) <*> deriv1 o (fmap (resolve es) t2)
-    
-    deriv1 o x'
-     = case x' of
-        (MBE a@(p1,(e1,b1)) b@(p2,(e2,b2))) ->
-             if (b1 && b2) || (gc p1 e1 == gc p2 e2) then (\x -> (x,b1||b2)) <$> getExactType mjoin (p1, e1) (p2, e2)
-             else mustBeBound o [(p,e) | (p,(e,False))<-[a,b]]
-        (MBG (p1,(e1,b1)) (p2,(e2,b2))) ->
-             (\x -> (x,b1)) <$> getAndCheckType mjoin (p1, True, e1) (p2, b2, e2)
-        (UNI (p1,(e1,b1)) (p2,(e2,b2))) ->
-             (\x -> (x,b1 && b2)) <$> getAndCheckType mjoin (p1, b1, e1) (p2, b2, e2)
-        (ISC (p1,(e1,b1)) (p2,(e2,b2))) ->
-             (\x -> (x,b1 || b2)) <$> getAndCheckType mIsc  (p1, b1, e1) (p2, b2, e2)
-     where
-      getExactType flf (p1,e1) (p2,e2)
-       = case findExact genLattice (flf (gc p1 e1) (gc p2 e2)) of
-          [] -> mustBeOrdered o (p1,e1) (p2,e2)
-          r  -> pure$ head r
-      getAndCheckType flf (p1,b1,e1) (p2,b2,e2)
-       = case findSubsets genLattice (flf (gc p1 e1) (gc p2 e2)) of -- note: we could have used GetOneGuarded, but this is more specific
-          []  -> mustBeOrdered o (p1,e1) (p2,e2)
-          [r] -> case (b1 || Set.member (gc p1 e1) r,b2 || Set.member (gc p2 e2) r ) of
-                   (True,True) -> pure (head' (Set.toList r))
-                   (a,b) -> mustBeBound o [(p,e) | (False,p,e)<-[(a,p1,e1),(b,p2,e2)]]
-          lst -> mustBeOrderedConcLst o (p1,e1) (p2,e2) (map (map castConcept . Set.toList) lst)
-       where head' [] =fatal 321 ("empty list on expressions "++show ((p1,b1,e1),(p2,b2,e2)))
-             head' (a:_) = a
-    termPrimDisAmb :: TermPrim -> (TermPrim, DisambPrim)
-    termPrimDisAmb x
-     = (x, case x of
-           PI _        -> Ident
-           Pid _ conspt-> Known (EDcI (pCpt2aCpt conspt))
-           Patm _ s Nothing -> Mp1 s
-           Patm _ s (Just conspt) -> Known (EMp1 s (pCpt2aCpt conspt))
-           PVee _      -> Vee
-           Pfull _ a b -> Known (EDcV (Sign (pCpt2aCpt a) (pCpt2aCpt b)))
-           Prel _ r    -> Rel [EDcD dc | dc <- (Map.elems $ findDecls r)]
-           PTrel _ r s -> Rel [EDcD dc | dc <- (findDeclsTyped r (pSign2aSign s))]
-        )
-    
-    termPrim2Decl :: TermPrim -> Guarded Declaration
-    termPrim2Decl o@(Prel _ r   ) = getOneExactly o [ dc | dc <- (Map.elems $ findDecls r)]
-    termPrim2Decl o@(PTrel _ r s) = getOneExactly o [ dc | dc <- (findDeclsTyped r (pSign2aSign s))]
-    termPrim2Decl _ = fatal 231 "Expecting Declaration"
-    termPrim2Expr :: TermPrim -> Guarded Expression
-    termPrim2Expr = pDisAmb2Expr . termPrimDisAmb
-    
-    pIfc2aIfc :: P_Interface -> Guarded Interface
-    pIfc2aIfc P_Ifc { ifc_Params = tps
-                    , ifc_Args = args
-                    , ifc_Roles = rols
-                    , ifc_Obj = obj
-                    , ifc_Pos = orig
-                    -- , ifc_Name = nm
-                    , ifc_Prp = prp
-                    }
-        = (\ tps' obj'
-             -> Ifc { ifcParams = tps'
-                    , ifcArgs = args
-                    , ifcRoles = rols
-                    , ifcObj = obj'
-                    , ifcPos = orig
-                    , ifcPrp = prp
-                    }) <$> traverse termPrim2Expr tps
-                       <*> pObjDef2aObjDef obj
-    pProc2aProc :: P_Process -> Guarded Process
-    pProc2aProc P_Prc { procNm = nm
-                      , procPos = orig
-                      , procEnd = posEnd
-                      , procRules = ruls
-                      , procGens = gens
-                      , procDcls = dcls
-                      , procRRuls = rolruls
-                      , procRRels = rolrels
-                      , procCds = _cdefs -- SJ2013: the underscore means that this argument is not used.
-                      , procIds = idefs
-                      , procVds = viewdefs
-                      , procXps = purposes
-                      , procPop = pops
-                      }
-     = (\ ruls' rels' pops' idefs' viewdefs' purposes'
-         ->  let (decls',dPops) = unzip [ pDecl2aDecl nm deflangCtxt deffrmtCtxt pDecl | pDecl<-dcls ]
-             in Proc { prcNm = nm
-                     , prcPos = orig
-                     , prcEnd = posEnd
-                     , prcRules = map snd ruls'
-                     , prcGens = map pGen2aGen gens
-                     , prcDcls = decls'
-                     , prcUps = pops' ++ [ dp | dp@PRelPopu{}<-dPops, (not.null.popps) dp ] ++ [ cp | cp@PCptPopu{}<-dPops, (not.null.popas) cp ]
-                     , prcRRuls = [(rol,r)|(rols,r)<-ruls',rol<-rols]
-                     , prcRRels = [(rol,r)|(rols,rs)<-rels',rol<-rols,r<-rs]
-                     , prcIds = idefs'
-                     , prcVds = viewdefs'
-                     , prcXps = purposes'
-                     }
-       ) <$> traverse (\x -> pRul2aRul' [rol | rr <- rolruls, rul <- mRules rr, name x == rul, rol <- mRoles rr] nm x) ruls
-         <*> sequenceA [(\x -> (rr_Roles prr,x)) <$> (traverse termPrim2Decl $ rr_Rels prr) | prr <- rolrels]
-         <*> traverse pPop2aPop pops
-         <*> traverse pIdentity2aIdentity idefs
-         <*> traverse pViewDef2aViewDef viewdefs
-         <*> traverse pPurp2aPurp purposes
-    
-    pPat2aPat :: P_Pattern -> Guarded Pattern
-    pPat2aPat ppat
-     = f <$> parRuls ppat <*> parKeys ppat <*> parPops ppat <*> parViews ppat <*> parPrps ppat <*> sequenceA rrels
-       where
-        f prules keys' pops' views' xpls rrels'
-           = let (decls',dPops) = unzip [ pDecl2aDecl (name ppat) deflangCtxt deffrmtCtxt pDecl | pDecl<-pt_dcs ppat ]
-             in A_Pat { ptnm  = name ppat
-                      , ptpos = pt_pos ppat
-                      , ptend = pt_end ppat
-                      , ptrls = map snd prules
-                      , ptgns = agens'
-                      , ptdcs = decls'
-                      , ptups = pops' ++ [ dp | dp@PRelPopu{}<-dPops, (not.null.popps) dp ] ++ [ cp | cp@PCptPopu{}<-dPops, (not.null.popas) cp ]
-                      , ptrruls = [(rol,r)|(rols,r)<-prules,rol<-rols]
-                      , ptrrels = [(rol,dcl)|rr<-rrels', rol<-rrRoles rr, dcl<-rrRels rr]  -- The assignment of roles to Relations.
-                      , ptids = keys'
-                      , ptvds = views'
-                      , ptxps = xpls
-                      }
-        agens'   = map pGen2aGen (pt_gns ppat)
-        parRuls  = traverse (\x -> pRul2aRul' [rol | prr <- pt_rus ppat, rul<-mRules prr, name x == rul, rol<-mRoles prr] (name ppat) x) . pt_rls
-        rrels :: [Guarded RoleRelation]
-        rrels =  [(\x -> RR (rr_Roles prr) x (origin prr)) <$> (traverse termPrim2Decl $ rr_Rels prr) | prr <- pt_res ppat]
-        parKeys  = traverse pIdentity2aIdentity . pt_ids
-        parPops  = traverse pPop2aPop . pt_pop
-        parViews = traverse pViewDef2aViewDef . pt_vds
-        parPrps  = traverse pPurp2aPurp . pt_xps
-    
-    pRul2aRul':: [String] -- list of roles for this rule
-              -> String -- environment name (pattern / proc name)
-              -> (P_Rule TermPrim) -> Guarded ([String],Rule)  -- roles in the lhs
-    pRul2aRul' a b c = fmap ((,) a) (pRul2aRul a b c)
-    pRul2aRul :: [String] -- list of roles for this rule
-              -> String -- environment name (pattern / proc name)
-              -> (P_Rule TermPrim) -> Guarded Rule
-    pRul2aRul rol env = typeCheckRul rol env . disambiguate termPrimDisAmb
-    typeCheckRul :: [String] -- list of roles for this rule
-              -> String -- environment name (pattern / proc name)
-              -> (P_Rule (TermPrim, DisambPrim)) -> Guarded Rule
-    typeCheckRul sgl env P_Ru { rr_nm = nm
-                       , rr_exp = expr
-                       , rr_fps = orig
-                       , rr_mean = meanings
-                       , rr_msg = msgs
-                       , rr_viol = viols
-                       }
-     = (\ (exp',_)
-       -> (\ vls ->
-          Ru { rrnm = nm
-             , rrexp = exp'
-             , rrfps = orig
-             , rrmean = pMean2aMean deflangCtxt deffrmtCtxt meanings
-             , rrmsg = map (pMess2aMess deflangCtxt deffrmtCtxt) msgs
-             , rrviol = vls
-             , rrtyp = sign exp'
-             , rrdcl = Nothing
-             , r_env = env
-             , r_usr = UserDefined
-             , isSignal = not (null sgl)
-             , srrel = Sgn{ decnm   = nm
-                          , decsgn  = (sign exp')
-                          , decprps = []
-                          , decprps_calc = Nothing
-                          , decprL  = ""
-                          , decprM  = ""
-                          , decprR  = ""
-                          , decMean = pMean2aMean deflangCtxt deffrmtCtxt meanings
-                          , decfpos = orig
-                          , deciss  = True
-                          , decusr  = False
-                          , decpat  = env
-                          , decplug = False
-                          }
-             }
-             ) <$> maybeOverGuarded (typeCheckPairView orig exp') viols
-          ) <?> typecheckTerm expr
-    pIdentity2aIdentity :: P_IdentDef -> Guarded IdentityDef
-    pIdentity2aIdentity
-            P_Id { ix_pos = orig
-                 , ix_lbl = lbl
-                 , ix_cpt = pconc
-                 , ix_ats = isegs
-                 }
-     = (\isegs' ->
-       Id { idPos = orig
-          , idLbl = lbl
-          , idCpt = pCpt2aCpt pconc
-          , identityAts = isegs'
-          }) <$> traverse pIdentSegment2IdentSegment isegs
-    pIdentSegment2IdentSegment :: P_IdentSegment -> Guarded IdentitySegment
-    pIdentSegment2IdentSegment (P_IdentExp ojd)
-     = IdentityExp <$> pObjDef2aObjDef ojd
-    
-    typeCheckPairView :: Origin -> Expression -> PairView (Term (TermPrim, DisambPrim)) -> Guarded (PairView Expression)
-    typeCheckPairView o x (PairView lst)
-     = PairView <$> traverse (typeCheckPairViewSeg o x) lst
-    typeCheckPairViewSeg :: Origin -> Expression -> (PairViewSegment (Term (TermPrim, DisambPrim))) -> Guarded (PairViewSegment Expression)
-    typeCheckPairViewSeg _ _ (PairViewText x) = pure (PairViewText x)
-    typeCheckPairViewSeg o t (PairViewExp s x)
-     = (\(e,(b,_)) -> case (findSubsets genLattice (mjoin (name (source e)) (gc s t))) of
-                        [] -> mustBeOrdered o (Src,e) (s,t)
-                        lst -> if b || and (map (name (source e) `elem`) lst)
-                               then pure (PairViewExp s e)
-                               else mustBeBound o [(Src, e)]
-                        ) <?> typecheckTerm x
-
-    pPurp2aPurp :: PPurpose -> Guarded Purpose
-    pPurp2aPurp PRef2 { pexPos    = orig     -- :: Origin
-                      , pexObj    = objref   -- :: PRefObj
-                      , pexMarkup = pmarkup  -- :: P_Markup
-                      , pexRefIDs  = refIds  -- :: [String]
-                      }
-     = (\ obj -> Expl { explPos      = orig
-                      , explObj      = obj
-                      , explMarkup   = pMarkup2aMarkup deflangCtxt deffrmtCtxt pmarkup
-                      , explUserdefd = True
-                      , explRefIds   = refIds
-                      })
-       <$> pRefObj2aRefObj objref
-    pRefObj2aRefObj :: PRef2Obj -> Guarded ExplObj
-    pRefObj2aRefObj (PRef2ConceptDef  s ) = pure$ ExplConceptDef (lookupConceptDef s)
-    pRefObj2aRefObj (PRef2Declaration tm) = ExplDeclaration <$> (termPrim2Decl tm)
-    pRefObj2aRefObj (PRef2Rule        s ) = pure$ ExplRule s
-    pRefObj2aRefObj (PRef2IdentityDef s ) = pure$ ExplIdentityDef s
-    pRefObj2aRefObj (PRef2ViewDef     s ) = pure$ ExplViewDef s
-    pRefObj2aRefObj (PRef2Pattern     s ) = pure$ ExplPattern s
-    pRefObj2aRefObj (PRef2Process     s ) = pure$ ExplProcess s
-    pRefObj2aRefObj (PRef2Interface   s ) = pure$ ExplInterface s
-    pRefObj2aRefObj (PRef2Context     s ) = pure$ ExplContext s
-    pRefObj2aRefObj (PRef2Fspc        s ) = pure$ ExplContext s
-    lookupConceptDef :: String -> ConceptDef
-    lookupConceptDef s
-     = if null cs
-       then Cd{cdpos=OriginUnknown, cdcpt=s, cdplug=True, cddef="", cdtyp="", cdref="", cdfrom=n1}
-       else head cs
-       where cs = [cd | cd<-allConceptDefs, name cd==s]
-    allConceptDefs :: [ConceptDef]
-    allConceptDefs = p_conceptdefs++concatMap pt_cds p_patterns++concatMap procCds p_processes
-    
-pDisAmb2Expr :: (TermPrim, DisambPrim) -> Guarded Expression
--- SJ 20140211 @SJC: TODO graag een typefout genereren voor een SESSION atoom anders dan _SESSION.
-pDisAmb2Expr (_,Known x) = pure x
-pDisAmb2Expr (_,Rel [x]) = pure x
-pDisAmb2Expr (o,Rel rs)  = cannotDisambRel o rs
-pDisAmb2Expr (o,_)       = cannotDisamb o
-
-pMean2aMean :: Lang           -- The default language 
-            -> PandocFormat   -- The default pandocFormat
-            -> [PMeaning] -> AMeaning
-pMean2aMean defLanguage defFormat pmeanings
- = AMeaning [ pMarkup2aMarkup defLanguage defFormat pmarkup | PMeaning pmarkup <-pmeanings ]
-pMess2aMess :: Lang           -- The default language 
-            -> PandocFormat   -- The default pandocFormat
-            -> PMessage -> A_Markup
-pMess2aMess defLanguage defFormat (PMessage x) = pMarkup2aMarkup defLanguage defFormat x
-pMarkup2aMarkup :: Lang           -- The default language 
-                -> PandocFormat   -- The default pandocFormat
-                -> P_Markup -> A_Markup 
-pMarkup2aMarkup defLanguage defFormat
-   P_Markup  { mLang   = ml
-             , mFormat = mpdf
-             , mString = str
-             }
- = A_Markup { amLang = fromMaybe defLanguage ml -- The language is always defined; if not by the user, then by default.
-            , amFormat = fmt
-            , amPandoc = string2Blocks fmt str
-            }
-     where
-       fmt = fromMaybe defFormat mpdf           -- The pandoc format is always defined; if not by the user, then by default.
-
--- helpers for generating a lattice, not having to write `Atom' all the time
-mjoin,mIsc :: a -> a -> FreeLattice a
-mjoin a b = Join (Atom a) (Atom b)
-mIsc  a b = Meet (Atom a) (Atom b)
--- intended for finding the right expression on terms like (Src,fst)
-resolve :: t -> (SrcOrTgt, t -> (t1, (t2, t2))) -> (SrcOrTgt, (t1, t2))
-resolve es (p,f)
- = case (p,f es) of
-  (Src,(e,(b,_))) -> (Src,(e,b))
-  (Tgt,(e,(_,b))) -> (Tgt,(e,b))
-
-maybeOverGuarded :: Applicative f => (t -> f a) -> Maybe t -> f (Maybe a)
-maybeOverGuarded _ Nothing = pure Nothing
-maybeOverGuarded f (Just x) = Just <$> f x
-
-data TT a  -- (In order of increasing strictness. If you are unsure which to pick: just use MBE, it'll usually work fine)
- = UNI a a -- find the union of these types, return it.
- | ISC a a -- find the intersection of these types, return it.
- | MBE a a -- must be equal: must be (made) of equal type. If these types are comparable, it returns the greatest.
- | MBG a a -- The first of these types must be the greatest, if so, return it (error otherwise)
- -- SJC: difference between UNI and MBE
- -- in general, UNI is less strict than MBE:
- --   suppose A ≤ C, B ≤ C, and C is the least such concept (e.g. if A≤D and B≤D then C≤D)
- --   in this case UNI A B will yield C (if both A and B are generalizable), while MBE A B will give an error
- --   note that in case of A ≤ C, B ≤ C, A ≤ D, B ≤ D (and there is no order between C and D), both will give an error
- --   the error message, however, should be different:
- --     for MBE it says that A and B must be of the same type, and suggests adding an order between A and B
- --     for UNI it says that it cannot decide whether A \/ B is of type C or D, and suggests adding an order between C and D
- --   In addition, MBE requires that both sides are not generalizable. UNI does not, and simply propagates this property.
- -- MBG is like MBE, but will only try to generalize the right hand side (when allowed)
-
-deriv' :: (Applicative f)
-       => ((SrcOrTgt, t -> (Expression, (Bool, Bool))), (SrcOrTgt, t -> (Expression, (Bool, Bool))))
-       -> t
-       -> f ((String, Bool), (String, Bool))
-deriv' (a,b) es = let (sourceOrTarget1, (e1, t1)) = resolve es a
-                      (sourceOrTarget2, (e2, t2)) = resolve es b
-                  in pure ((gc sourceOrTarget1 e1, t1), (gc sourceOrTarget2 e2, t2))
-instance Functor TT where
-  fmap f (UNI a b) = UNI (f a) (f b)
-  fmap f (ISC a b) = ISC (f a) (f b)
-  fmap f (MBE a b) = MBE (f a) (f b)
-  fmap f (MBG a b) = MBG (f a) (f b)

− src/lib/DatabaseDesign/Ampersand/ADL1/Pair.hs 
@@ -1,25 +0,0 @@-{-# OPTIONS_GHC -Wall #-}
-{-# LANGUAGE TypeSynonymInstances #-}
-{-# LANGUAGE FlexibleInstances #-}
-module DatabaseDesign.Ampersand.ADL1.Pair
-                    ( Paire,Pairs
-                    , srcPaire,trgPaire
-                    , mkPair
-                    ) 
-where
-
-   type Pairs = [Paire]
-   srcPaire :: Paire -> String
-   trgPaire :: Paire -> String
-   type Paire = (String,String)
-   mkPair :: String -> String -> Paire
-   mkPair a b = (a,b)
-   srcPaire = fst
-   trgPaire = snd
---   data Paire = Paire {srcPaire ::String
---                      ,trgPaire ::String
---                      } deriving (Show ,Eq)
---   mkPair = Paire
-
-
-

− src/lib/DatabaseDesign/Ampersand/ADL1/Rule.hs 
@@ -1,107 +0,0 @@-{-# OPTIONS_GHC -Wall #-}
-module DatabaseDesign.Ampersand.ADL1.Rule    (
-                consequent, antecedent, rulefromProp, ruleviolations, hasantecedent)
-where
-   import DatabaseDesign.Ampersand.Core.AbstractSyntaxTree
-   import DatabaseDesign.Ampersand.Basics
-   import DatabaseDesign.Ampersand.Core.ParseTree        ( Prop(..))
-   import DatabaseDesign.Ampersand.Classes.Populated              ( fullContents)
-   import DatabaseDesign.Ampersand.Misc
-
-   fatal :: Int -> String -> a
-   fatal = fatalMsg "ADL1.Rule"
-
-
-   hasantecedent :: Rule -> Bool
-   hasantecedent r
-    = case rrexp r of
-        EEqu{} -> True
-        EImp{} -> True
-        _      -> False
-   antecedent :: Rule -> Expression
-   antecedent r
-    = case rrexp r of
-        EEqu (le,_) -> le
-        EImp (le,_) -> le
-        _           -> fatal 134 $ "erroneous reference to antecedent of rule "++show r
-
-   consequent :: Rule -> Expression
-   consequent r
-    = case rrexp r of
-        EEqu (_,re) -> re
-        EImp (_,re) -> re
-        x           -> x
-
-   ruleviolations :: [A_Gen] -> [Population] -> Rule -> Pairs
-   ruleviolations gens pt r = case rrexp r of
-        EEqu{} -> (cra >- crc) ++ (crc >- cra)
-        EImp{} -> cra >- crc
-        _      -> fullContents gens pt (EDcV (sign (consequent r))) >- crc  --everything not in con
-        where cra = fullContents gens pt (antecedent r)
-              crc = fullContents gens pt (consequent r)
-
--- rulefromProp specifies a rule that defines property prp of declaration d.
--- The table of all relations is provided, in order to generate shorter names if possible.
-   rulefromProp :: Prop -> Declaration -> Rule
-   rulefromProp prp d@Sgn{}
-      = Ru { rrnm  = show prp++" "++name d++"::"++s++"*"++t
-           , rrexp = rExpr
-           , rrfps = origin d
-           , rrmean = AMeaning $ explain True prp
-           , rrmsg = explain False prp
-           , rrviol = Nothing
-           , rrtyp = sign rExpr
-           , rrdcl = Just (prp,d)         -- For traceability: The original property and declaration.
-           , r_env = decpat d             -- For traceability: The name of the pattern. Unknown at this position but it may be changed by the environment.
-           , r_usr = Multiplicity
-           , isSignal = False
-           , srrel = d{decnm=show prp++name d}
-           }
-          where
-           s = name (source d)
-           t = name (target d)
-           r:: Expression
-           r = EDcD d
-           rExpr = if not (isEndo r) && prp `elem` [Sym, Asy, Trn, Rfx, Irf]
-                   then fatal 70 ("Illegal property of an endo relation "++show (name d)) else
-                   case prp of
-                        Uni-> flp r .:. r .|-. EDcI (target r)
-                        Tot-> EDcI (source r)  .|-. r .:. flp r
-                        Inj-> r .:. flp r .|-. EDcI (source r)
-                        Sur-> EDcI (target r)  .|-. flp r .:. r
-                        Sym-> r .==. flp r
-                        Asy-> flp r ./\. r .|-. EDcI (source r)
-                        Trn-> r .:. r .|-. r
-                        Rfx-> EDcI (source r) .|-. r
-                        Irf-> r .|-. ECpl (EDcI (source r))
-           explain isPositive prop = [ A_Markup English ReST (string2Blocks ReST (
-                                 case prop of
-                                   Sym-> state isPositive English (name d++"["++s++"]") "symmetric"
-                                   Asy-> state isPositive English (name d++"["++s++"]") "antisymmetric"
-                                   Trn-> state isPositive English (name d++"["++s++"]") "transitive"
-                                   Rfx-> state isPositive English (name d++"["++s++"]") "reflexive"
-                                   Irf-> state isPositive English (name d++"["++s++"]") "irreflexive"
-                                   Uni-> state isPositive English (name d++"["++s++"*"++t++"]") "univalent"
-                                   Sur-> state isPositive English (name d++"["++s++"*"++t++"]") "surjective"
-                                   Inj-> state isPositive English (name d++"["++s++"*"++t++"]") "injective"
-                                   Tot-> state isPositive English (name d++"["++s++"*"++t++"]") "total"
-                                   ))
-                          ,   A_Markup Dutch ReST (string2Blocks ReST (
-                                 case prop of
-                                   Sym-> state isPositive Dutch (name d++"["++s++"]") "symmetrisch."
-                                   Asy-> state isPositive Dutch (name d++"["++s++"]") "antisymmetrisch."
-                                   Trn-> state isPositive Dutch (name d++"["++s++"]") "transitief."
-                                   Rfx-> state isPositive Dutch (name d++"["++s++"]") "reflexief."
-                                   Irf-> state isPositive Dutch (name d++"["++s++"]") "irreflexief."
-                                   Uni-> state isPositive Dutch (name d++"["++s++"*"++t++"]") "univalent"
-                                   Sur-> state isPositive Dutch (name d++"["++s++"*"++t++"]") "surjectief"
-                                   Inj-> state isPositive Dutch (name d++"["++s++"*"++t++"]") "injectief"
-                                   Tot-> state isPositive Dutch (name d++"["++s++"*"++t++"]") "totaal"
-                                   ))
-                         ]
-
-           state True  _       left right = left ++ " is " ++ right
-           state False English left right = left ++ " is not " ++ right
-           state False Dutch   left right = left ++ " is niet " ++ right
-
-   rulefromProp _ _ = fatal 252 "Properties can only be set on user-defined relations."

− src/lib/DatabaseDesign/Ampersand/Basics.hs 
@@ -1,12 +0,0 @@-{-# OPTIONS_GHC -Wall #-}
-module DatabaseDesign.Ampersand.Basics (module X, Identified(..)) where
-import DatabaseDesign.Ampersand.Basics.Auxiliaries as X
-import DatabaseDesign.Ampersand.Basics.Collection as X
-import DatabaseDesign.Ampersand.Basics.String as X
-import DatabaseDesign.Ampersand.Basics.UTF8 as X
-import DatabaseDesign.Ampersand.Basics.Version as X
-
-
-class Identified a where
-  name :: a->String
-

− src/lib/DatabaseDesign/Ampersand/Basics/Auxiliaries.hs 
@@ -1,65 +0,0 @@-{-# OPTIONS_GHC -Wall #-}
-module DatabaseDesign.Ampersand.Basics.Auxiliaries
-  where
-   import Data.List (nub,elemIndex)
-   import Data.Graph (stronglyConnComp, SCC(CyclicSCC))
-   import Data.Maybe (fromMaybe)
-
-   -- | The 'eqClass' function takes an equality test function and a list and returns a list of lists such
-   -- that each sublist in the result contains only equal elements, and all equal elements are in 
-   -- the same sublist.  For example,
-   --
-   -- > eqClass "Mississippi" = ["M","iiii","ssss","pp"]
-   --
-   eqClass :: (a -> a -> Bool) -> [a] -> [[a]]
-   eqClass _ [] = []
-   eqClass f (x:xs) = (x:[e |e<-xs, f x e]) : eqClass f [e |e<-xs, not (f x e)]
-
-   -- | eqCl is a very useful function for gathering things that are equal wrt some criterion f.
-   --   For instance, if you want to have persons with the same name:
-   --    'eqCl name persons' produces a list,in which each element is a list of persons with the same name.
-   eqCl :: Eq b => (a -> b) -> [a] -> [[a]]
-   eqCl _ [] = []
-   eqCl f (x:xs) = (x:[e |e<-xs, f x==f e]) : eqCl f [e |e<-xs, f x/=f e]
-
-   -- | getCycles returns a list of cycles in the edges list (each edge is a pair of a from-vertex
-   --   and a list of to-vertices)
-   getCycles :: Eq a => [(a, [a])] -> [[a]]
-   getCycles edges =
-     let allVertices = nub . concat $ [ from : to | (from, to) <- edges ] 
-         keyFor v = fromMaybe (error "FATAL") $ elemIndex v allVertices
-         graphEdges = [ (v, keyFor v , map keyFor vs)  | (v, vs) <- edges ]
-     in  [ vs | CyclicSCC vs <- stronglyConnComp graphEdges ]
-
--- The following function can be used to determine how much of a set of alternative expression is already determined
-   -- | The 'combinations' function returns all possible combinations of lists of list.
-   -- For example,
-   --
-   -- > combinations [[1,2,3],[10,20],[4]] == [[1,10,4],[1,20,4],[2,10,4],[2,20,4],[3,10,4],[3,20,4]]
-   combinations :: [[a]] -> [[a]]
-   combinations []       = [[]]
-   combinations (es:ess) = [ x:xs | x<-es, xs<-combinations ess]
-                              
-   commaEng :: String -> [String] -> String
-   commaEng str [a,b,c] = a++", "++b++", "++str++" "++c
-   commaEng str [a,b]   = a++" "++str++" "++b
-   commaEng _   [a]     = a
-   commaEng str (a:as)  = a++", "++commaEng str as
-   commaEng _   []      = ""
-
-   commaNL :: String -> [String] -> String
-   commaNL str [a,b]  = a++" "++str++" "++b
-   commaNL  _  [a]    = a
-   commaNL str (a:as) = a++", "++commaNL str as
-   commaNL  _  []     = ""
-
-   fst3 :: (a,b,c)->a
-   snd3 :: (a,b,c)->b
-   thd3 :: (a,b,c)->c
-   fst3 (a,_,_) = a
-   snd3 (_,b,_) = b
-   thd3 (_,_,c) = c
-
-   class Flippable a where
-     flp :: a -> a
-   
− src/lib/DatabaseDesign/Ampersand/Basics/BuildInfo_Generated.hs 
@@ -1,15 +0,0 @@-module DatabaseDesign.Ampersand.Basics.BuildInfo_Generated (cabalVersionStr, svnRevisionStr, buildTimeStr) where
-
--- This module is generated automatically by Setup.hs before building. Do not edit!
-
-{-# NOINLINE cabalVersionStr #-}
-cabalVersionStr :: String
-cabalVersionStr = "3.0.2"
-
-{-# NOINLINE svnRevisionStr #-}
-svnRevisionStr :: String
-svnRevisionStr = "1366"
-
-{-# NOINLINE buildTimeStr #-}
-buildTimeStr :: String
-buildTimeStr = "15-Jun-14 20:03:10 UTC"

− src/lib/DatabaseDesign/Ampersand/Basics/Collection.hs 
@@ -1,28 +0,0 @@-{-# OPTIONS_GHC -Wall #-}
-module DatabaseDesign.Ampersand.Basics.Collection
-  (  Collection ( eleM
-                , uni
-                , isc
-                ,(>-)
-                ,empty
-                ,elems)
-  )where
-   ----------------------------------------------
-   ---- Collection of type a --------------------
-   ----------------------------------------------
-   infixl 5  >-
-
-   class Collection a where      -- TODO Vervangen door efficient algorithme: Data.Set
-    eleM :: Eq b => b -> a b -> Bool  
-    uni, isc :: Eq b => a b -> a b -> a b  
-    (>-) :: Eq b => a b -> a b -> a b
-    empty :: Eq b => a b
-    elems :: Eq b => a b -> [b]
-
-   instance Collection [] where
-    eleM         = elem
-    xs `uni` ys  = xs++(ys>-xs)
-    xs `isc` ys  = [y | y<-ys, y `elem` xs]
-    xs >- ys     = [x | x<-xs, x `notElem` ys]
-    empty        = []
-    elems        = id

− src/lib/DatabaseDesign/Ampersand/Basics/String.hs 
@@ -1,29 +0,0 @@-  {-# OPTIONS_GHC -Wall #-}
-  -- | This module contains some common String funcions
-  module DatabaseDesign.Ampersand.Basics.String
-   (unCap,upCap,escapeNonAlphaNum)
-  where
-   import Data.Char 
-
-   -- | Converts the first character of a string to lowercase, with the exception that there is a second character, which is uppercase. 
-   -- uncap "AbcDe" == "abcDe"
-   -- uncap "ABcDE" == "ABcDE"  
-   unCap :: String -> String
-   unCap [] = []
-   unCap [h] = [toLower h]
-   unCap (h:h':t) | isUpper h' = h:h':t
-                  | otherwise  = toLower h:h':t
-   -- | Converts the first character of a string to uppercase
-   upCap :: String -> String
-   upCap [] = []  
-   upCap (h:t) = toUpper h:t
-
-   
-   -- | escape anything except regular characters and digits to _<character code>
-   -- e.g. escapeNonAlphaNum "a_é" = "a_95_233"
-   escapeNonAlphaNum :: String -> String
-   escapeNonAlphaNum = concatMap escapeNonAlphaNumChar
-    where escapeNonAlphaNumChar c 
-            | isAlphaNum c && isAscii c = [c]
-            | otherwise                 = '_' : show (ord c)
-   
− src/lib/DatabaseDesign/Ampersand/Basics/UTF8.hs 
@@ -1,79 +0,0 @@-{-
-Copyright (C) 2010 John MacFarlane <jgm@berkeley.edu>
-
-This program is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or
-(at your option) any later version.
-
-This program is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with this program; if not, write to the Free Software
-Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
--}
-
-{- |
-   Module      : Text.Pandoc.UTF8
-   Copyright   : Copyright (C) 2010 John MacFarlane
-   License     : GNU GPL, version 2 or above 
-
-   Maintainer  : John MacFarlane <jgm@berkeley.edu>
-   Stability   : alpha
-   Portability : portable
-
-UTF-8 aware string IO functions that will work with GHC 6.10, 6.12, or 7.
--}
-module DatabaseDesign.Ampersand.Basics.UTF8
-           ( readFile
-            , writeFile
-            , getContents
-            , putStr
-            , putStrLn
-            , hGetContents
-            , hPutStr
-            , hPutStrLn
-            )
-
-where
-import Codec.Binary.UTF8.String (encodeString)
-import qualified Data.ByteString as B hiding (putStrLn)
-import qualified Data.ByteString.Char8 as C (putStrLn)
-import Data.ByteString.UTF8 (toString, fromString)
-import Prelude hiding (readFile, writeFile, getContents, putStr, putStrLn)
-import System.IO (Handle)
-import Control.Monad (liftM)
-
-bom :: B.ByteString
-bom = B.pack [0xEF, 0xBB, 0xBF]
-
-stripBOM :: B.ByteString -> B.ByteString
-stripBOM s | bom `B.isPrefixOf` s = B.drop 3 s
-stripBOM s = s
-
-readFile :: FilePath -> IO String
-readFile = liftM (toString . stripBOM) . B.readFile . encodeString
-
-writeFile :: FilePath -> String -> IO ()
-writeFile f = B.writeFile (encodeString f) . fromString
-
-getContents :: IO String
-getContents = liftM (toString . stripBOM) B.getContents
-
-putStr :: String -> IO ()
-putStr = B.putStr . fromString
-
-putStrLn :: String -> IO ()
-putStrLn = C.putStrLn . fromString
-
-hGetContents :: Handle -> IO String
-hGetContents h = liftM (toString . stripBOM) (B.hGetContents h)
-
-hPutStr :: Handle -> String -> IO ()
-hPutStr h = B.hPutStr h . fromString
-
-hPutStrLn :: Handle -> String -> IO ()
-hPutStrLn h s = hPutStr h (s ++ "\n")

− src/lib/DatabaseDesign/Ampersand/Basics/Version.hs 
@@ -1,33 +0,0 @@-{-# OPTIONS_GHC -Wall #-}--- | This module contains Version of Ampersand-module DatabaseDesign.Ampersand.Basics.Version (ampersandVersionStr, ampersandVersionWithoutBuildTimeStr, fatalMsg) where--import DatabaseDesign.Ampersand.Basics.BuildInfo_Generated---- | a function to create error message in a structured way, containing the version of Ampersand. ---   It throws an error, showing a (module)name and a number. This makes debugging pretty easy. -fatalMsg :: String -> Int -> String -> a-fatalMsg haskellModuleName lineNr msg- = error ("!fatal "++show lineNr++" (module "++haskellModuleName++") "++ampersandVersionWithoutBuildTimeStr++"\n  "++-            let maxLen = 1500 -- This trick is to make sure the process is terminated after the error. -                              -- If the string is too long, it seems that the sentinel `hangs`.-                              -- But what is too long???-            in case drop maxLen msg of-                [] -> msg-                _  -> take maxLen msg ++"\n<The rest of error message has been cut off.>"-           )---- | String, containing the Ampersand version, including the build timestamp.-ampersandVersionStr :: String-ampersandVersionStr = ampersandVersionWithoutBuildTimeStr ++", build time: "++buildTimeStr---- | String, containing the Ampersand version-ampersandVersionWithoutBuildTimeStr :: String-ampersandVersionWithoutBuildTimeStr = "Ampersand v"++cabalVersionStr++"."++svnRevisionStr-{- -   #1.#2.#3.#4 : #1 major version; #2 student release version; #3 production fix version (normally 0 ); -   #4 SVN revision number: -      - may be a range separated by ':' if the working copy contains mixed revisions (e.g. "163:165")-      - ends with an 'M' if the working copy was modified (e.g. "163M")-      - for other (rare) values, see the output of the command 'svnversion --help' --}
− src/lib/DatabaseDesign/Ampersand/Classes.hs 
@@ -1,10 +0,0 @@-{-# OPTIONS_GHC -Wall #-}
-module DatabaseDesign.Ampersand.Classes (module X) where
-import DatabaseDesign.Ampersand.Classes.Populated as X
-       (fullContents,atomsOf)
-import DatabaseDesign.Ampersand.Classes.ConceptStructure as X
-       (ConceptStructure(..),prim2rel)
-import DatabaseDesign.Ampersand.Classes.Relational as X
-       (Relational(..))
-import DatabaseDesign.Ampersand.Classes.ViewPoint as X
-       (Language(..), ProcessStructure(..))
− src/lib/DatabaseDesign/Ampersand/Classes/ConceptStructure.hs 
@@ -1,213 +0,0 @@-{-# OPTIONS_GHC -Wall #-}
-{-# LANGUAGE FlexibleInstances #-}
-module DatabaseDesign.Ampersand.Classes.ConceptStructure          (ConceptStructure(..), prim2rel)
-where
-   import DatabaseDesign.Ampersand.Core.AbstractSyntaxTree       
-   import DatabaseDesign.Ampersand.Core.ParseTree (ConceptDef(..))
-   import DatabaseDesign.Ampersand.Basics
-   import Data.List
-   import Data.Maybe
-   import DatabaseDesign.Ampersand.ADL1.Expression
-   import Prelude hiding (Ordering(..))
-   fatal :: Int -> String -> a
-   fatal = fatalMsg "Classes.ConceptStructure"
-
-   class ConceptStructure a where
-    concs ::    a -> [A_Concept]       -- ^ the set of all concepts used in data structure a
-    relsUsedIn :: a -> [Declaration]        -- ^ the set of all declaratons used within data structure a. `used within` means that there is a relation that refers to that declaration.
-    relsUsedIn a = [ d | d@Sgn{}<-relsMentionedIn a]++[Isn c | c<-concs a]
-    relsMentionedIn :: a -> [Declaration]        -- ^ the set of all declaratons used within data structure a. `used within` means that there is a relation that refers to that declaration.
-    relsMentionedIn = nub . map prim2rel . primsMentionedIn
-    primsMentionedIn :: a -> [Expression]
-    primsMentionedIn = nub . concatMap primitives . expressionsIn
-    expressionsIn :: a -> [Expression] -- ^The set of all expressions within data structure a 
-    mp1Exprs :: a -> [Expression]     -- ^ the set of all EMp1 expressions within data structure a (needed to get the atoms of these relations into the populationtable)
-    mp1Exprs = filter isMp1.primsMentionedIn
-    -- | mp1Pops draws the population from singleton expressions.
-    mp1Pops :: a -> [Population]
-    mp1Pops struc
-     = [ PCptPopu{ popcpt = cpt (head cl), popas = map atm cl } | cl<-eqCl cpt (mp1Exprs struc)]
-       where cpt (EMp1 _ c) = c
-             cpt _          = fatal 31 "cpt error"
-             atm (EMp1 a _) = a
-             atm _          = fatal 31 "atm error"
-
-   prim2rel :: Expression -> Declaration
-   prim2rel e
-    = case e of
-       EDcD d@Sgn{} -> d
-       EDcD{}       -> fatal 23 "invalid declaration in EDcD{}" 
-       EDcI c       -> Isn c
-       EDcV sgn     -> Vs sgn
-       EMp1 _ c     -> Isn c
-       _            -> fatal 40 $ "only primitive expressions should be found here.\nHere we see: " ++ show e
-
-   instance (ConceptStructure a,ConceptStructure b) => ConceptStructure (a, b)  where
-    concs    (a,b) = concs a `uni` concs b
-    expressionsIn (a,b) = expressionsIn a `uni` expressionsIn b
-
-   instance ConceptStructure a => ConceptStructure (Maybe a) where
-    concs    ma = maybe [] concs ma
-    expressionsIn ma = maybe [] expressionsIn ma
- 
-   instance ConceptStructure a => ConceptStructure [a] where
-    concs     = nub . concatMap concs
-    expressionsIn = foldr ((uni) . expressionsIn) [] 
-    
-   instance ConceptStructure A_Context where 
-    concs ctx = foldr uni []
-                [ (concs.ctxpats) ctx
-                , (concs.ctxprocs) ctx
-                , (concs.ctxrs) ctx
-                , (concs.ctxds) ctx
-                , (concs.ctxpopus) ctx
-                , (concs.ctxcds) ctx
-                , (concs.ctxks) ctx
-                , (concs.ctxvs) ctx
-                , (concs.ctxgs) ctx
-                , (concs.ctxifcs) ctx
-                , (concs.ctxps) ctx
-                , (concs.ctxsql) ctx
-                , (concs.ctxphp) ctx
-                ]
-    expressionsIn ctx = foldr uni []
-                        [ (expressionsIn.ctxpats) ctx
-                        , (expressionsIn.ctxprocs) ctx
-                        , (expressionsIn.ctxifcs) ctx
-                        , (expressionsIn.ctxrs) ctx
-                        , (expressionsIn.ctxks) ctx
-                        , (expressionsIn.ctxvs) ctx
-                        , (expressionsIn.ctxsql) ctx
-                        , (expressionsIn.ctxphp) ctx
-                        ]
-
-   instance ConceptStructure IdentityDef where
-    concs       identity   = [idCpt identity] `uni` concs [objDef | IdentityExp objDef <- identityAts identity]
-    expressionsIn identity = expressionsIn             [objDef | IdentityExp objDef <- identityAts identity]
-
-   instance ConceptStructure ViewDef where
-    concs       vd = [vdcpt vd] `uni` concs [objDef | ViewExp objDef <- vdats vd]
-    expressionsIn vd = expressionsIn        [objDef | ViewExp objDef <- vdats vd]
-
-   instance ConceptStructure Expression where
-    concs (EDcI c    ) = [c]
-    concs (EEps i sgn) = nub (i:concs sgn)
-    concs (EDcV   sgn) = concs sgn
-    concs (EMp1 _ c  ) = [c]
-    concs e            = foldrMapExpression uni concs [] e
-    expressionsIn e = [e]
-
-
-   instance ConceptStructure A_Concept where
-    concs         c = [c]
-    expressionsIn _ = []
-
-   instance ConceptStructure ConceptDef where
-    concs        cd = [PlainConcept (cdcpt cd)]
-    expressionsIn _ = []
-
-   instance ConceptStructure Sign where
-    concs (Sign s t) = nub [s,t]
-    expressionsIn _  = []
-
-   instance ConceptStructure ObjectDef where
-    concs     obj = [target (objctx obj)] `uni` concs (objmsub obj)
-    expressionsIn obj = foldr (uni) []
-                       [ (expressionsIn.objctx) obj
-                       , (expressionsIn.objmsub) obj
-                       ]
-
-   -- Note that these functions are not recursive in the case of InterfaceRefs (which is of course obvious from their types)
-   instance ConceptStructure SubInterface where
-    concs (Box _ objs)         = concs objs 
-    concs (InterfaceRef _)   = [] 
-    expressionsIn (Box _ objs)       = expressionsIn objs 
-    expressionsIn (InterfaceRef _) = [] 
-          
-   instance ConceptStructure Pattern where
-    concs pat = foldr uni []
-                [ (concs.ptrls) pat
-                , (concs.ptgns) pat
-                , (concs.ptdcs) pat
-                , (concs.ptups) pat
-                , (concs.ptids) pat
-                , (concs.ptxps) pat
-                ]
-    expressionsIn p = foldr (uni) []
-                       [ (expressionsIn.ptrls) p
-                       , (expressionsIn.ptids) p
-                       , (expressionsIn.ptvds) p
-                       ]
-
-
-   instance ConceptStructure Process where
-    concs prc = foldr uni []
-                [ (concs.prcRules) prc
-                , (concs.prcGens) prc
-                , (concs.prcDcls) prc
-                , (concs.prcUps) prc
-                , (concs.prcIds) prc
-                , (concs.prcVds) prc
-                , (concs.prcXps) prc
-                ]
-    expressionsIn p = foldr (uni) []
-                       [ (expressionsIn.prcRules) p
-                       , (expressionsIn.prcIds) p
-                       , (expressionsIn.prcVds) p
-                       ]
-
-   instance ConceptStructure Interface where
-    concs         ifc = concs (ifcObj ifc)
-    expressionsIn ifc = foldr (uni) []
-                       [ (expressionsIn.ifcObj) ifc
-                       , (expressionsIn.ifcParams) ifc
-                       ]
-
-   instance ConceptStructure Declaration where
-    concs         d = concs (sign d)
-    expressionsIn _ = fatal 148 "expressionsIn not allowed on Declaration"
-
-   instance ConceptStructure Rule where
-    concs r   = concs (rrexp r) `uni` concs (rrviol r)
-    expressionsIn r = foldr (uni) []
-                     [ (expressionsIn.rrexp ) r
-                     , (expressionsIn.rrviol) r
-                     ]
-   
-   instance ConceptStructure (PairView Expression) where
-    concs         (PairView ps) = concs         ps
-    expressionsIn (PairView ps) = expressionsIn ps
-
-   instance ConceptStructure Population where
-    concs pop@PRelPopu{} = concs (popdcl pop)
-    concs pop@PCptPopu{} = concs (popcpt pop)
-    expressionsIn _    = []
-
-   instance ConceptStructure Purpose where
-    concs pop@Expl{} = concs (explObj pop)
-    expressionsIn _ = []
-
-   instance ConceptStructure ExplObj where
-    concs (ExplConceptDef cd) = concs cd
-    concs (ExplDeclaration d) = concs d
-    concs (ExplRule _)        = [{-beware of loops...-}] 
-    concs (ExplIdentityDef _) = [{-beware of loops...-}]
-    concs (ExplViewDef _)     = [{-beware of loops...-}]
-    concs (ExplPattern _)     = [{-beware of loops...-}]
-    concs (ExplProcess _)     = [{-beware of loops...-}]
-    concs (ExplInterface _)   = [{-beware of loops...-}]
-    concs (ExplContext _)     = [{-beware of loops...-}]
-    
-    expressionsIn _ = []
-
-   instance ConceptStructure (PairViewSegment Expression) where
-    concs       (PairViewText _)  = []
-    concs       (PairViewExp _ x) = concs x
-    expressionsIn    (PairViewText _)  = []
-    expressionsIn    (PairViewExp _ x) = expressionsIn x
-     
-   instance ConceptStructure A_Gen where
-    concs g@Isa{}  = nub [gengen g,genspc g]  
-    concs g@IsE{}  = nub (genspc g: genrhs g)
-    expressionsIn _ = fatal 160 "expressionsIn not allowed on A_Gen"
-    
− src/lib/DatabaseDesign/Ampersand/Classes/Populated.hs 
@@ -1,111 +0,0 @@-{-# OPTIONS_GHC -Wall #-}
-module DatabaseDesign.Ampersand.Classes.Populated                 (fullContents,atomsOf)
-{- This file contains all functions to compute populations.
-   The implementation is done through Haskell's Map mechanism, as defined in Data.Map, for reasons of efficiency.
--}
-where
-   import Prelude hiding (lookup)
-   import DatabaseDesign.Ampersand.ADL1.Pair
-   import DatabaseDesign.Ampersand.ADL1.Expression                 (notCpl)
-   import DatabaseDesign.Ampersand.Core.AbstractSyntaxTree
-   import DatabaseDesign.Ampersand.Basics                          (Collection (uni,isc,(>-)),fatalMsg, Identified(..))  
-   import Data.Map (Map, (!), lookup, keys, assocs, elems, fromList, fromListWith, unionWith, unionsWith, differenceWith, mergeWithKey, empty)
-      -- WHY: don't we use strict Maps? Since the sets of atoms and pairs are finite, we might want the efficiency of strictness.
-   import Data.Maybe (maybeToList)
-   import Data.List (nub)
-   fatal :: Int -> String -> a
-   fatal = fatalMsg "Classes.Populated"
-
-   
-   -- | This function returns the atoms of a concept (like fullContents does for relation-like things.)
-   atomsOf :: [A_Gen]      -- the generalisation relations from the context
-           -> [Population] -- the user defined populations in the context
-           -> A_Concept    -- the concept from which the population is requested
-           -> [String]     -- the elements in the concept's set of atoms
-   atomsOf gens pt c
-    = case c of
-        ONE -> ["1"] -- fatal 22 "Asking for the value of the universal singleton"
-        PlainConcept{}
-            -> let smallerconcs = c:smallerConcepts gens c in
-               nub$ [srcPaire p | pop@PRelPopu{} <- pt, source (popdcl pop) `elem` smallerconcs, p <- popps pop]
-                  ++[trgPaire p | pop@PRelPopu{} <- pt, target (popdcl pop) `elem` smallerconcs, p <- popps pop]
-                  ++[a          | pop@PCptPopu{} <- pt, popcpt pop `elem` smallerconcs, a <- popas pop]
-
-   pairsOf :: [A_Gen] -> [Population] -> Declaration -> Map String [String]
-   pairsOf gens pt dcl
-    = case dcl of
-        Isn c  -> fromList [ (a,[a])   | a  <-atomsOf gens pt c]
-        Vs sgn -> fromList [ (sa, atomsOf gens pt (target sgn)) | sa <-atomsOf gens pt (source sgn)]
-        Sgn{}  -> unionsWith uni
-                         [ fromListWith uni [ (srcPaire p,[trgPaire p]) | p<-popps pop]
-                         | pop@PRelPopu{} <- pt
-                         , name dcl==name (popdcl pop)
-                         , let s=source (popdcl pop) in s `elem` s:smallerConcepts gens (source dcl)
-                         , let t=target (popdcl pop) in t `elem` t:smallerConcepts gens (target dcl)
-                         ]
-
-   fullContents :: [A_Gen] -> [Population] -> Expression -> Pairs
-   fullContents gens pt e = [ mkPair a b | let pairMap=contents e, a<-keys pairMap, b<-pairMap ! a ]
-     where
-      unions t1 t2 = unionWith uni t1 t2
-      inters t1 t2 = mergeWithKey (\_ l r ->case l `isc` r of [] -> Nothing; atoms -> Just atoms) c c t1 t2
-                     where c=const empty
-      differ t1 t2 = differenceWith (\l r->case l >- r of [] -> Nothing; atoms -> Just atoms) t1 t2
-      contents :: Expression -> Map String [String]
-      contents expr
-       = let lkp x contMap = (concat.maybeToList.lookup x) contMap in  -- (!) may not be used, because we don't know whether x `elem` keys fmap
-         case expr of
-            EEqu (l,r) -> contents ((l .|-. r) ./\. (r .|-. l))
-            EImp (l,r) -> contents (notCpl l .\/. r)
-            EUni (l,r) -> unions (contents l) (contents r)
-            EIsc (l,r) -> inters (contents l) (contents r)
-            EDif (l,r) -> differ (contents l) (contents r)
-            -- The left residual l/r is defined by: for all x,y:  x(l/r)y  <=>  for all z in X, y r z implies x l z.
-            ELrs (l,r) -> fromListWith (++)
-                          [(x,[y]) | x<-atomsOf gens pt (source l), y<-atomsOf gens pt (source r)
-                                   , null (lkp y (contents r) >- lkp x (contents l))
-                                   ]
-            -- The right residual l\r defined by: for all x,y:   x(l\r)y  <=>  for all z in X, z l x implies z r y.
-            ERrs (l,r) -> fromListWith uni
-                          [(x,[y]) | x<-atomsOf gens pt (target l), y<-atomsOf gens pt (target r)
-                                   , null (lkp x (contents (EFlp l)) >- lkp y (contents (EFlp r)))
-                                   ]
-            EDia (l,r) -> fromListWith (++)
-                          [(x,[y]) | x<-atomsOf gens pt (source l), y<-atomsOf gens pt (source r)
-                                   , null (lkp y (contents r) >- lkp x (contents l))
-                                   , null (lkp y (contents l) >- lkp x (contents r))
-                                   ]
-            ERad (l,r) -> fromListWith uni
-                          [(x,[y]) | x<-atomsOf gens pt (source l), y<-atomsOf gens pt (target r)
-                                   , null (atomsOf gens pt (target l) >- (lkp x (contents l) `uni` lkp y (contents (EFlp r))))
-                                   ]
-            EPrd (l,r) -> fromList $ 
-                          [ (a,cod) | a <- atomsOf gens pt (source l), let cod=atomsOf gens pt (target r), not (null cod) ]
-            ECps (l,r) -> fromListWith uni
-                          [(x,[y]) | x<-keys (contents l), y<-keys flipr
-                                   , (not.null) ((contents l ! x ) `isc` (flipr ! y))
-                                   ] where flipr = contents (EFlp r)
-            EKl0 x     -> if source x == target x --see #166
-                          then closMap (unionWith uni (contents x) (contents (EDcI (source x))))
-                          else fatal 87 ("source and target of "++show x++show (sign x)++ " are not equal.")
-            EKl1 x     -> if source x == target x --see #166
-                          then closMap (contents x)
-                          else fatal 90 ("source and target of "++show x++show (sign x)++ " are not equal.")
-            EFlp x     -> fromListWith uni [(b,[a]) | (a,bs)<-assocs (contents x), b<-bs]
-            ECpl x     -> contents (EDcV (sign x) .-. x)
-            EBrk x     -> contents x
-            EDcD dcl   -> pairsOf gens pt dcl
-            EDcI c     -> fromList [(a,[a]) | a <- atomsOf gens pt c]
-            EEps i _   -> fromList [(a,[a]) | a <- atomsOf gens pt i]
-            EDcV sgn   -> fromList [(s, cod) | s <- atomsOf gens pt (source sgn), let cod=atomsOf gens pt (target sgn), not (null cod) ]
-            EMp1 a c   -> fromList [(a,[a]) | name c/="SESSION"] -- prevent populating SESSION
-
-----------------------------------------------------
---  Warshall's transitive closure algorithm in Haskell:
-----------------------------------------------------
-   closMap :: (Eq a, Ord a) => Map a [a] -> Map a [a]
-   closMap xs
-     = foldl f xs (keys xs `isc` nub (concat (elems xs)))
-       where
-        f :: (Eq a, Ord a) => Map a [a] -> a -> Map a [a]   -- The type is given for documentation purposes only
-        f q x = unionWith uni q (fromListWith uni [(a, q ! x) | (a, bs) <- assocs q, x `elem` bs])

− src/lib/DatabaseDesign/Ampersand/Classes/Relational.hs 
@@ -1,212 +0,0 @@-{-# OPTIONS_GHC -Wall #-}
-module DatabaseDesign.Ampersand.Classes.Relational 
-   (Relational(..)
-   ) where
-
-import Data.Maybe
-import DatabaseDesign.Ampersand.Core.AbstractSyntaxTree
-import DatabaseDesign.Ampersand.Core.ParseTree       (Prop(..))
-import DatabaseDesign.Ampersand.ADL1.Expression
-import DatabaseDesign.Ampersand.Basics
-
-fatal :: Int -> String -> a
-fatal = fatalMsg "Classes.Relational"
-
-class Association r => Relational r where
-    multiplicities :: r -> [Prop]
-    isProp :: r -> Bool  -- > tells whether the argument is a property
-    isImin :: r -> Bool  -- > tells whether the argument is equivalent to I-
-    isTrue :: r -> Bool  -- > tells whether the argument is equivalent to V
-    isFalse :: r -> Bool  -- > tells whether the argument is equivalent to V-
-    isFunction :: r -> Bool     
-    isFunction r   = null ([Uni,Tot]>-multiplicities r)
-    isTot :: r -> Bool  -- 
-    isTot r = Tot `elem` multiplicities r
-    isUni :: r -> Bool  -- 
-    isUni r = Uni `elem` multiplicities r
-    isSur :: r -> Bool  -- 
-    isSur r = Sur `elem` multiplicities r
-    isInj :: r -> Bool  -- 
-    isInj r = Inj `elem` multiplicities r
-    isRfx :: r -> Bool  -- 
-    isRfx r = Rfx `elem` multiplicities r
-    isIrf :: r -> Bool  -- 
-    isIrf r = Irf `elem` multiplicities r
-    isTrn :: r -> Bool  -- 
-    isTrn r = Trn `elem` multiplicities r
-    isSym :: r -> Bool  -- 
-    isSym r = Sym `elem` multiplicities r
-    isAsy :: r -> Bool  -- 
-    isAsy r = Asy `elem` multiplicities r
-    isIdent :: r -> Bool  -- > tells whether the argument is equivalent to I
-    isEpsilon :: r -> Bool  -- > tells whether the argument is equivalent to I
-
---instance Relational Relation where
---    multiplicities rel 
---      = case rel of
---           Rel{}               -> multiplicities (reldcl rel)
---           V {}                -> [Tot]
---                                ++[Sur]
---                                ++[Inj | isSingleton (source rel)]
---                                ++[Uni | isSingleton (target rel)]
---                                ++[Asy | isEndo rel, isSingleton (source rel)]
---                                ++[Sym | isEndo rel]
---                                ++[Rfx | isEndo rel]
---                                ++[Trn | isEndo rel]
---           I{}                 -> [Uni,Tot,Inj,Sur,Sym,Asy,Trn,Rfx]
---    isProp rel = case rel of
---           Rel{}               -> null ([Asy,Sym]>-multiplicities (reldcl rel))
---           V{}                 -> isEndo rel && isSingleton (source rel)
---           I{}                 -> True
---    isImin rel  = isImin (makeDeclaration rel)   -- > tells whether the argument is equivalent to I-
---    isTrue rel = case rel of
---           Rel{}               -> False
---           V{}                 -> True
---           I{}                 -> False
---    isFalse _   = False
---    isIdent rel = case rel of       -- > tells whether the argument is equivalent to I
---                   Rel{} -> False
---                   V{}   -> isEndo rel && isSingleton (source rel)
---                   I{}   -> True
-
-instance Relational Declaration where
-    multiplicities d = case d of
-           Sgn {}       -> case decprps_calc d of
-                             Nothing -> decprps d
-                             Just ps -> ps 
-           Isn{}        -> [Uni,Tot,Inj,Sur,Sym,Asy,Trn,Rfx]
-           Vs{}         -> [Tot,Sur]
-    isProp d = case d of         -- > tells whether the argument is a property.
-           Sgn {}       -> null ([Asy,Sym]>-multiplicities d)
-           Isn{}        -> True
-           Vs{}         -> isEndo (sign d) && isSingleton (source d)
-    isImin _ = False  -- LET OP: Dit kan natuurlijk niet goed zijn, maar is gedetecteerd bij revision 913, toen straffeloos de Iscompl{} kon worden verwijderd.
-    isTrue d = case d of 
-           Vs{}         -> True
-           _            -> False
-    isFalse _ = False
-    isIdent d = case d of
-                 Isn{} -> True   -- > tells whether the argument is equivalent to I
-                 _     -> False
-    isEpsilon _ = False
-
-isSingleton :: A_Concept -> Bool
-isSingleton ONE = True
-isSingleton _   = False
-
--- The function "multiplicities" does not only provide the multiplicities provided by the Ampersand user,
--- but tries to derive the most obvious multiplicity constraints as well. The more multiplicity constraints are known,
--- the better the data structure that is derived.
--- Not every constraint that can be proven is obtained by this function. This does not hurt Ampersand.
-instance Relational Expression where        -- TODO: see if we can find more multiplicity constraints...
- multiplicities expr = case expr of
-     EDcD dcl   -> multiplicities dcl
-     EDcI{}     -> [Uni,Tot,Inj,Sur,Sym,Asy,Trn,Rfx]
-     EEps a sgn -> [Tot | a == source sgn]++[Sur | a == target sgn] ++ [Uni,Inj]
-     EDcV sgn   -> [Tot]
-                 ++[Sur]
-                 ++[Inj | isSingleton (source sgn)]
-                 ++[Uni | isSingleton (target sgn)]
-                 ++[Asy | isEndo sgn, isSingleton (source sgn)]
-                 ++[Sym | isEndo sgn]
-                 ++[Rfx | isEndo sgn]
-                 ++[Trn | isEndo sgn]
-     EBrk f     -> multiplicities f
-     ECps (l,r) -> [m | m<-multiplicities l `isc` multiplicities r, m `elem` [Uni,Tot,Inj,Sur]] -- endo properties can be used and deduced by and from rules: many rules are multiplicities (TODO)
-     EPrd (l,r) -> [Tot | isTot l]++[Sur | isSur r]++[Rfx | isRfx l&&isRfx r]++[Trn]
-     EKl0 e'    -> [Rfx,Trn] `uni` (multiplicities e'>-[Uni,Inj])
-     EKl1 e'    -> [    Trn] `uni` (multiplicities e'>-[Uni,Inj])
-     ECpl e'    -> [p |p<-multiplicities e', p==Sym]
-     EFlp e'    -> [fromMaybe m $ lookup m [(Uni,Inj),(Inj,Uni),(Sur,Tot),(Tot,Sur)] | m <- multiplicities e'] -- switch Uni<->Inj and Sur<->Tot, keeping the others the same
-     EMp1{}     -> [Uni,Inj,Sym,Asy,Trn]
-     _          -> []
-
- -- |  isTrue e == True   means that e is true, i.e. the population of e is (source e * target e).
- --    isTrue e == False  does not mean anything.
- --    the function isTrue is meant to produce a quick answer, without any form of theorem proving.
- isTrue expr
-  = case expr of
-     EEqu (l,r) -> l == r
-     EImp (l,_) -> isTrue l
-     EIsc (l,r) -> isTrue l && isTrue r
-     EUni (l,r) -> isTrue l || isTrue r 
-     EDif (l,r) -> isTrue l && isFalse r
-     ECps (l,r) | null ([Uni,Tot]>-multiplicities l) -> isTrue r
-                | null ([Sur,Inj]>-multiplicities r) -> isTrue l
-                | otherwise                          -> isTrue l && isTrue r
-     EPrd (l,r) -> isTrue l && isTrue r || isTot l && isSur r || isRfx l && isRfx r
-     EKl0 e     -> isTrue e
-     EKl1 e     -> isTrue e
-     EFlp e     -> isTrue e
-     ECpl e     -> isFalse e
-     EDcD{}     -> False
-     EDcI c     -> isSingleton c
-     EEps i _   -> isSingleton i
-     EDcV{}     -> True
-     EBrk e     -> isTrue e
-     _          -> False  -- TODO: find richer answers for ERrs, ELrs, EDia, ERad, and EMp1
-
- -- |  isFalse e == True   means that e is false, i.e. the population of e is empty.
- --    isFalse e == False  does not mean anything.
- --    the function isFalse is meant to produce a quick answer, without any form of theorem proving.
- isFalse expr
-  = case expr of
-     EEqu (l,r) -> l == notCpl r
-     EImp (_,r) -> isFalse r
-     EIsc (l,r) -> isFalse r || isFalse l
-     EUni (l,r) -> isFalse r && isFalse l
-     EDif (l,r) -> isFalse l || isTrue r
-     ECps (l,r) -> isFalse r || isFalse l
-     EPrd (l,r) -> isFalse r || isFalse l
-     EKl0 e     -> isFalse e
-     EKl1 e     -> isFalse e
-     EFlp e     -> isFalse e
-     ECpl e     -> isTrue e
-     EDcD{}     -> False
-     EDcI{}     -> False
-     EEps{}     -> False
-     EDcV{}     -> False
-     EBrk e     -> isFalse e
-     _          -> False  -- TODO: find richer answers for ERrs, ELrs, EDia, and ERad
-
- isProp expr = null ([Asy,Sym]>-multiplicities expr)
-
- -- |  The function isIdent tries to establish whether an expression is an identity relation.
- --    It does a little bit more than just test on ERel I _.
- --    If it returns False, this must be interpreted as: the expression is definitely not I, an may not be equal to I as far as the computer can tell on face value. 
- isIdent expr = case expr of
-     EEqu (l,r) -> isIdent (EIsc (EImp (l,r), EImp (r,l)))    -- TODO: maybe derive something better?
-     EImp (l,r) -> isIdent (EUni (ECpl l, r))                     -- TODO: maybe derive something better?
-     EIsc (l,r) -> isIdent l && isIdent r
-     EUni (l,r) -> isIdent l && isIdent r
-     EDif (l,r) -> isIdent l && isFalse r
-     ECps (l,r) -> isIdent l && isIdent r
-     EKl0 e     -> isIdent e || isFalse e
-     EKl1 e     -> isIdent e
-     ECpl e     -> isImin e
-     EDcD{}     -> False
-     EDcI{}     -> True
-     EEps i sgn -> if isEndo sgn && i==source expr then fatal 189 (show expr++" is endo") else
-                   False
-     EDcV sgn   -> isEndo sgn && isSingleton (source sgn)
-     EBrk f     -> isIdent f
-     EFlp f     -> isIdent f
-     _          -> False  -- TODO: find richer answers for ELrs, ERrs, EDia, EPrd, and ERad
- isEpsilon e = case e of
-                EEps{} -> True
-                _      -> False
- 
- isImin expr' = case expr' of       -- > tells whether the argument is equivalent to I-
-     EEqu (l,r) -> isImin (EIsc (EImp (l,r), EImp (r,l)))       -- TODO: maybe derive something better?
-     EImp (l,r) -> isImin (EUni (ECpl l, r))                  -- TODO: maybe derive something better?
-     EIsc (l,r) -> isImin l && isImin r
-     EUni (l,r) -> isImin l && isImin r
-     EDif (l,r) -> isImin l && isFalse r
-     ECpl e     -> isIdent e
-     EDcD dcl   -> isImin dcl
-     EDcI{}     -> False
-     EEps{}     -> False
-     EDcV{}     -> False
-     EBrk f     -> isImin f
-     EFlp f     -> isImin f
-     _          -> False  -- TODO: find richer answers for ELrs, ERrs, and EDia

− src/lib/DatabaseDesign/Ampersand/Classes/ViewPoint.hs 
@@ -1,209 +0,0 @@-{-# OPTIONS_GHC -Wall #-}
-module DatabaseDesign.Ampersand.Classes.ViewPoint (Language(..),ProcessStructure(..)) where
-import DatabaseDesign.Ampersand.Core.ParseTree
-import DatabaseDesign.Ampersand.Core.AbstractSyntaxTree
-import Prelude hiding (Ord(..))
-import DatabaseDesign.Ampersand.ADL1.Rule                    (rulefromProp, ruleviolations)
-import DatabaseDesign.Ampersand.Classes.Relational  (Relational(multiplicities))
-import DatabaseDesign.Ampersand.Basics
-import DatabaseDesign.Ampersand.Misc.Explain
-import Data.List
- 
-fatal :: Int -> String -> a
-fatal = fatalMsg "Classes.ViewPoint"
-
--- Language exists because there are many data structures that behave like an ontology, such as Pattern, P_Context, and Rule.
--- These data structures are accessed by means of a common set of functions (e.g. rules, relations, etc.)
-
-class Language a where
-  objectdef :: a -> ObjectDef        -- ^ The objectdef that characterizes this viewpoint
-  relsDefdIn :: a -> [Declaration]   -- ^ all relations that are declared in the scope of this viewpoint.
-                                     --   These are user defined relations and all generated relarations,
-                                     --   i.e. one relation for each GEN and one for each signal rule.
-                                     --   Don't confuse relsDefdIn with relsUsedIn, which gives the relations that are
-                                     --   used in a.)
-  udefrules :: a -> [Rule]           -- ^ all user defined rules that are maintained within this viewpoint,
-                                     --   which are not multiplicity- and not identity rules.
-  invariants :: a -> [Rule]          -- ^ all rules that are not maintained by users will be maintained by the computer.
-                                     --   That includes multiplicity rules and identity rules, but excludes rules that are assigned to a role.
-                                     -- ^ all relations used in rules must have a valid declaration in the same viewpoint.
-  invariants x  = [r |r<-udefrules x, not (isSignal r)] ++ multrules x ++ identityRules x
-  multrules :: a -> [Rule]           -- ^ all multiplicityrules that are maintained within this viewpoint.
-  multrules x   = [rulefromProp p d |d<-relsDefdIn x, p<-multiplicities d]
-  identityRules :: a -> [Rule]       -- all identity rules that are maintained within this viewpoint.
-  identityRules x    = concatMap rulesFromIdentity (identities x)
-  identities :: a -> [IdentityDef]   -- ^ all keys that are defined in a
-  viewDefs :: a -> [ViewDef]         -- ^ all views that are defined in a
-  gens :: a -> [A_Gen]               -- ^ all generalizations that are valid within this viewpoint
-  patterns :: a -> [Pattern]         -- ^ all patterns that are used in this viewpoint
-  
-
-
-class ProcessStructure a where
-  processes :: a -> [Process]       -- ^ all roles that are used in this ProcessStructure
-  roles :: a -> [String]        -- ^ all roles that are used in this ProcessStructure
-  interfaces :: a -> [Interface]     -- ^ all interfaces that are used in this ProcessStructure
-  objDefs :: a -> [ObjectDef]
-  processRules :: a -> [Rule]          -- ^ all process rules that are visible within this viewpoint
-                                       -- ^ all relations used in rules must have a valid declaration in the same viewpoint.
-  maintains :: a -> [(String,Rule)] -- ^ the string represents a Role
-  mayEdit :: a -> [(String,Declaration)] -- ^ the string represents a Role
-  workFromProcessRules :: [A_Gen] -> [Population] -> a -> [(Rule,Paire)]  --the violations of rules and multrules of this viewpoint
-  workFromProcessRules gens' udp x = [(r,viol) |r<-processRules x, viol<-ruleviolations gens' udp r]
-   
-rulesFromIdentity :: IdentityDef -> [Rule]
-rulesFromIdentity identity
- = [ if null (identityAts identity) then fatal 81 ("Moving into foldr1 with empty list (identityAts identity).") else
-     mkKeyRule
-      ( foldr1 (./\.) [  expr .:. flp expr | IdentityExp att <- identityAts identity, let expr=objctx att ]
-        .|-. EDcI (idCpt identity)) ]
- {-    diamond e1 e2 = (flp e1 .\. e2) ./\. (e1 ./. flp e2)  -}
- where ruleName = "identity_" ++ name identity
-       meaningEN = "Identity rule" ++ ", following from identity "++name identity
-       meaningNL = "Identiteitsregel" ++ ", volgend uit identiteit "++name identity
-       mkKeyRule expression =
-         Ru { rrnm   = ruleName
-            , rrexp  = expression
-            , rrfps  = origin identity     -- position in source file
-            , rrmean = AMeaning 
-                         [ A_Markup English ReST (string2Blocks ReST meaningEN)
-                         , A_Markup Dutch ReST (string2Blocks ReST meaningNL)
-                         ]
-            , rrmsg  = []
-            , rrviol = Nothing
-            , rrtyp  = sign expression
-            , rrdcl  = Nothing        -- This rule was not generated from a property of some declaration.
-            , r_env  = ""             -- For traceability: The name of the pattern. Unknown at this position but it may be changed by the environment.
-            , r_usr  = Identity            -- This rule was not specified as a rule in the Ampersand script, but has been generated by a computer
-            , isSignal  = False          -- This is not a signal rule
-            , srrel  = Sgn  { decnm   = ruleName
-                            , decsgn  = sign expression
-                            , decprps = []
-                            , decprps_calc = Nothing -- []
-                            , decprL  = ""
-                            , decprM  = ""
-                            , decprR  = ""
-                            , decMean = AMeaning 
-                                          [ A_Markup English ReST (string2Blocks ReST meaningEN)
-                                          , A_Markup Dutch ReST (string2Blocks ReST meaningNL)
-                                          ]
-                            , decfpos = origin identity
-                            , deciss  = False
-                            , decusr  = False
-                            , decpat  = ""
-                            , decplug = False
-                            }
-            }
-
-instance ProcessStructure a => ProcessStructure [a] where
-  processes     = concatMap processes
-  roles         = concatMap roles
-  interfaces    = concatMap interfaces
-  objDefs       = concatMap objDefs
-  processRules  = concatMap processRules
-  maintains     = concatMap maintains
-  mayEdit       = concatMap mayEdit
-
-instance Language A_Context where
-  objectdef    context = Obj { objnm   = name context
-                             , objpos  = Origin "Object generated by objectdef (Language A_Context)"
-                             , objctx  = EDcI ONE
-                             , objmsub = Just . Box ONE $ map (objectdef) (ctxpats context)
-                             , objstrs = []
-                             }
-  relsDefdIn context = uniteRels (concatMap relsDefdIn (patterns context)
-                                ++ concatMap relsDefdIn (processes context)
-                                ++ ctxds context)
-     where
-      -- relations with the same name, but different properties (decprps,pragma,decpopu,etc.) may exist and need to be united
-      -- decpopu, decprps and decprps_calc are united, all others are taken from the head.
-      uniteRels :: [Declaration] -> [Declaration]
-      uniteRels [] = []
-      uniteRels ds = [ d | cl<-eqClass (==) ds
-                         , let d=(head cl){ decprps      = (foldr1 uni.map decprps) cl
-                                          , decprps_calc = Nothing -- Calculation is only done in ADL2Fspc. -- was:(foldr1 uni.map decprps_calc) cl
-                                          }]
-  udefrules    context = concatMap udefrules  (ctxpats context) ++ concatMap udefrules  (ctxprocs context) ++ ctxrs context
-  identities   context = concatMap identities (ctxpats context) ++ concatMap identities (ctxprocs context) ++ ctxks context
-  viewDefs     context = concatMap viewDefs   (ctxpats context) ++ concatMap viewDefs   (ctxprocs context) ++ ctxvs context
-  gens         context = concatMap gens       (ctxpats context) ++ concatMap gens       (ctxprocs context) ++ ctxgs context
-  patterns             = ctxpats
-
-instance ProcessStructure A_Context where
-  processes            = ctxprocs
-  roles        context = nub ([r | proc<-ctxprocs context, r <- roles proc]++
-                              [r | interface<-ctxifcs context, r <- ifcRoles interface])
-  interfaces           = ctxifcs
-  objDefs      context = [ifcObj s | s<-ctxifcs context]
-  processRules context = [r |r<-udefrules context, (not.null) [role | (role, rul) <-maintains context, name r == name rul ] ]
-  maintains    context = maintains (ctxprocs context)
-  mayEdit      context = mayEdit (ctxprocs context)
-
-
-instance Language Process where
-  objectdef    prc = Obj { objnm   = name prc
-                         , objpos  = origin prc
-                         , objctx  = EDcI ONE
-                         , objmsub = Nothing
-                         , objstrs = []
-                         }
-  relsDefdIn proc = prcDcls proc
-  udefrules       = prcRules -- all user defined rules in this process
---  invariants proc = [r | r<-prcRules proc, not (isSignal r) ]
-  identities      = prcIds
-  viewDefs        = prcVds
-  gens            = prcGens
-  patterns    _   = []
-
-instance ProcessStructure Process where
-  processes    proc = [proc]
-  roles        proc = nub ( [r | (r,_) <- prcRRuls proc]++
-                            [r | (r,_) <- prcRRels proc] )
-  interfaces    _   = []
-  objDefs       _   = []
-  processRules proc = [r |r<-prcRules proc, isSignal r]
-  maintains         = prcRRuls  -- says which roles maintain which rules.
-  mayEdit           = prcRRels  -- says which roles may change the population of which relation.
-
-instance Language Pattern where
-  objectdef    pat = Obj { objnm   = name pat
-                         , objpos  = origin pat
-                         , objctx  = EDcI ONE
-                         , objmsub = Nothing
-                         , objstrs = []
-                         }
-  relsDefdIn pat = ptdcs pat
-  udefrules      = ptrls   -- all user defined rules in this pattern
---  invariants pat = [r |r<-ptrls pat, not (isSignal r)]
-  identities     = ptids 
-  viewDefs       = ptvds 
-  gens           = ptgns 
-  patterns   pat = [pat]
-
-instance Language Rule where
-  objectdef rule = Obj { objnm   = name rule
-                       , objpos  = origin rule
-                       , objctx  = EDcI ONE
-                       , objmsub = Nothing
-                       , objstrs = []
-                       }
-  relsDefdIn r = [srrel r | isSignal r] -- a process rule "declares" a new relation to store violations in. That relation is "stored" in that rule. Therefore it counts as a declaration.
-  udefrules  r = [r | r_usr r == UserDefined ]
---  invariants   r = [r | not (isSignal r)]
-  identities _ = []
-  viewDefs   _ = []
-  gens       _ = []
-  patterns r   = [A_Pat{ ptnm  = "Pattern for rule "++name r
-                       , ptpos = Origin "Nameless pattern generated by patterns (Language (Rule(Relation Concept))) "
-                       , ptend = Origin "Nameless pattern generated by patterns (Language (Rule(Relation Concept))) "
-                       , ptrls = [r]
-                       , ptgns = []  -- A rule defines no Gens.
-                       , ptdcs = relsDefdIn r
-                       , ptups = []
-                       , ptrruls = []
-                       , ptrrels = []
-                       , ptids = []
-                       , ptvds = []
-                       , ptxps = []
-                       }
-                 ]

− src/lib/DatabaseDesign/Ampersand/Components.hs 
@@ -1,142 +0,0 @@-{-# OPTIONS_GHC -Wall #-}
--- | This module contains the building blocks that are available in the Ampersand Library. These building blocks will be described further at [ampersand.sourceforge.net |the wiki pages of our project].
--- 
-module DatabaseDesign.Ampersand.Components 
-  ( -- * Type checking and calculus
-     makeFspec
-    -- * Generators of output
-   , generateAmpersandOutput
---   , doGenADL
---   , doGenProofs
---   , doGenHaskell
---   , doGenXML
---   , doGenUML
---   , doGenDocument
---   , doGenFPAExcel
-   , Guarded(..)
-    -- * etc...
-  )
-where
-import Prelude hiding (putStr,readFile,writeFile)
-import DatabaseDesign.Ampersand.Misc
-import DatabaseDesign.Ampersand.ADL1.P2A_Converters
-import Text.Pandoc 
-import Text.Pandoc.Builder
-import DatabaseDesign.Ampersand.Basics 
-import DatabaseDesign.Ampersand.Fspec
-import DatabaseDesign.Ampersand.Fspec.GenerateUML
-import DatabaseDesign.Ampersand.Fspec.ShowXMLtiny (showXML)
-import DatabaseDesign.Ampersand.Output
-import Control.Monad
-import System.FilePath
-
-fatal :: Int -> String -> a
-fatal = fatalMsg "Components"
-
---  | The Fspc is the datastructure that contains everything to generate the output. This monadic function
---    takes the Fspc as its input, and spits out everything the user requested.
-generateAmpersandOutput :: Options -> Fspc -> IO ()
-generateAmpersandOutput flags fSpec = 
- do { verboseLn flags "Generating common Ampersand artifacts..."
-    ; when (genXML flags)      $ doGenXML      fSpec flags
-    ; when (genUML flags)      $ doGenUML      fSpec flags 
-    ; when (haskell flags)     $ doGenHaskell  fSpec flags 
-    ; when (export2adl flags)  $ doGenADL      fSpec flags
-    ; when (genFspec flags)    $ doGenDocument fSpec flags 
-    ; when (genFPAExcel flags) $ doGenFPAExcel fSpec flags
-    ; when (proofs flags)      $ doGenProofs   fSpec flags
-    ; when (genMeat flags && (not . includeRap) flags)  -- When rap is included, the file is created there.
-        $ doGenMeatGrinder fSpec flags
-    --; Prelude.putStrLn $ "Declared rules:\n" ++ show (map showADL $ vrules fSpec)
-    --; Prelude.putStrLn $ "Generated rules:\n" ++ show (map showADL $ grules fSpec)
-    --; Prelude.putStrLn $ "Violations:\n" ++ show (violations fSpec)
-    ; verboseLn flags "Done."
-    }
-
--- An expression e is type ambiguous means that   (showADL e) cannot be parsed (in the context of fSpec) without a type ambiguity error.
--- Q: Should we disambiguate the exprs in the fSpec i.e. mapexprs disambiguate fSpec fSpec?
---    Or do we assume a correct implementation with unambiguous expressions only?
--- A: The fSpec may contain disambiguated expressions only. If one expression somewhere in fSpec is type-ambiguous, fSpec is wrong.
---    So the answer is: we assume a correct implementation with unambiguous expressions only.
-doGenADL :: Fspc -> Options -> IO()
-doGenADL    fSpec flags =
- do { writeFile outputFile (showADL fSpec) 
-    ; verboseLn flags $ ".adl-file written to " ++ outputFile ++ "."
-    }
- where outputFile = combine (dirOutput flags) (outputfile flags)
-
-doGenProofs :: Fspc -> Options -> IO()
-doGenProofs fSpec flags =
- do { verboseLn flags $ "Generating Proof for " ++ name fSpec ++ " into " ++ outputFile ++ "."
---  ; verboseLn flags $ writeTextile def thePandoc
-    ; writeFile outputFile $ writeHtmlString def thePandoc
-    ; verboseLn flags "Proof written."
-    }
- where outputFile = combine (dirOutput flags) $ replaceExtension ("proofs_of_"++baseName flags) ".html" 
-       thePandoc = setTitle title (doc theDoc)
-       title  = text $ "Proofs for "++name fSpec
-       theDoc = deriveProofs flags fSpec
-       --theDoc = plain (text "Aap")  -- use for testing...
-
-doGenHaskell :: Fspc -> Options -> IO()
-doGenHaskell fSpec flags =
- do { verboseLn flags $ "Generating Haskell source code for "++name fSpec
---  ; verboseLn flags $ fSpec2Haskell fSpec flags  -- switch this on to display the contents of Installer.php on the command line. May be useful for debugging.
-    ; writeFile outputFile (fSpec2Haskell fSpec flags) 
-    ; verboseLn flags $ "Haskell written into " ++ outputFile ++ "."
-    }
- where outputFile = combine (dirOutput flags) $ replaceExtension (baseName flags) ".hs"
-   
-doGenMeatGrinder :: Fspc -> Options -> IO()
-doGenMeatGrinder fSpec flags =
- do verboseLn flags $ "Generating meta-population for "++name fSpec
-    let (nm,content) = meatGrinder flags fSpec
-        outputFile = combine (dirOutput flags) $ replaceExtension nm ".adl"
-    writeFile outputFile content
-    verboseLn flags $ "Meta population written into " ++ outputFile ++ "."
-   
-doGenXML :: Fspc -> Options -> IO()
-doGenXML fSpec flags =
- do { verboseLn flags "Generating XML..."
-    ; writeFile outputFile $ showXML fSpec (genTime flags)   
-    ; verboseLn flags $ "XML written into " ++ outputFile ++ "."
-    }
-   where outputFile = combine (dirOutput flags) $ replaceExtension (baseName flags) ".xml"
-               
-doGenUML :: Fspc -> Options -> IO()
-doGenUML fSpec flags =
- do { verboseLn flags "Generating UML..."
-    ; writeFile outputFile $ generateUML fSpec flags
-    ; Prelude.putStrLn $ "Generated file: " ++ outputFile ++ "."
-    }
-   where outputFile = combine (dirOutput flags) $ replaceExtension (baseName flags) ".xmi"
-
--- This function will generate all Pictures for a given Fspc. 
--- the returned Fspc contains the details about the Pictures, so they
--- can be referenced while rendering the Fspc.
--- This function generates a pandoc document, possibly with pictures from an fSpec.
-doGenDocument :: Fspc -> Options -> IO()
-doGenDocument fSpec flags =
- do { verboseLn flags ("Processing "++name fSpec)
-    ; makeOutput
-    ; verboseLn flags $ "Document has been written to " ++ outputFile ++ "."
-    ; when (genGraphics flags && not(null thePictures) && fspecFormat flags/=FPandoc) $ 
-        mapM_ (writePicture flags) thePictures
-     -- postProcessing of the generated output file depends on the format:
-    ; postProcessor
-    }
-  where (thePandoc,thePictures) = 
-          case (theme flags, fspecFormat flags) of
- -- TODO Ticket #104: Could not find texOnly_proofdoc in any module? Where has in gone?
- --                (ProofTheme, FLatex ) -> (texOnly_proofdoc fSpec,[])     --generate a proof document
-                 (ProofTheme, _      ) -> fatal 116 "Ampersand only supports proof documents output in LaTeX format. try `-fLatex` "
-                 (_         , _      ) -> fSpec2Pandoc fSpec flags
-        (outputFile,makeOutput,postProcessor) = writepandoc flags fSpec thePandoc
-
--- | This function will generate an Excel workbook file, containing an extract from the Fspc
-doGenFPAExcel :: Fspc -> Options -> IO()
-doGenFPAExcel fSpec flags =
- do { verboseLn flags "Generating Excel..."
-    ; writeFile outputFile (showSpreadsheet (fspec2Workbook fSpec flags))
-    }
-   where outputFile = combine (dirOutput flags) $ replaceExtension ("FPA_"++baseName flags) ".xml"  -- Do not use .xls here, because that generated document contains xml. 

− src/lib/DatabaseDesign/Ampersand/Core/AbstractSyntaxTree.hs 
@@ -1,573 +0,0 @@-{-# OPTIONS_GHC -Wall #-}-{-# LANGUAGE FlexibleInstances, UndecidableInstances, OverlappingInstances #-}-module DatabaseDesign.Ampersand.Core.AbstractSyntaxTree (-   A_Context(..)- , Meta(..)- , Theme(..)- , Process(..)- , Pattern(..)- , PairView(..)- , PairViewSegment(..)- , Rule(..)- , RuleType(..)- , RuleOrigin(..)- , Declaration(..)- , IdentityDef(..)- , IdentitySegment(..)- , ViewDef(..)- , ViewSegment(..)- , A_Gen(..)- , Interface(..)- , SubInterface(..)- , ObjectDef(..)- , Object(..)- , objAts- , Purpose(..)- , ExplObj(..)- , Expression(..)- , A_Concept(..)- , A_Markup(..)- , AMeaning(..)- , RoleRelation(..)- , Sign(..)- , Population(..)- , GenR- , Association(..)-  -- (Poset.<=) is not exported because it requires hiding/qualifying the Prelude.<= or Poset.<= too much-  -- import directly from DatabaseDesign.Ampersand.Core.Poset when needed- , (<==>),join,meet,greatest,least,maxima,minima,sortWith - , smallerConcepts, largerConcepts, rootConcepts- , showSign- , aMarkup2String- , module DatabaseDesign.Ampersand.Core.ParseTree  -- export all used contstructors of the parsetree, because they have actually become part of the Abstract Syntax Tree.- , (.==.), (.|-.), (./\.), (.\/.), (.-.), (./.), (.\.), (.<>.), (.:.), (.!.), (.*.)-)where-import qualified Prelude-import Prelude hiding (Ord(..), Ordering(..))-import DatabaseDesign.Ampersand.Basics-import DatabaseDesign.Ampersand.Core.ParseTree   (MetaObj(..),Meta(..),ConceptDef,Origin(..),Traced(..),PairView(..),PairViewSegment(..),Prop,Lang,Pairs, PandocFormat, P_Markup(..), PMeaning(..), SrcOrTgt(..), isSrc)-import DatabaseDesign.Ampersand.Core.Poset (Poset(..), Sortable(..),Ordering(..),greatest,least,maxima,minima,sortWith)-import DatabaseDesign.Ampersand.Misc-import Text.Pandoc hiding (Meta)---import Debug.Trace-import Data.List (intercalate,nub,delete)-fatal :: Int -> String -> a-fatal = fatalMsg "Core.AbstractSyntaxTree"--data A_Context-   = ACtx{ ctxnm :: String           -- ^ 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 (currently: LaTeX, ...)-         , ctxthms :: [String]       -- ^ Names of patterns/processes to be printed in the functional specification. (For partial documents.)-         , ctxpats :: [Pattern]      -- ^ The patterns defined in this context-         , ctxprocs :: [Process]     -- ^ The processes defined in this context-         , ctxrs :: [Rule]           -- ^ All user defined rules in this context, but outside patterns and outside processes-         , ctxds :: [Declaration]    -- ^ 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-         , ctxcds :: [ConceptDef]    -- ^ 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-         , ctxvs :: [ViewDef]        -- ^ The view definitions defined in this context, outside the scope of patterns-         , ctxgs :: [A_Gen]          -- ^ 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, outside the scope of patterns-         , ctxps :: [Purpose]        -- ^ The purposes of objects defined in this context, outside the scope of patterns-         , ctxsql :: [ObjectDef]     -- ^ user defined sqlplugs, taken from the Ampersand script-         , ctxphp :: [ObjectDef]     -- ^ user defined phpplugs, taken from the Ampersand script-         , ctxmetas :: [Meta]        -- ^ used for Pandoc authors (and possibly other things)-         }               --deriving (Show) -- voor debugging-instance Show A_Context where-  showsPrec _ c = showString (ctxnm c)-instance Eq A_Context where-  c1 == c2  =  name c1 == name c2-instance Identified A_Context where-  name  = ctxnm--data Theme = PatternTheme Pattern | ProcessTheme Process--instance Identified Theme where-  name (PatternTheme pat) = name pat-  name (ProcessTheme prc) = name prc-  -instance Traced Theme where-  origin (PatternTheme pat) = origin pat-  origin (ProcessTheme prc) = origin prc-  -data Process = Proc { prcNm :: String-                    , prcPos :: Origin-                    , prcEnd :: Origin      -- ^ the end position in the file, elements with a position between pos and end are elements of this process.-                    , prcRules :: [Rule]-                    , prcGens :: [A_Gen]-                    , prcDcls :: [Declaration]-                    , prcUps :: [Population]  -- ^ The user defined populations in this process-                    , prcRRuls :: [(String,Rule)]    -- ^ The assignment of roles to rules.-                    , prcRRels :: [(String,Declaration)] -- ^ The assignment of roles to Relations.-                    , prcIds :: [IdentityDef]            -- ^ The identity definitions defined in this process-                    , prcVds :: [ViewDef]            -- ^ The view definitions defined in this process-                    , prcXps :: [Purpose]           -- ^ The motivations of elements defined in this process-                    }-instance Identified Process where-  name = prcNm--instance Traced Process where-  origin = prcPos--data RoleRelation-   = RR { rrRoles :: [String]     -- ^ name of a role-        , rrRels :: [Declaration]   -- ^ name of a Relation-        , rrPos :: Origin       -- ^ position in the Ampersand script-        } --deriving (Eq, Show)     -- just for debugging-instance Traced RoleRelation where-   origin = rrPos-    ---data Pattern-   = A_Pat { ptnm :: String         -- ^ Name of this pattern-           , ptpos :: Origin        -- ^ the position in the file in which this pattern was declared.-           , ptend :: Origin        -- ^ the end position in the file, elements with a position between pos and end are elements of this pattern.-           , ptrls :: [Rule]        -- ^ The user defined rules in this pattern-           , ptgns :: [A_Gen]       -- ^ The generalizations defined in this pattern-           , ptdcs :: [Declaration] -- ^ The relations that are declared in this pattern-           , ptups :: [Population]  -- ^ The user defined populations in this pattern-           , ptrruls :: [(String,Rule)]         -- ^ The assignment of roles to rules.-           , ptrrels :: [(String,Declaration)]  -- ^ The assignment of roles to Relations.-           , ptids :: [IdentityDef] -- ^ 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 (Show)    -- for debugging purposes-instance Identified Pattern where- name = ptnm-instance Traced Pattern where- origin = ptpos--data A_Markup =-    A_Markup { amLang :: Lang -- No Maybe here!  In the A-structure, it will be defined by the default if the P-structure does not define it. In the P-structure, the language is optional.-             , amFormat :: PandocFormat -- Idem: no Maybe in the A-structure.-             , amPandoc :: [Block]-             } deriving Show--data RuleOrigin = UserDefined     -- This rule was specified explicitly as a rule in the Ampersand script-                | Multiplicity    -- This rule follows implicitly from the Ampersand script (Because of a property) and generated by a computer-                | Identity             -- This rule follows implicitly from the Ampersand script (Because of a identity) and generated by a computer-                deriving (Show, Eq)-data Rule =-     Ru { rrnm :: String                  -- ^ Name of this rule-        , rrexp :: Expression              -- ^ The rule expression-        , rrfps :: Origin                  -- ^ Position in the Ampersand file-        , rrmean :: AMeaning                -- ^ Ampersand generated meaning (for all known languages)-        , rrmsg :: [A_Markup]              -- ^ User-specified violation messages, possibly more than one, for multiple languages.-        , rrviol :: Maybe (PairView Expression) -- ^ Custom presentation for violations, currently only in a single language-        , rrtyp :: Sign                    -- ^ Allocated type-        , rrdcl :: Maybe (Prop,Declaration)  -- ^ The property, if this rule originates from a property on a Declaration-        , r_env :: String                  -- ^ Name of pattern in which it was defined.-        , r_usr :: RuleOrigin              -- ^ Where does this rule come from?-        , isSignal :: Bool                    -- ^ True if this is a signal; False if it is an invariant-        , srrel :: Declaration             -- ^ the signal relation-        }-instance Eq Rule where-  r==r' = rrnm r==rrnm r'-instance Show Rule where-  showsPrec _ x-   = showString $ "RULE "++ (if null (name x) then "" else name x++": ")++ show (rrexp x)-instance Traced Rule where-  origin = rrfps-instance Identified Rule where-  name   = rrnm-instance Association Rule where-  sign   = rrtyp--data RuleType = Implication | Equivalence | Truth  deriving (Eq,Show)--data Declaration = -  Sgn { decnm :: String     -- ^ the name of the declaration-      , decsgn :: Sign       -- ^ the source and target concepts of the declaration-       --multiplicities returns decprps_calc, when it has been calculated. So if you only need the user defined properties do not use multiplicities but decprps-      , decprps :: [Prop]     -- ^ the user defined multiplicity properties (Uni, Tot, Sur, Inj) and algebraic properties (Sym, Asy, Trn, Rfx)-      , decprps_calc :: Maybe [Prop] -- ^ the calculated and user defined multiplicity properties (Uni, Tot, Sur, Inj) and algebraic properties (Sym, Asy, Trn, Rfx, Irf). Note that calculated properties are made by adl2fspec, so in the A-structure decprps and decprps_calc yield exactly the same answer.-      , decprL :: String     -- ^ three strings, which form the pragma. E.g. if pragma consists of the three strings: "Person ", " is married to person ", and " in Vegas."-      , decprM :: String     -- ^    then a tuple ("Peter","Jane") in the list of links means that Person Peter is married to person Jane in Vegas.-      , decprR :: String-      , decMean :: AMeaning   -- ^ the meaning of a declaration, for each language supported by Ampersand.-      , decfpos :: Origin     -- ^ the position in the Ampersand source file where this declaration is declared. Not all decalartions come from the ampersand souce file. -      , deciss  :: Bool       -- ^ if true, this is a signal relation; otherwise it is an ordinary relation.-      , decusr  :: Bool       -- ^ if true, this relation is declared by an author in the Ampersand script; otherwise it was generated by Ampersand.-      , decpat  :: String     -- ^ the pattern where this declaration has been declared.-      , decplug :: Bool       -- ^ if true, this relation may not be stored in or retrieved from the standard database (it should be gotten from a Plug of some sort instead)-      } | -  Isn -      { detyp :: A_Concept       -- ^ The type-      } |-  Vs -      { decsgn :: Sign-      }--instance Eq Declaration where-  d@Sgn{}     == d'@Sgn{}     = decnm d==decnm d' && decsgn d==decsgn d'-  d@Isn{}     == d'@Isn{}     = detyp d==detyp d'-  d@Vs{}      == d'@Vs{}      = decsgn d==decsgn d'-  _           == _            = False-instance Show Declaration where  -- For debugging purposes only (and fatal messages)-  showsPrec _ decl@Sgn{}-   = showString (case decl of-                  Sgn{} -> name decl++showSign (sign decl)-                  Isn{} -> "I["++show (detyp decl)++"]" -- Isn{} is of type Declaration and it is implicitly defined-                  Vs{}  -> "V"++show (decsgn decl) )--- was:---  = showString (unwords (["RELATION",decnm decl,show (decsgn decl),show (decprps_calc decl)---                         ,"PRAGMA",show (decprL decl),show (decprM decl),show (decprR decl)]---                          ++concatMap showMeaning (ameaMrk (decMean decl))---               )        )---         where ---            showMeaning m = "MEANING"---                           : ["IN", show (amLang m)]---                          ++ [show (amFormat m)]---                          ++ ["{+",aMarkup2String m,"-}"]                ---                          -- then [] else ["MEANING",show (decMean decl)] ))--  showsPrec _ d@Isn{}     = showString $ "Isn{detyp="++show(detyp d)++"}"-  showsPrec _ d@Vs{}      = showString $ "V"++showSign(decsgn d)---aMarkup2String :: A_Markup -> String-aMarkup2String a = blocks2String (amFormat a) False (amPandoc a)--data AMeaning = AMeaning { ameaMrk ::[A_Markup]} deriving Show--instance Identified Declaration where-  name d@Sgn{}   = decnm d-  name Isn{}     = "I"-  name Vs{}      = "V"-instance Association Declaration where-  sign d = case d of-              Sgn {}    -> decsgn d-              Isn {}    -> Sign (detyp d) (detyp d)-              Vs {}     -> decsgn d-instance Traced Declaration where-  origin d = case d of-              Sgn{}     -> decfpos d-              _         -> OriginUnknown--data IdentityDef = Id { idPos :: Origin        -- ^ position of this definition in the text of the Ampersand source file (filename, line number and column number).-                      , idLbl :: String        -- ^ 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-                      , identityAts :: [IdentitySegment]  -- ^ the constituent attributes (i.e. name/expression pairs) of this identity.-                      } deriving (Eq,Show)-instance Identified IdentityDef where-  name = idLbl-instance Traced IdentityDef where-  origin = idPos--data IdentitySegment = IdentityExp ObjectDef deriving (Eq, Show)  -- TODO: refactor to a list of terms--data ViewDef = Vd { vdpos :: Origin         -- ^ position of this definition in the text of the Ampersand source file (filename, line number and column number).-                  , vdlbl :: String         -- ^ the name (or label) of this View. The label has no meaning in the Compliant Service Layer, but is used in the generated user interface. It is not an empty string.-                  , vdcpt :: A_Concept      -- ^ this expression describes the instances of this object, related to their context-                  , vdats :: [ViewSegment]  -- ^ the constituent attributes (i.e. name/expression pairs) of this view.-                  } deriving (Eq,Show)-instance Identified ViewDef where-  name = vdlbl-instance Traced ViewDef where-  origin = vdpos--data ViewSegment = ViewExp ObjectDef | ViewText String | ViewHtml String deriving (Eq, Show)---- | data structure A_Gen contains the CLASSIFY statements from an Ampersand script---   CLASSIFY Employee ISA Person   translates to Isa (C "Person") (C "Employee")---   CLASSIFY Workingstudent IS Employee/\Student   translates to IsE orig (C "Workingstudent") [C "Employee",C "Student"]-data A_Gen = Isa { genspc :: A_Concept      -- ^ specific concept-                 , gengen :: A_Concept      -- ^ generic concept-                 }-           | IsE { genspc :: A_Concept      -- ^ specific concept-                 , genrhs :: [A_Concept]    -- ^ concepts of which the conjunction is equivalent to the specific concept-                 }-instance Show A_Gen where-  -- This show is used in error messages. It should therefore not display the term's type-  showsPrec _ g =-    case g of-     Isa{} -> showString ("CLASSIFY "++show (genspc g)++" ISA "++show (gengen g))-     IsE{} -> showString ("CLASSIFY "++show (genspc g)++" IS "++intercalate " /\\ " (map show (genrhs g)))---- | this function takes all generalisation relations from the context and a concept and delivers a list of all concepts that are more specific than the given concept.---   If there are no cycles in the generalization graph,  cpt  cannot be an element of  smallerConcepts gens cpt.-smallerConcepts :: [A_Gen] -> A_Concept -> [A_Concept]-smallerConcepts gens cpt -  = nub$ oneSmaller ++ concatMap (smallerConcepts gens) oneSmaller -  where oneSmaller = delete cpt. nub $ [ genspc g | g@Isa{}<-gens, gengen g==cpt ]++[ genspc g | g@IsE{}<-gens, cpt `elem` genrhs g ]--- | this function takes all generalisation relations from the context and a concept and delivers a list of all concepts that are more generic than the given concept.-largerConcepts :: [A_Gen] -> A_Concept -> [A_Concept]-largerConcepts gens cpt - = nub$ oneLarger ++ concatMap (largerConcepts gens) oneLarger-  where oneLarger  = delete cpt. nub $[ gengen g | g@Isa{}<-gens, genspc g==cpt ]++[ c | g@IsE{}<-gens, genspc g==cpt, c<-genrhs g ] ---- | this function returns the most generic concepts in the class of a given concept-rootConcepts :: [A_Gen]  -> [A_Concept] -> [A_Concept]-rootConcepts gens cpts = [ root | root<-nub $ [ c | cpt<-cpts, c<-largerConcepts gens cpt ] `uni` cpts-                                , root `notElem` [ genspc g | g@Isa{}<-gens]++[c | g@IsE{}<-gens, c<-genrhs g ]-                                ]--data Interface = Ifc { ifcParams :: [Expression] -- Only primitive expressions are allowed!-                     , ifcArgs ::   [[String]]-                     , ifcRoles ::  [String]-                     , ifcObj ::    ObjectDef -- NOTE: this top-level ObjectDef is contains the interface itself (ie. name and expression)-                     , ifcPos ::    Origin-                     , ifcPrp ::    String-                     } deriving Show-instance Eq Interface where-  s==s' = name s==name s'-instance Identified Interface where-  name = name . ifcObj-instance Traced Interface where-  origin = ifcPos--objAts :: ObjectDef -> [ObjectDef]-objAts obj -  = case objmsub obj of-     Nothing       -> []-     Just (InterfaceRef _) -> []-     Just (Box _ objs)     -> objs--class Object a where- concept :: a -> A_Concept        -- the type of the object- attributes :: a -> [ObjectDef]   -- the objects defined within the object    - contextOf :: a -> Expression     -- the context expression--instance Object ObjectDef where- concept obj = target (objctx obj)- attributes  = objAts- contextOf   = objctx---data ObjectDef = Obj { objnm ::   String         -- ^ 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)-                     , objctx ::  Expression     -- ^ this expression describes the instances of this object, related to their context. -                     , objmsub :: Maybe SubInterface    -- ^ the attributes, which are object definitions themselves.-                     , objstrs :: [[String]]     -- ^ directives that specify the interface.-                     } deriving (Eq, Show)       -- just for debugging (zie ook instance Show ObjectDef)-instance Identified ObjectDef where-  name   = objnm-instance Traced ObjectDef where-  origin = objpos--data SubInterface = Box A_Concept [ObjectDef] | InterfaceRef String deriving (Eq, Show) ---- | Explanation is the intended constructor. It explains the purpose of the object it references.---   The enrichment process of the parser must map the names (from PPurpose) to the actual objects-data Purpose  = Expl { explPos :: Origin     -- ^ The position in the Ampersand script of this purpose definition-                     , explObj :: ExplObj    -- ^ The object that is explained.-                     , explMarkup :: A_Markup   -- ^ This field contains the text of the explanation including language and markup info.-                     , explUserdefd :: Bool       -- ^ Is this purpose defined in the script?-                     , explRefIds :: [String]     -- ^ The references of the explaination-                     } -instance Eq Purpose where-  x0 == x1  =  explObj x0 == explObj x1 && -               (amLang . explMarkup) x0 == (amLang . explMarkup) x1-instance Traced Purpose where-  origin = explPos--data Population -- The user defined populations-  = PRelPopu { popdcl :: Declaration-             , popps ::  Pairs     -- The user-defined pairs that populate the relation-             }-  | PCptPopu { popcpt :: A_Concept-             , popas ::  [String]  -- The user-defined atoms that populate the concept-             } deriving Eq--data ExplObj = ExplConceptDef ConceptDef-             | ExplDeclaration Declaration-             | ExplRule String-             | ExplIdentityDef String-             | ExplViewDef String-             | ExplPattern String-             | ExplProcess String-             | ExplInterface String-             | ExplContext String-          deriving (Show ,Eq)--data Expression-      = EEqu (Expression,Expression)   -- ^ equivalence             =-      | EImp (Expression,Expression)   -- ^ implication             |--      | EIsc (Expression,Expression)   -- ^ intersection            /\-      | EUni (Expression,Expression)   -- ^ union                   \/-      | EDif (Expression,Expression)   -- ^ difference              --      | ELrs (Expression,Expression)   -- ^ left residual           /-      | ERrs (Expression,Expression)   -- ^ right residual          \-      | EDia (Expression,Expression)   -- ^ diamond                 <>-      | ECps (Expression,Expression)   -- ^ composition             ; -      | ERad (Expression,Expression)   -- ^ relative addition       ! -      | EPrd (Expression,Expression)   -- ^ cartesian product       * -      | EKl0 Expression                -- ^ Rfx.Trn closure         *  (Kleene star)-      | EKl1 Expression                -- ^ Transitive closure      +  (Kleene plus)-      | EFlp Expression                -- ^ conversion (flip, wok)  ~-      | ECpl Expression                -- ^ Complement-      | EBrk Expression                -- ^ bracketed expression ( ... )-      | EDcD Declaration               -- ^ simple declaration-      | EDcI A_Concept                 -- ^ Identity relation-      | EEps A_Concept Sign            -- ^ Epsilon relation (introduced by the system to ensure we compare concepts by equality only.-      | EDcV Sign                      -- ^ Cartesian product relation-      | EMp1 String A_Concept          -- ^ constant (string between single quotes)-      deriving (Eq,Show)--(.==.), (.|-.), (./\.), (.\/.), (.-.), (./.), (.\.), (.<>.), (.:.), (.!.), (.*.) :: Expression -> Expression -> Expression--infixl 1 .==.   -- equivalence-infixl 1 .|-.   -- implication-infixl 2 ./\.   -- intersection-infixl 2 .\/.   -- union-infixl 4 .-.    -- difference-infixl 6 ./.    -- left residual-infixl 6 .\.    -- right residual-infixl 6 .<>.   -- diamond-infixl 8 .:.    -- composition    -- .;. was unavailable, because Haskell's scanner does not recognize it as an operator.-infixl 8 .!.    -- relative addition-infixl 8 .*.    -- cartesian product---- SJ 20130118: The fatals are superfluous, but only if the type checker works correctly. Once we have sufficient confidence, they can be removed for performance reasons.-l .==. r = if source l/=source r ||  target l/=target r then fatal 424 ("Cannot equate (with operator \"==\") expression\n   "++show l++"\n   with "++show r++".") else-           EEqu (l,r)-l .|-. r = if source l/=source r ||  target l/=target r then fatal 426 ("Cannot include (with operator \"|-\") expression\n   "++show l++"\n   with "++show r++".") else-           EImp (l,r)-l ./\. r = if source l/=source r ||  target l/=target r then fatal 428 ("Cannot intersect (with operator \"/\\\") expression\n   "++show l++"\n   with "++show r++".") else-           EIsc (l,r)-l .\/. r = if source l/=source r ||  target l/=target r then fatal 430 ("Cannot unite (with operator \"\\/\") expression\n   "++show l++"\n   with "++show r++".") else-           EUni (l,r)-l .-. r  = if source l/=source r ||  target l/=target r then fatal 432 ("Cannot subtract (with operator \"-\") expression\n   "++show l++"\n   with "++show r++".") else-           EDif (l,r)-l ./. r  = if target l/=target r then fatal 434 ("Cannot residuate (with operator \"/\") expression\n   "++show l++"\n   with "++show r++".") else-           ELrs (l,r)-l .\. r  = if source l/=source r then fatal 436 ("Cannot residuate (with operator \"\\\") expression\n   "++show l++"\n   with "++show r++".") else-           ERrs (l,r)-l .<>. r = if source l/=target r then fatal 438 ("Cannot use diamond operator \"<>\") on\n   "++show l++"\n   and "++show r++".") else-           EDia (l,r)-l .:. r  = if source r/=target l then fatal 440 ("Cannot compose (with operator \";\") expression\n   "++show l++"\n   with "++show r++".") else-           ECps (l,r)-l .!. r  = if source r/=target l then fatal 442 ("Cannot add (with operator \"!\") expression\n   "++show l++"\n   with "++show r++".") else-           ERad (l,r)-l .*. r  = -- SJC: always fits! No fatal here..-           EPrd (l,r)-{- For the operators /, \, ;, ! and * we must not check whether the intermediate types exist.-   Suppose the user says GEN Student ISA Person and GEN Employee ISA Person, then Student `join` Employee has a name (i.e. Person), but Student `meet` Employee-   does not. In that case, -(r!s) (with target r=Student and source s=Employee) is defined, but -r;-s is not.-   So in order to let -(r!s) be equal to -r;-s we must not check for the existence of these types, for the Rotterdam paper already shows that this is fine.--}--instance Flippable Expression where-  flp expr = case expr of-               EEqu (l,r) -> EEqu (flp l, flp r)-               EImp (l,r) -> EImp (flp l, flp r)-               EIsc (l,r) -> EIsc (flp l, flp r)-               EUni (l,r) -> EUni (flp l, flp r)-               EDif (l,r) -> EDif (flp l, flp r)-               ELrs (l,r) -> ERrs (flp r, flp l)-               ERrs (l,r) -> ELrs (flp r, flp l)-               EDia (l,r) -> EDia (flp r, flp l)-               ECps (l,r) -> ECps (flp r, flp l)-               ERad (l,r) -> ERad (flp r, flp l)-               EPrd (l,r) -> EPrd (flp r, flp l)-               EFlp e     -> e-               ECpl e     -> ECpl (flp e)-               EKl0 e     -> EKl0 (flp e)-               EKl1 e     -> EKl1 (flp e)-               EBrk f     -> EBrk (flp f)-               EDcD{}     -> EFlp expr -               EDcI{}     -> expr-               EEps i sgn -> EEps i (flp sgn)-               EDcV sgn   -> EDcV (flp sgn)-               EMp1{}     -> expr--instance Association Expression where- sign (EEqu (l,r)) = Sign (source l) (target r)- sign (EImp (l,r)) = Sign (source l) (target r)- sign (EIsc (l,r)) = Sign (source l) (target r)- sign (EUni (l,r)) = Sign (source l) (target r)- sign (EDif (l,r)) = Sign (source l) (target r)- sign (ELrs (l,r)) = Sign (source l) (source r)- sign (ERrs (l,r)) = Sign (target l) (target r)- sign (EDia (l,r)) = Sign (source l) (target r)- sign (ECps (l,r)) = Sign (source l) (target r)- sign (ERad (l,r)) = Sign (source l) (target r)- sign (EPrd (l,r)) = Sign (source l) (target r)- sign (EKl0 e)     = sign e- sign (EKl1 e)     = sign e- sign (EFlp e)     = flp (sign e)- sign (ECpl e)     = sign e- sign (EBrk e)     = sign e- sign (EDcD d)     = sign d- sign (EDcI c)     = Sign c c- sign (EEps _ sgn) = sgn- sign (EDcV sgn)   = sgn- sign (EMp1 _ c)   = Sign c c--showSign :: Association a => a -> String-showSign x = let Sign s t = sign x in "["++name s++"*"++name t++"]"---- The following definition of concept is used in the type checker only.--- It is called Concept, meaning "type checking concept"--data A_Concept-   = PlainConcept { cptnm :: String }  -- ^PlainConcept nm represents the set of instances cs by name nm.-   | ONE  -- ^The universal Singleton: 'I'['Anything'] = 'V'['Anything'*'Anything']--instance Eq A_Concept where-   PlainConcept{cptnm=a} == PlainConcept{cptnm=b} = a==b-   ONE == ONE = True-   _ == _ = False--instance Identified A_Concept where-  name PlainConcept{cptnm = nm} = nm-  name ONE = "ONE"--instance Show A_Concept where-  showsPrec _ c = showString (name c)-   -  -data Sign = Sign A_Concept A_Concept deriving Eq-  --instance Show Sign where-  showsPrec _ (Sign s t) = -     showString (   "[" ++ show s ++ "*" ++ show t ++ "]" )--instance Association Sign where-  source (Sign s _) = s-  target (Sign _ t) = t-  sign sgn = sgn--instance Flippable Sign where- flp (Sign s t) = Sign t s--class Association rel where-  source, target :: rel -> A_Concept      -- e.g. Declaration -> Concept-  source x        = source (sign x)-  target x        = target (sign x)-  sign :: rel -> Sign-  isEndo :: rel  -> Bool-  isEndo s        = source s == target s---{- -  --  a <= b means that concept a is more specific than b and b is more generic than a. For instance 'Elephant' <= 'Animal'-  --  The generalization relation <= between concepts is a partial order.-  --  Partiality reflects the fact that not every pair of concepts of a specification need be related.-  --  Although meets, joins and sorting of all concepts may be meaningless, within classes of comparable concepts it is meaningfull.-  --  See Core.Poset to see how these functions are defined for the meaningfull cases only.-  --  Core.Poset is based and partly copied from http://hackage.haskell.org/package/altfloat-0.3.1 intended to sort floats and more-  --  A partial order is by definition reflexive, antisymmetric, and transitive-  --  For every concept a and b in Ampersand, the following rule holds: a<b || b<a || a==b || a <==> b || a<\=> b-  --  Every concept drags around the same partial order represented by -  --   + a compare function (A_Concept->A_Concept->Ordering) -  --   + and a list of comparable classes [[A_Concept]]--}-type GenR = ( A_Concept -> A_Concept -> Ordering      --  gE: the ordering relation, which yields EQ, LT, GT, CP, or NC-            , [[A_Concept]]                           --  join classes. Each class corresponds to a (scalar, binary or wide) entity later on in the database generator.-            , [(A_Concept,A_Concept)]                 --  the smallest set of pairs that produces the ordering relation gE-            , A_Concept -> A_Concept -> [A_Concept]   --  c `elem` (a `meets` b) means that c<=q and c<=b -            , A_Concept -> A_Concept -> [A_Concept]   --  c `elem` (a `joins` b) means that c>=q and c>=b -            )---{- not used, but may be handy for debugging-showOrder :: A_Concept -> String-showOrder x = "\nComparability classes:"++ind++intercalate ind (map show classes)- where (_,classes,_,_,_) = cptgE x; ind = "\n   "--}
− src/lib/DatabaseDesign/Ampersand/Core/ParseTree.hs 
@@ -1,605 +0,0 @@-{-# OPTIONS_GHC -Wall #-}
-module DatabaseDesign.Ampersand.Core.ParseTree (
-     P_Context(..)
-   , Meta(..)
-   , MetaObj(..)
-   , P_Process(..)
-   , P_RoleRelation(..)
-   , RoleRule(..)
-   , P_Pattern(..)
-   , P_Declaration(..)
-   , Term(..), TermPrim(..)
-   , PairView(..), PairViewSegment(..), PairViewTerm(..), PairViewSegmentTerm(..)
-   , SrcOrTgt(..), isSrc
-   , P_Rule(..)
-   , ConceptDef(..)
-   , P_Population(..)
-   
-   , P_ObjectDef, P_SubInterface, P_Interface(..), P_ObjDef(..), P_SubIfc(..)
-   
-   , P_IdentDef(..) , P_IdentSegment(..)
-   , P_ViewDef , P_ViewSegment
-   , P_ViewD(..) , P_ViewSegmt(..)
-   
-   , PPurpose(..),PRef2Obj(..),PMeaning(..),PMessage(..)
-   
-   , P_Concept(..), P_Sign(..)
-   
-   , P_Gen(..)
-   
-   , Lang(..)
-   , P_Markup(..)
-   
-   , PandocFormat(..)
-   
-   , Label(..)
-   
-   , Prop(..), Props
-   -- Inherited stuff: 
-   , module DatabaseDesign.Ampersand.Input.ADL1.FilePos
-   , module DatabaseDesign.Ampersand.ADL1.Pair
-   , gen_concs
-  )
-where
-   import DatabaseDesign.Ampersand.Input.ADL1.FilePos           
-   import DatabaseDesign.Ampersand.Basics
-   import DatabaseDesign.Ampersand.ADL1.Pair (Pairs,Paire,mkPair ,srcPaire, trgPaire)
-   import Data.Traversable
-   import Data.Foldable
-   import Prelude hiding (foldr, sequence)
-   import Control.Applicative
-
-   fatal :: Int -> String -> a
-   fatal = fatalMsg "Core.ParseTree"
-   
-   data P_Context
-      = PCtx{ ctx_nm ::     String           -- ^ The name of this context
-            , ctx_pos ::    [Origin]         -- ^ The origin of the context. A context can be a merge of a file including other files c.q. a list of Origin.
-            , ctx_lang ::   Maybe Lang       -- ^ The default language specified by this context, if specified at all.
-            , ctx_markup :: Maybe PandocFormat  -- ^ The default markup format for free text in this context
-            , ctx_thms ::   [String]         -- ^ Names of patterns/processes to be printed in the functional specification. (For partial documents.)
-            , ctx_pats ::   [P_Pattern]      -- ^ The patterns defined in this context
-            , ctx_PPrcs ::  [P_Process]      -- ^ The processes as defined by the parser
-            , ctx_rs ::     [(P_Rule TermPrim)]         -- ^ All user defined rules in this context, but outside patterns and outside processes
-            , ctx_ds ::     [P_Declaration]  -- ^ The relations defined in this context, outside the scope of patterns
-            , ctx_cs ::     [ConceptDef]     -- ^ The concept definitions defined in this context, outside the scope of patterns
-            , ctx_ks ::     [P_IdentDef]     -- ^ The identity definitions defined in this context, outside the scope of patterns
-            , ctx_vs ::     [P_ViewDef]      -- ^ The view definitions defined in this context, outside the scope of patterns
-            , ctx_gs ::     [P_Gen]          -- ^ The gen definitions defined in this context, outside the scope of patterns
-            , ctx_ifcs ::   [P_Interface]    -- ^ The interfaces defined in this context, outside the scope of patterns
-            , ctx_ps ::     [PPurpose]       -- ^ The purposes defined in this context, outside the scope of patterns
-            , ctx_pops ::   [P_Population]   -- ^ The populations defined in this context
-            , ctx_sql ::    [P_ObjectDef]    -- ^ user defined sqlplugs, taken from the Ampersand script
-            , ctx_php ::    [P_ObjectDef]    -- ^ user defined phpplugs, taken from the Ampersand script
-            , ctx_metas ::  [Meta]         -- ^ generic meta information (name/value pairs) that can be used for experimenting without having to modify the adl syntax
-            } deriving Show
-   
-   instance Eq P_Context where
-     c1 == c2  =  name c1 == name c2
-   
-   instance Identified 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 { mtPos :: Origin
-                 , mtObj :: MetaObj
-                 , mtName :: String
-                 , mtVal :: String
-                 } deriving (Show)
-   data MetaObj = ContextMeta deriving Show -- for now, we just have meta data for the entire context  
-   
-   -- | A RoleRelation rs means that any role in 'rrRoles rs' may edit any Relation  in  'rrInterfaces rs'
-   data P_RoleRelation
-      = P_RR { rr_Roles :: [String]  -- ^ name of a role
-             , rr_Rels :: [TermPrim] -- ^ Typically: PTrel nm sgn, with nm::String and sgn::P_Sign representing a Relation with type information
-             , rr_Pos :: Origin      -- ^ position in the Ampersand script
-             } deriving (Show)       -- deriving Show is just for debugging
-   instance Eq P_RoleRelation where rr==rr' = origin rr==origin rr'
-   instance Traced P_RoleRelation where
-    origin = rr_Pos
-
-   data P_Process
-      = P_Prc { procNm :: String
-              , procPos :: Origin             -- ^ the start position in the file
-              , procEnd :: Origin             -- ^ the end position in the file
-              , procRules :: [(P_Rule TermPrim)]         -- ^ the rules in this process
-              , procGens :: [P_Gen]           -- ^ the generalizations in this process
-              , procDcls :: [P_Declaration]   -- ^ the relation that are declared in this process
-              , procRRuls :: [RoleRule]       -- ^ The assignment of roles to rules.
-              , procRRels :: [P_RoleRelation] -- ^ The assignment of roles to Relations.
-              , procCds :: [ConceptDef]       -- ^ The concept definitions defined in this process
-              , procIds :: [P_IdentDef]       -- ^ The identity definitions defined in this process
-              , procVds :: [P_ViewDef]        -- ^ The view definitions defined in this process
-              , procXps :: [PPurpose]         -- ^ The purposes of elements defined in this process
-              , procPop :: [P_Population]     -- ^ The populations that are local to this process
-              } deriving Show
-
-   instance Identified P_Process where
-    name = procNm 
-
-   instance Traced P_Process where
-    origin = procPos
-
-    -- | A RoleRule r means that a role called 'mRoles r' must maintain the process rule called 'mRules r'
-   data RoleRule
-      = Maintain
-        { mRoles :: [String]    -- ^ name of a role
-        , mRules :: [String]    -- ^ name of a Rule
-        , mPos :: Origin      -- ^ position in the Ampersand script
-        } deriving (Eq, Show)   -- deriving (Eq, Show) is just for debugging
-
-   instance Traced RoleRule where
-    origin = mPos
-
-   data P_Pattern
-      = P_Pat { pt_nm :: String            -- ^ Name of this pattern
-              , pt_pos :: Origin           -- ^ the starting position in the file in which this pattern was declared.
-              , pt_end :: Origin           -- ^ the end position in the file in which this pattern was declared.
-              , pt_rls :: [(P_Rule TermPrim)]         -- ^ The user defined rules in this pattern
-              , pt_gns :: [P_Gen]          -- ^ The generalizations defined in this pattern
-              , pt_dcs :: [P_Declaration]  -- ^ The relations that are declared in this pattern
-              , pt_rus :: [RoleRule]       -- ^ The assignment of roles to rules.
-              , pt_res :: [P_RoleRelation] -- ^ The assignment of roles to Relations.
-              , pt_cds :: [ConceptDef]     -- ^ The concept definitions defined in this pattern
-              , pt_ids :: [P_IdentDef]     -- ^ The identity definitions defined in this pattern
-              , pt_vds :: [P_ViewDef]      -- ^ The view definitions defined in this pattern
-              , pt_xps :: [PPurpose]       -- ^ The purposes of elements defined in this pattern
-              , pt_pop :: [P_Population]   -- ^ The populations that are local to this pattern
-              }   deriving (Show)       -- for debugging purposes
-
-   instance Identified P_Pattern where
-    name = pt_nm
-
-   instance Traced P_Pattern where
-    origin = pt_pos
-
-   data ConceptDef 
-      = Cd  { cdpos :: Origin   -- ^ The position of this definition in the text of the Ampersand source (filename, line number and column number).
-            , cdcpt :: String   -- ^ The name of the concept for which this is the definition. If there is no such concept, the conceptdefinition is ignored.
-            , cdplug:: Bool     -- ^ Whether the user specifically told Ampersand not to store this concept in the database
-            , cddef :: String   -- ^ The textual definition of this concept.
-            , cdtyp :: String   -- ^ The (SQL) type of this concept.
-            , cdref :: String   -- ^ A label meant to identify the source of the definition. (useful as LaTeX' symbolic reference)
-            , cdfrom:: String   -- ^ The name of the pattern or context in which this concept definition was made
-            }   deriving (Show,Eq)
-
-   instance Traced ConceptDef where
-    origin = cdpos
-   instance Identified ConceptDef where
-    name = cdcpt
-      
-   data P_Declaration = 
-         P_Sgn { dec_nm :: String    -- ^ the name of the declaration
-               , dec_sign :: P_Sign    -- ^ the type. Parser must guarantee it is not empty.
-               , dec_prps :: Props     -- ^ the user defined multiplicity properties (Uni, Tot, Sur, Inj) and algebraic properties (Sym, Asy, Trn, Rfx)
-               , dec_prL :: String    -- ^ three strings, which form the pragma. E.g. if pragma consists of the three strings: "Person ", " is married to person ", and " in Vegas."
-               , dec_prM :: String    -- ^    then a tuple ("Peter","Jane") in the list of links means that Person Peter is married to person Jane in Vegas.
-               , dec_prR :: String
-               , dec_Mean :: [PMeaning]  -- ^ the optional meaning of a declaration, possibly more than one for different languages.
-               , dec_popu :: Pairs     -- ^ the list of tuples, of which the relation consists.
-               , dec_fpos :: Origin    -- ^ the position in the Ampersand source file where this declaration is declared. Not all decalartions come from the ampersand souce file. 
-               , dec_plug :: Bool      -- ^ if true, this relation may not be stored in or retrieved from the standard database (it should be gotten from a Plug of some sort instead)
-               } deriving Show -- for debugging and testing only
-   instance Eq P_Declaration where
-    decl==decl' = origin decl==origin decl'
-   instance Prelude.Ord P_Declaration where
-    decl `compare` decl' = origin decl `compare` origin decl'
-   instance Identified P_Declaration where
-    name = dec_nm
-   instance Traced P_Declaration where
-    origin = dec_fpos
-   
-   data TermPrim
-      = PI Origin                              -- ^ identity element without a type
-                                               --   At parse time, there may be zero or one element in the list of concepts.
-                                               --   Reason: when making eqClasses, the least element of that class is used as a witness of that class
-                                               --   to know whether an eqClass represents a concept, we only look at its witness
-                                               --   By making Pid the first in the data decleration, it becomes the least element for "deriving Ord".
-      | Pid Origin P_Concept                   -- ^ identity element restricted to a type
-      | Patm Origin String (Maybe P_Concept)   -- ^ an atom, possibly with a type
-      | PVee Origin                            -- ^ the complete relation, of which the type is yet to be derived by the type checker.
-      | Pfull Origin P_Concept P_Concept       -- ^ the complete relation, restricted to a type.
-                                               --   At parse time, there may be zero, one or two elements in the list of concepts.
-      | Prel Origin String                     -- ^ we expect expressions in flip-normal form
-      | PTrel Origin String P_Sign             -- ^ type cast expression 
-      deriving Show
-   data Term a
-      = Prim a
-      | Pequ Origin (Term a) (Term a)  -- ^ equivalence             =
-      | Pimp Origin (Term a) (Term a)  -- ^ implication             |-
-      | PIsc Origin (Term a) (Term a)  -- ^ intersection            /\
-      | PUni Origin (Term a) (Term a)  -- ^ union                   \/
-      | PDif Origin (Term a) (Term a)  -- ^ difference              -
-      | PLrs Origin (Term a) (Term a)  -- ^ left residual           /
-      | PRrs Origin (Term a) (Term a)  -- ^ right residual          \
-      | PDia Origin (Term a) (Term a)  -- ^ diamond                 <>
-      | PCps Origin (Term a) (Term a)  -- ^ composition             ;
-      | PRad Origin (Term a) (Term a)  -- ^ relative addition       !
-      | PPrd Origin (Term a) (Term a)  -- ^ cartesian product       *
-      | PKl0 Origin (Term a)           -- ^ Rfx.Trn closure         *  (Kleene star)
-      | PKl1 Origin (Term a)           -- ^ Transitive closure      +  (Kleene plus)
-      | PFlp Origin (Term a)           -- ^ conversion (flip, wok)  ~
-      | PCpl Origin (Term a)           -- ^ Complement
-      | PBrk Origin (Term a)           -- ^ bracketed expression ( ... )
-      deriving (Show) -- deriving Show for debugging purposes
-   instance Functor Term where fmap = fmapDefault
-   instance Foldable Term where foldMap = foldMapDefault
-   instance Traversable Term where
-    traverse f' x
-     = case x of
-       Prim a -> Prim <$> f' a
-       Pequ o a b -> Pequ o <$> (f a) <*> (f b)
-       Pimp o a b -> Pimp o <$> (f a) <*> (f b)
-       PIsc o a b -> PIsc o <$> (f a) <*> (f b)
-       PUni o a b -> PUni o <$> (f a) <*> (f b)
-       PDif o a b -> PDif o <$> (f a) <*> (f b)
-       PLrs o a b -> PLrs o <$> (f a) <*> (f b)
-       PRrs o a b -> PRrs o <$> (f a) <*> (f b)
-       PDia o a b -> PDia o <$> (f a) <*> (f b)
-       PCps o a b -> PCps o <$> (f a) <*> (f b)
-       PRad o a b -> PRad o <$> (f a) <*> (f b)
-       PPrd o a b -> PPrd o <$> (f a) <*> (f b)
-       PKl0 o a   -> PKl0 o <$> (f a)
-       PKl1 o a   -> PKl1 o <$> (f a)
-       PFlp o a   -> PFlp o <$> (f a)
-       PCpl o a   -> PCpl o <$> (f a)
-       PBrk o a   -> PBrk o <$> (f a)
-     where f = traverse f'
-   
-   
-   instance Functor P_SubIfc where fmap = fmapDefault
-   instance Foldable P_SubIfc where foldMap = foldMapDefault
-   instance Traversable P_SubIfc where
-    traverse _ (P_InterfaceRef a b) = pure (P_InterfaceRef a b)
-    traverse f (P_Box b lst) = P_Box b <$> (traverse (traverse f) lst)
-   
-   instance Traced (P_SubIfc a) where
-    origin = si_ori
-   
-   instance Functor P_ObjDef where fmap = fmapDefault
-   instance Foldable P_ObjDef where foldMap = foldMapDefault
-   instance Traversable P_ObjDef where
-    traverse f (P_Obj nm pos ctx msub strs)
-     = (\ctx' msub'->(P_Obj nm pos ctx' msub' strs)) <$>
-        traverse f ctx <*> traverse (traverse f) msub
-   
-   instance Traced TermPrim where
-    origin e = case e of
-      PI orig        -> orig
-      Pid orig _     -> orig
-      Patm orig _ _  -> orig
-      PVee orig      -> orig
-      Pfull orig _ _ -> orig
-      Prel orig _    -> orig
-      PTrel orig _ _ -> orig
-   instance Identified TermPrim where
-    name e = case e of
-      PI _        -> "I"
-      Pid _ _     -> "I"
-      Patm _ s _  -> s
-      PVee _      -> "V"
-      Pfull _ _ _ -> "V"
-      Prel _ r    -> r
-      PTrel _ r _ -> r
-      
-   instance Traced a => Traced (Term a) where
-    origin e = case e of
-      Prim a         -> origin a
-      Pequ orig _ _  -> orig
-      Pimp orig _ _  -> orig
-      PIsc orig _ _  -> orig
-      PUni orig _ _  -> orig
-      PDif orig _ _  -> orig
-      PLrs orig _ _  -> orig
-      PRrs orig _ _  -> orig
-      PDia orig _ _  -> orig
-      PCps orig _ _  -> orig
-      PRad orig _ _  -> orig
-      PPrd orig _ _  -> orig
-      PKl0 orig _    -> orig
-      PKl1 orig _    -> orig
-      PFlp orig _    -> orig
-      PCpl orig _    -> orig
-      PBrk orig _    -> orig
-
-   data SrcOrTgt = Src | Tgt deriving (Show, Eq, Ord)
-   instance Flippable SrcOrTgt where
-     flp Src = Tgt
-     flp Tgt = Src
-   
-   isSrc :: SrcOrTgt -> Bool
-   isSrc Src = True
-   isSrc Tgt = False
-   
-   data PairView a = PairView { ppv_segs :: [PairViewSegment a] } deriving Show
-   data PairViewSegment a = PairViewText String
-                          | PairViewExp SrcOrTgt a
-            deriving Show
-   -- | the newtype to make it possible for a PairView to be disambiguatable: it must be of the form "d a" instead of "d (Term a)"
-   newtype PairViewTerm a = PairViewTerm (PairView (Term a)) 
-   newtype PairViewSegmentTerm a = PairViewSegmentTerm (PairViewSegment (Term a))
-   
-   instance Traversable PairViewSegmentTerm where
-     traverse f (PairViewSegmentTerm x) = PairViewSegmentTerm <$> traverse (traverse f) x
-   instance Functor PairViewSegmentTerm where fmap = fmapDefault
-   instance Foldable PairViewSegmentTerm where foldMap = foldMapDefault
-   instance Traversable PairViewTerm where
-     traverse f (PairViewTerm x) = PairViewTerm <$> traverse (traverse f) x
-   instance Functor PairViewTerm where fmap = fmapDefault
-   instance Foldable PairViewTerm where foldMap = foldMapDefault
-   instance Traversable PairViewSegment where
-     traverse _ (PairViewText s) = pure (PairViewText s)
-     traverse f (PairViewExp st x) = PairViewExp st <$> f x
-   instance Functor PairViewSegment where fmap = fmapDefault
-   instance Foldable PairViewSegment where foldMap = foldMapDefault
-   instance Traversable PairView where
-     traverse f (PairView s) = PairView <$> traverse (traverse f) s
-   instance Functor PairView where fmap = fmapDefault
-   instance Foldable PairView where foldMap = foldMapDefault
-   
-   
-   data P_Rule a  =
-      P_Ru { rr_nm ::   String            -- ^ Name of this rule
-           , rr_exp ::  (Term a)   -- ^ The rule expression 
-           , rr_fps ::  Origin            -- ^ Position in the Ampersand file
-           , rr_mean :: [PMeaning]        -- ^ User-specified meanings, possibly more than one, for multiple languages.
-           , rr_msg ::  [PMessage]        -- ^ User-specified violation messages, possibly more than one, for multiple languages.
-           , rr_viol :: Maybe (PairView (Term a))  -- ^ Custom presentation for violations, currently only in a single language
-           } deriving Show
-
-   instance Traced (P_Rule a) where
-    origin = rr_fps
-   instance Functor P_Rule where fmap = fmapDefault
-   instance Foldable P_Rule where foldMap = foldMapDefault
-   instance Traversable P_Rule where
-    traverse f (P_Ru nm expr fps mean msg viol)
-     = (\e v -> P_Ru nm e fps mean msg v) <$> traverse f expr <*> traverse (traverse (traverse f)) viol
-
-   instance Identified (P_Rule a) where
-    name = rr_nm
-
-   newtype PMeaning = PMeaning P_Markup
-            deriving Show
-   newtype PMessage = PMessage P_Markup
-            deriving Show
-   data P_Markup = 
-       P_Markup  { mLang ::   Maybe Lang
-                 , mFormat :: Maybe PandocFormat
-                 , mString :: String
-                 } deriving Show -- for debugging only     
-               
-   data P_Population
-     = P_RelPopu { p_rnme ::  String  -- the name of a relation
-                 , p_orig ::  Origin  -- the origin 
-                 , p_popps :: Pairs   -- the contents
-                 }
-     | P_TRelPop { p_rnme ::  String  -- the name of a relation
-                 , p_type ::  P_Sign  -- the sign of the relation
-                 , p_orig ::  Origin  -- the origin 
-                 , p_popps :: Pairs   -- the contents
-                 }
-     | P_CptPopu { p_cnme ::  String  -- the name of a concept
-                 , p_orig ::  Origin  -- the origin
-                 , p_popas :: [String]   -- atoms in the initial population of that concept
-                 }
-       deriving Show
-       
-   instance Identified P_Population where
-    name P_RelPopu{p_rnme = nm} = nm
-    name P_TRelPop{p_rnme = nm} = nm
-    name P_CptPopu{p_cnme = nm} = nm
-    
-   instance Traced P_Population where
-    origin = p_orig
-
-   data P_Interface = 
-        P_Ifc { ifc_Name :: String           -- ^ the name of the interface
-              , ifc_Params :: [TermPrim]         -- ^ a list of relations, which are editable within this interface.
-                                             --   either   Prel o nm
-                                             --       or   PTrel o nm sgn
-              , ifc_Args :: [[String]]       -- ^ a list of arguments for code generation.
-              , ifc_Roles :: [String]        -- ^ a list of roles that may use this interface
-              , ifc_Obj :: P_ObjectDef       -- ^ the context expression (mostly: I[c])
-              , ifc_Pos :: Origin
-              , ifc_Prp :: String
-              } deriving Show
-
-   instance Identified P_Interface where
-    name = ifc_Name
-
-   instance Traced P_Interface where
-    origin = ifc_Pos
-   
-   type P_SubInterface = P_SubIfc TermPrim
-   data P_SubIfc a
-                 = P_Box          { si_ori :: Origin
-                                  , si_box :: [P_ObjDef a] }
-                 | P_InterfaceRef { si_ori :: Origin
-                                  , si_str :: String }
-                   deriving (Eq, Show)
-
-   type P_ObjectDef = P_ObjDef TermPrim
-   data P_ObjDef a = 
-        P_Obj { obj_nm :: String         -- ^ 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.
-              , obj_pos :: Origin         -- ^ position of this definition in the text of the Ampersand source file (filename, line number and column number)
-              , obj_ctx :: Term a        -- ^ this expression describes the instances of this object, related to their context. 
-              , obj_msub :: Maybe (P_SubIfc a)  -- ^ the attributes, which are object definitions themselves.
-              , obj_strs :: [[String]]     -- ^ directives that specify the interface.
-              }  deriving (Show)       -- just for debugging (zie ook instance Show ObjectDef)
-   instance Eq (P_ObjDef a) where od==od' = origin od==origin od'
-   instance Identified (P_ObjDef a) where
-    name = obj_nm
-   instance Traced (P_ObjDef a) where
-    origin = obj_pos
-
-   data P_IdentDef =
-            P_Id { ix_pos :: Origin         -- ^ position of this definition in the text of the Ampersand source file (filename, line number and column number).
-                 , ix_lbl :: String         -- ^ 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.
-                 , ix_cpt :: P_Concept      -- ^ this expression describes the instances of this object, related to their context
-                 , ix_ats :: [P_IdentSegment] -- ^ the constituent segments of this identity. TODO: refactor to a list of terms
-                 } deriving (Show)
-   instance Identified P_IdentDef where
-    name = ix_lbl
-   instance Eq P_IdentDef where identity==identity' = origin identity==origin identity'
-
-   instance Traced P_IdentDef where
-    origin = ix_pos
-   
-   data P_IdentSegment 
-                 = P_IdentExp  { ks_obj :: P_ObjectDef }
-                   deriving (Eq, Show)
-   type P_ViewDef = P_ViewD TermPrim
-   data P_ViewD a = 
-            P_Vd { vd_pos :: Origin         -- ^ position of this definition in the text of the Ampersand source file (filename, line number and column number).
-                 , vd_lbl :: String         -- ^ the name (or label) of this View. The label has no meaning in the Compliant Service Layer, but is used in the generated user interface. It is not an empty string.
-                 , vd_cpt :: P_Concept      -- ^ this expression describes the instances of this object, related to their context
-                 , vd_ats :: [P_ViewSegmt a] -- ^ the constituent segments of this view.
-                 } deriving (Show)
-   instance Identified (P_ViewD a) where
-    name = vd_lbl
-   instance Functor P_ViewD where fmap = fmapDefault
-   instance Foldable P_ViewD where foldMap = foldMapDefault
-   instance Traversable P_ViewD where
-    traverse f (P_Vd a b c d) = P_Vd a b c <$> traverse (traverse f) d
-   
-   instance Functor P_ViewSegmt where fmap = fmapDefault
-   instance Foldable P_ViewSegmt where foldMap = foldMapDefault
-   instance Traversable P_ViewSegmt where
-    traverse f (P_ViewExp  a) = P_ViewExp <$> traverse f a
-    traverse _ (P_ViewText a) = pure (P_ViewText a)
-    traverse _ (P_ViewHtml a) = pure (P_ViewHtml a)
-   
-   instance Traced (P_ViewD a) where
-    origin = vd_pos
-   
-   type P_ViewSegment = P_ViewSegmt TermPrim
-   data P_ViewSegmt a 
-                 = P_ViewExp  { vs_obj :: P_ObjDef a }
-                 | P_ViewText { vs_txt :: String }
-                 | P_ViewHtml { vs_htm :: String }
-                   deriving (Eq, Show)
-                  
--- PPurpose is a parse-time constructor. It contains the name of the object it explains.
--- It is a pre-explanation in the sense that it contains a reference to something that is not yet built by the compiler.
---                       Constructor      name          RefID  Explanation
-   data PRef2Obj = PRef2ConceptDef String
-                 | PRef2Declaration TermPrim -- typically PTrel o nm sgn,   with nm::String and sgn::P_Sign
-                                         -- or        Prel o nm; Other terms become fatals
-                 | PRef2Rule String
-                 | PRef2IdentityDef String
-                 | PRef2ViewDef String
-                 | PRef2Pattern String
-                 | PRef2Process String
-                 | PRef2Interface String
-                 | PRef2Context String
-                 | PRef2Fspc String
-                 deriving Show -- only for fatal error messages
-   
-   instance Identified PRef2Obj where
-     name pe = case pe of 
-        PRef2ConceptDef str -> str
-        PRef2Declaration (PTrel _ nm sgn) -> nm++show sgn
-        PRef2Declaration (Prel _ nm) -> nm
-        PRef2Declaration expr -> fatal 362 ("Expression "++show expr++" should never occur in PRef2Declaration")
-        PRef2Rule str -> str
-        PRef2IdentityDef str -> str
-        PRef2ViewDef str -> str
-        PRef2Pattern str -> str
-        PRef2Process str -> str
-        PRef2Interface str -> str
-        PRef2Context str -> str
-        PRef2Fspc str -> str
-
-   data PPurpose = PRef2 { pexPos :: Origin      -- the position in the Ampersand script of this purpose definition
-                         , pexObj :: PRef2Obj    -- the reference to the object whose purpose is explained
-                         , pexMarkup:: P_Markup  -- the piece of text, including markup and language info
-                         , pexRefIDs :: [String] -- the references (for traceability)
-                         } deriving Show
-
-   instance Identified PPurpose where
-    name pe = name (pexObj pe)
-
-   instance Traced PPurpose where
-    origin = pexPos
-
-   data P_Concept
-      = PCpt{ p_cptnm :: String }  -- ^The name of this Concept
-      | P_Singleton 
---      deriving (Eq, Ord)
--- (Sebastiaan 12 feb 2012) P_Concept has been defined Ord, only because we want to maintain sets of concepts in the type checker for quicker lookups.
--- (Sebastiaan 11 okt 2013) Removed this again, I thought it would be more clean to use newtype for this instead
-
-   instance Identified P_Concept where
-    name (PCpt {p_cptnm = nm}) = nm
-    name P_Singleton = "ONE"
-   
-   instance Show P_Concept where
-    showsPrec _ c = showString (name c)
-
-
-   data P_Sign = P_Sign {pSrc :: P_Concept, pTgt :: P_Concept }
-
-   instance Show P_Sign where
-     showsPrec _ sgn = 
-         showString (   "[" ++ show (pSrc sgn)++"*"++show (pTgt sgn) ++ "]" )
-
-   data P_Gen =  P_Cy{ gen_spc :: P_Concept         -- ^ Left hand side concept expression 
-                     , gen_rhs :: [P_Concept]       -- ^ Right hand side concept expression
-                     , gen_fp ::  Origin            -- ^ Position in the Ampersand file
-                     }
-               | PGen{ gen_spc :: P_Concept      -- ^ specific concept
-                     , gen_gen :: P_Concept      -- ^ generic concept
-                     , gen_fp  :: Origin         -- ^ the position of the GEN-rule
-                     }
-   gen_concs :: P_Gen -> [P_Concept]
-   gen_concs (P_Cy {gen_rhs=x}) = x
-   gen_concs (PGen {gen_gen=x,gen_spc=y}) = [x,y]
-      
-   instance Show P_Gen where
-    -- This show is used in error messages.
-    showsPrec _ g = showString ("CLASSIFY "++show (gen_spc g)++" IS "++show (gen_concs g))
-
-   instance Traced P_Gen where
-    origin = gen_fp
-
-   data Lang = Dutch | English deriving (Show, Eq)
-
-   data PandocFormat = HTML | ReST | LaTeX | Markdown deriving (Eq, Show)
-
-   type Props = [Prop]
-
-   data Prop      = Uni          -- ^ univalent
-                  | Inj          -- ^ injective
-                  | Sur          -- ^ surjective
-                  | Tot          -- ^ total
-                  | Sym          -- ^ symmetric
-                  | Asy          -- ^ antisymmetric
-                  | Trn          -- ^ transitive
-                  | Rfx          -- ^ reflexive
-                  | Irf          -- ^ irreflexive
-                    deriving (Eq,Ord)
-   instance Show Prop where
-    showsPrec _ Uni = showString "UNI"
-    showsPrec _ Inj = showString "INJ"
-    showsPrec _ Sur = showString "SUR"
-    showsPrec _ Tot = showString "TOT"
-    showsPrec _ Sym = showString "SYM"
-    showsPrec _ Asy = showString "ASY"
-    showsPrec _ Trn = showString "TRN"
-    showsPrec _ Rfx = showString "RFX"
-    showsPrec _ Irf = showString "IRF"
-
-   instance Flippable Prop where
-    flp Uni = Inj
-    flp Tot = Sur
-    flp Sur = Tot
-    flp Inj = Uni
-    flp x = x
-
-   data Label = Lbl { lblnm :: String
-                    , lblpos :: Origin
-                    , lblstrs :: [[String]]
-                    }
-   instance Eq Label where
-    l==l' = lblnm l==lblnm l'
-

− src/lib/DatabaseDesign/Ampersand/Core/Poset.hs 
@@ -1,136 +0,0 @@-{- COPIED FROM http://hackage.haskell.org/package/altfloat-0.3.1 -}-{-- - Copyright (C) 2009 Nick Bowler.- -- - License BSD2:  2-clause BSD license.  See LICENSE for full terms.- - This is free software: you are free to change and redistribute it.- - There is NO WARRANTY, to the extent permitted by law.- -}---- | Partially ordered data types.  The standard 'Prelude.Ord' class is for--- total orders and therefore not suitable for floating point.  However, we can--- still define meaningful 'max' and 'sortWith functions for these types.------ We define our own 'Ord' class which is intended as a replacement for--- 'Prelude.Ord'.  Should the user wish to take advantage of existing libraries--- which use 'Prelude.Ord', just let Prelude.compare = (totalOrder .) . compare-module DatabaseDesign.Ampersand.Core.Poset (-    Poset(..), Sortable(..), Ordering(..), Ord, comparableClass,greatest,least,maxima,minima,sortWith-) where-import qualified Prelude-import qualified GHC.Exts (sortWith)--import Prelude hiding (Ord(..), Ordering(..))-import DatabaseDesign.Ampersand.Basics-import DatabaseDesign.Ampersand.Core.Poset.Instances-import DatabaseDesign.Ampersand.Core.Poset.Internal hiding (fatal)--import Data.Function-import Data.Monoid--import DatabaseDesign.Ampersand.Basics (eqCl,isc,fatalMsg)-import qualified Data.List as List--fatal :: Int -> String -> a-fatal = fatalMsg "Core.Poset"---- | makePartialOrder makes a partial order containing local partial orders, i.e. comparable classes.---   it makes sense to sort comparable classes.---   example: A and B are in a comparable class---            A and B are not LT, not GT, not EQ => CP---            if you sortBy comparableClass then A and B are considered EQ (comparableClass CP = Prelude.EQ)---   when the comparable classes have a top, then join can be defined on them---   when the comparable classes have a bottom, then meet can be defined on them------   When A_Concept should be a collection of total orders change f a b guard (| or [ a `elem` cl && b `elem` cl | cl <- cls ] = NC)------   examples on data X = A | B | C | D | E | F deriving (Eq,Show):---   [bottom]       (makePartialOrder [(A,B),(C,D),(B,D),(A,C),(D,E),(D,F)]) :: (A <= B /\ C <= B \/ C <= D <= E /\ F <= E \/ F)---   [ringish]      (makePartialOrder [(A,B),(C,D),(B,D),(A,C),(D,E),(D,F),(E,A),(F,A)]) _ _ = LT ---   [ringish]      (makePartialOrder [(A,B),(C,D),(B,D),(A,C),(D,E),(D,F),(E,A)])       F A = GT---                  (makePartialOrder [(A,B),(C,D),(B,D),(A,C),(D,E),(D,F),(E,A)])       _ _ = LT---   [bottom,total] (makePartialOrder [(A,B),(C,D),(B,D),(A,C),(E,F)]) :: ( A <= B /\ C <= B \/ C <= D , E <= F )---   [2x total]     (makePartialOrder [(A,B),(B,C),(C,D),(E,F)]) :: ( A <= B <= C <= D , E <= F )---   [total]        (makePartialOrder [(A,B),(B,C),(C,D),(D,E),(E,F)]) :: ( A <= B <= C <= D <= E <= F )---   [3x total]     (makePartialOrder [(A,B),(B,C),(C,D)]) :: ( A <= B <= C <= D , E , F )---   [partial]      (makePartialOrder [(A,B),(C,D),(B,D),(D,E),(D,F)]) :: ( (A <= B <= D <= E /\ F <= E \/ F) + (C <= D <= E /\ F <= E \/ F) ) ------   a sorted list will have the x left of y for all x and y. x <= y---   like x==y, the intraposition of x and y is without meaning for all x and y. x `compare` y = CP---   for example given a (makePartialOrder [(A,B),(C,D),(B,D),(D,E),(F,C)]):---    + sort  [F,E,D,C,B,A] = [F,C,A,B,D,E]---    + sort  [F,E,D,B,A,C] = [F,A,B,C,D,E]---    + sort  [B,F,E,C,D,A] = [A,B,F,C,D,E]---instance Poset a => Poset (Maybe a) where-    Just x  <= Just y = x <= y-    Nothing <= _      = True-    _       <= _      = False--instance Poset a => Poset [a] where-    compare = (mconcat .) . zipWith compare---- | Sort a list using the default comparison function.-sort :: Sortable a => [a] -> [a]-sort = sortBy compare---- | Apply a function to values before comparing.-comparing :: Poset b => (a -> b) -> a -> a -> Ordering-comparing = on compare---- example where b=A_Concept: sortWith (snd . order , concs fSpec) idCpt (vIndices fSpec)-sortWith :: (Show b,Poset b) => (b -> [[b]], [b]) -> (a -> b) -> [a] -> [a]-sortWith _   _  [] = [] -sortWith (tos,allb) f xs - = let xtos = [ [x | x<-xs, elem (f x) to] --group xs such that each elem of (map f xtos) is a total order-              | to<-(tos . f . head) xs --non-trivial total orders-                    ++ [[b] | b<-allb, not( elem b (concat((tos . f . head) xs))) ] --trivial total orders-              ] -       sortwith = List.sortBy (\x y -> comparableClass(compare (f x) (f y))) --sortwith of Poset, which should be a total order-   in  concat(map sortwith xtos) --sortwith each total order and concat them         ---- | Elements can be arranged into classes of comparable elements, not necessarily a total order---   It makes sense to sort such a class.---   Take for example instance Sortable A_Concept.---   When A_Concept should be a collection of total orders: comparableClass CP = fatal 118 "Elements in totally ordered class, which are not LT, not GT and not EQ."-comparableClass :: Ordering -> Prelude.Ordering-comparableClass LT = Prelude.LT-comparableClass EQ = Prelude.EQ-comparableClass GT = Prelude.GT-comparableClass NC = fatal 123 "Uncomparable elements in comparable class."-comparableClass CP = Prelude.EQ --the position of two comparable concepts is equal---- | If elements are in a total order, then they can be sortedBy totalOrder using the Prelude.Ordering---   When A_Concept should be in a total order with an Anything and Nothing: sortBy f = Data.List.sortBy ((totalOrder .) . f)-totalOrder :: Ordering -> Prelude.Ordering-totalOrder LT = Prelude.LT-totalOrder EQ = Prelude.EQ-totalOrder GT = Prelude.GT-totalOrder NC = fatal 132 "Uncomparable elements in total order."-totalOrder CP = fatal 133 "Uncomparable elements in total order."---- | takes the greatest a of comparables-greatest :: (Show a,Sortable a) => [a] -> a-greatest xs =-  case maxima (List.nub xs) of-    []  -> fatal 138 "there is no greatest"-    [x] -> x-    xs  -> fatal 140 ("there is more than one greatest: "++ show (List.nub xs))--- | takes all a without anything larger-maxima :: Sortable a => [a] -> [a]-maxima [] = fatal 144 "the empty list has no maximum"-maxima xs = [x | x<-List.nub xs,not (or [x < y | y<-List.nub xs])]---- | takes the least a of comparables if there is only one-least :: Sortable a => [a] -> a-least xs =-  case minima (List.nub xs) of-    []  -> fatal 150 "there is no least"-    [x] -> x-    xs  -> fatal 150 "there is more than one least. "--- | takes all a without anything less-minima :: Sortable a => [a] -> [a]-minima [] = fatal 156 "the empty list has no minimum"-minima xs = [x | x<-List.nub xs,not (or [y < x | y<-List.nub xs])]-
− src/lib/DatabaseDesign/Ampersand/Core/Poset/Instances.hs 
@@ -1,57 +0,0 @@-{- COPIED FROM http://hackage.haskell.org/package/altfloat-0.3.1- - Disabled Sortable instances for instances of Prelude.Ord -}-{-- - Copyright (C) 2009-2010 Nick Bowler.- -- - License BSD2:  2-clause BSD license.  See LICENSE for full terms.- - This is free software: you are free to change and redistribute it.- - There is NO WARRANTY, to the extent permitted by law.- -}---- | 'Poset' and 'Sortable' instances for instances of 'Prelude.Ord'-{-# LANGUAGE CPP #-}-module DatabaseDesign.Ampersand.Core.Poset.Instances where--import qualified DatabaseDesign.Ampersand.Core.Poset.Internal as Poset-import DatabaseDesign.Ampersand.Core.Poset.Internal (Poset, Sortable, partialOrder, totalOrder)--import Data.Ratio-import Data.List-import Data.Word-import Data.Int--#define POSET_ORD_INSTANCE(ctx, v) instance ctx Poset (v) where { \-    compare = (partialOrder .) . compare; \-    (<)     = (<); \-    (<=)    = (<=); \-    (>=)    = (>=); \-    (>)     = (>); \-    (<==>)  = const $ const True; \-    (</=>)  = const $ const False }--#define SORTABLE_ORD_INSTANCE(ctx, v) instance ctx Sortable (v) where { \-    isOrdered = const True; \-    sortBy f = sortBy $ (totalOrder .) . f; \-    max    = max; \-    min    = min; }--#define ORD_INSTANCE(ctx, v) \-    POSET_ORD_INSTANCE(ctx, v); \- {- SORTABLE_ORD_INSTANCE(ctx, v); -} \-    instance ctx Poset.Ord (v)--ORD_INSTANCE(, Bool)-ORD_INSTANCE(, Char)-ORD_INSTANCE(, Int)-ORD_INSTANCE(, Int8)-ORD_INSTANCE(, Int16)-ORD_INSTANCE(, Int32)-ORD_INSTANCE(, Int64)-ORD_INSTANCE(, Word)-ORD_INSTANCE(, Word8)-ORD_INSTANCE(, Word16)-ORD_INSTANCE(, Word32)-ORD_INSTANCE(, Word64)-ORD_INSTANCE(, Integer)--ORD_INSTANCE(Integral a =>, Ratio a)
− src/lib/DatabaseDesign/Ampersand/Core/Poset/Internal.hs 
@@ -1,115 +0,0 @@-{- Based on http://hackage.haskell.org/package/altfloat-0.3.1  -}-{-- - Copyright (C) 2009-2010 Nick Bowler.- -- - License BSD2:  2-clause BSD license.  See LICENSE for full terms.- - This is free software: you are free to change and redistribute it.- - There is NO WARRANTY, to the extent permitted by law.- -}--{-# LANGUAGE FlexibleInstances, OverlappingInstances, UndecidableInstances #-}-module DatabaseDesign.Ampersand.Core.Poset.Internal where--import qualified Data.List as List-import qualified Prelude-import Prelude hiding (Ordering(..), Ord(..))-import Data.Monoid-import DatabaseDesign.Ampersand.Basics (fatalMsg)-fatal :: Int -> String -> a-fatal = fatalMsg "Core.Poset.Internal"---data Ordering = LT | EQ | GT | CP | NC-    deriving (Eq, Show, Read, Bounded, Enum)---- Lexicographic ordering.-instance Monoid Ordering where-    mempty = EQ-    mappend EQ x = x-    mappend NC _ = NC-    mappend LT _ = LT-    mappend GT _ = GT-    mappend CP _ = NC---- | Internal-use function to convert our Ordering to the ordinary one.-totalOrder :: Ordering -> Prelude.Ordering-totalOrder LT = Prelude.LT-totalOrder EQ = Prelude.EQ-totalOrder GT = Prelude.GT-totalOrder NC = fatal 36 "Uncomparable elements in total order."-totalOrder CP = fatal 37 "Uncomparable elements in total order."---- | Internal-use function to convert the ordinary Ordering to ours.-partialOrder :: Prelude.Ordering -> Ordering-partialOrder Prelude.LT = LT-partialOrder Prelude.EQ = EQ-partialOrder Prelude.GT = GT---- | Class for partially ordered data types.  Instances should satisfy the--- following laws for all values a, b and c:------ * @a <= a@.------ * @a <= b@ and @b <= a@ implies @a == b@.------ * @a <= b@ and @b <= c@ implies @a <= c@.------ But note that the floating point instances don't satisfy the first rule.------ Minimal complete definition: 'compare' or '<='.-class Eq a => Poset a where-    compare :: a -> a -> Ordering-    -- | Is comparable to.-    (<==>) :: a -> a -> Bool-    -- | Is not comparable to.-    (</=>) :: a -> a -> Bool-    (<) :: a -> a -> Bool-    (<=) :: a -> a -> Bool-    (>=) :: a -> a -> Bool-    (>) :: a -> a -> Bool--    a `compare` b-        | a == b = EQ-        | a <= b && b <= a = EQ-        | a <= b = LT-        | b <= a = GT-        | otherwise = NC--    a <    b = a `compare` b == LT-    a >    b = a `compare` b == GT-    a <==> b = a `compare` b /= NC-    a </=> b = a `compare` b == NC-    a <=   b = a < b || a `compare` b == EQ-    a >=   b = a > b || a `compare` b == EQ---- | Class for partially ordered data types where sorting makes sense.--- This includes all totally ordered sets and floating point types.  Instances--- should satisfy the following laws:------ * The set of elements for which 'isOrdered' returns true is totally ordered.------ * The max (or min) of an insignificant element and a significant element--- is the significant one.------ * The result of sorting a list should contain only significant elements.------ * @max a b@ = @max b a@------ * @min a b@ = @min b a@------ The idea comes from floating point types, where non-comparable elements--- (NaNs) are the exception rather than the rule.  For these types, we can--- define 'max', 'min' and 'sortBy' to ignore insignificant elements.  Thus, a--- sort of floating point values will discard all NaNs and order the remaining--- elements.------ Minimal complete definition: 'isOrdered'-class Poset a => Sortable a where-    sortBy :: (a -> a -> Ordering) -> [a] -> [a]-    join :: a -> a -> a-    meet :: a -> a -> a---- | Class for totally ordered data types.  Instances should satisfy--- @isOrdered a = True@ for all @a@.-class Poset a => Ord a-
− src/lib/DatabaseDesign/Ampersand/Fspec.hs 
@@ -1,28 +0,0 @@-{-# OPTIONS_GHC -Wall #-}
-module DatabaseDesign.Ampersand.Fspec (module X) where
-import DatabaseDesign.Ampersand.Fspec.Fspec as X 
-       (Fspc(..), concDefs, FProcess(..), ECArule(..), plugFields, lookupCpt, metaValues)
-import DatabaseDesign.Ampersand.Fspec.Plug as X
-       (PlugInfo(..), PlugSQL(..), SqlField(..), SqlFieldUsage(..), SqlType(..), tblcontents,
-        requiredFields, requires, plugpath, Plugable(..),
-        showSQL, fldauto, isPlugIndex)
-import DatabaseDesign.Ampersand.Fspec.ShowHS as X
-       (ShowHS(..), ShowHSName(..), fSpec2Haskell, haskellIdentifier)
-import DatabaseDesign.Ampersand.Fspec.ShowADL as X (ShowADL(..), LanguageDependent(..))
-import DatabaseDesign.Ampersand.Fspec.ShowECA as X (showECA)
-import DatabaseDesign.Ampersand.Fspec.ShowMeatGrinder as X (meatGrinder)
-import DatabaseDesign.Ampersand.Fspec.Graphic.ClassDiagram as X
-       (clAnalysis, cdAnalysis, ClassDiag(..))
-import DatabaseDesign.Ampersand.Fspec.Graphic.Graphics as X
-       (makePicture,writePicture,Picture(..), PictureReq(..),imagePath)
-import DatabaseDesign.Ampersand.Fspec.ToFspec.Calc as X
-       (deriveProofs,showProof,showPrf)
-import DatabaseDesign.Ampersand.Fspec.ToFspec.ADL2Fspec as X
-       (makeFspec)
-import DatabaseDesign.Ampersand.Fspec.ToFspec.NormalForms as X
-       (conjNF, disjNF, cfProof, simplify)
-import DatabaseDesign.Ampersand.Fspec.FPA as X
-       ( fPoints)
-import DatabaseDesign.Ampersand.Fspec.Motivations as X
-       (Meaning(..),Motivated(..))
-       
− src/lib/DatabaseDesign/Ampersand/Fspec/FPA.hs 
@@ -1,100 +0,0 @@-{-# OPTIONS_GHC -Wall #-}
-module DatabaseDesign.Ampersand.Fspec.FPA 
-    (FPAble(..)
-    )
-where
-   
-import DatabaseDesign.Ampersand.Misc (Lang(..))
-import DatabaseDesign.Ampersand.Core.AbstractSyntaxTree
-import DatabaseDesign.Ampersand.Fspec.Fspec
-import DatabaseDesign.Ampersand.Classes
-import DatabaseDesign.Ampersand.Basics
-
-fatal :: Int -> String -> a
-fatal = fatalMsg "Fspec.ToFspec.Calc"
-
-
-class FPAble a where
-  fpa :: a->FPA
-  fPoints :: a ->Int
-  fPoints x = fPoints'(fpa x)
-  showFPA :: Lang -> a -> String
-  showFPA l x = showLang l (fpa x)
-   
-instance FPAble PlugSQL where
-  fpa x = FPA 
-    ILGV -- It is assumed that all persistent storage of information is done withing the scope of the system.
-    $
-    case x of
-      TblSQL{}    | (length.fields) x < 2 -> Eenvoudig
-                  | (length.fields) x < 6 -> Gemiddeld
-                  | otherwise             -> Moeilijk 
-      BinSQL{}    -> Gemiddeld
-      ScalarSQL{} -> Eenvoudig  
-
-instance FPAble Interface where
-  fpa x 
-     | (not.null.ifcParams) x  = FPA IF complxy  -- In case there are editeble relations, this must be an import function. 
-     | (isUni.objctx.ifcObj) x = FPA OF complxy  -- If there is max one atom, this is a simple function. 
-     | otherwise               = FPA UF complxy  -- Otherwise, it is a UF
-   
-    where 
-      complxy = case depth (ifcObj x) of
-                   0 -> Eenvoudig
-                   1 -> Eenvoudig
-                   2 -> Gemiddeld
-                   _ -> Moeilijk 
-      depth :: ObjectDef -> Int
-      depth Obj{objmsub=Nothing} = 0
-      depth Obj{objmsub=Just si}
-         = case si of
-             Box _ os       -> 1 + maximum (map depth os) 
-             InterfaceRef{} -> 1
-
-instance FPAble PlugInfo where
-  fpa (InternalPlug _) = fatal 55 "FPA analysis of internal plugs is currently not supported"
-  fpa (ExternalPlug _)  = fatal 56 "FPA analysis of external plugs is currently not supported"
-
-class ShowLang a where
-  showLang :: Lang -> a -> String
-
-instance ShowLang FPcompl where
- showLang Dutch Eenvoudig   = "Eenvoudig"
- showLang Dutch Gemiddeld   = "Gemiddeld"
- showLang Dutch Moeilijk    = "Moeilijk"
- showLang English Eenvoudig = "Low"
- showLang English Gemiddeld = "Average"
- showLang English Moeilijk  = "High"
-
-instance ShowLang FPtype where
- showLang Dutch t = show t
- showLang English ILGV = "ILF" -- Internal Logical File
- showLang English KGV  = "ELF" -- External Logical File
- showLang English IF   = "EI"  -- External Input
- showLang English UF   = "EO"  -- External Output
- showLang English OF   = "EQ"  -- External inQuiry
- 
-instance ShowLang FPA where
- showLang lang x = showLang lang (fpType x)++" "++showLang lang (complexity x)
-                  
- 
-
--- | Valuing of function points according to par. 3.9 (UK) or par. 2.9 (NL) 
-fPoints' :: FPA -> Int
-fPoints' (FPA ILGV Eenvoudig) = 7
-fPoints' (FPA ILGV Gemiddeld) = 10
-fPoints' (FPA ILGV Moeilijk ) = 15
-fPoints' (FPA KGV  Eenvoudig) = 5
-fPoints' (FPA KGV  Gemiddeld) = 7
-fPoints' (FPA KGV  Moeilijk ) = 10
-fPoints' (FPA IF   Eenvoudig) = 3
-fPoints' (FPA IF   Gemiddeld) = 4
-fPoints' (FPA IF   Moeilijk ) = 6
-fPoints' (FPA UF   Eenvoudig) = 4
-fPoints' (FPA UF   Gemiddeld) = 5
-fPoints' (FPA UF   Moeilijk ) = 7
-fPoints' (FPA OF   Eenvoudig) = 3
-fPoints' (FPA OF   Gemiddeld) = 4
-fPoints' (FPA OF   Moeilijk ) = 6
-   
-

− src/lib/DatabaseDesign/Ampersand/Fspec/Fspec.hs 
@@ -1,443 +0,0 @@-{-# OPTIONS_GHC -Wall #-}
-{- | The intentions behind Fspc (SJ 30 dec 2008):
-Generation of functional specifications is the core functionality of Ampersand.
-All items in a specification are generated into the following data structure, Fspc.
-It is built by compiling an Ampersand script and translating that to Fspc.
-In the future, other ways of 'filling' Fspc are foreseen.
-All generators (such as the code generator, the proof generator, the atlas generator, etc.)
-are merely different ways to show Fspc.
--}
-module DatabaseDesign.Ampersand.Fspec.Fspec 
-          ( Fspc(..), concDefs, Atom(..)
-          , Fswitchboard(..),  Clauses(..), Quad(..)
-          , FSid(..), FProcess(..)
-          , InsDel(..)
-          , ECArule(..)
-          , Event(..)
-          , PAclause(..)
-          , Activity(..)
-          , PlugSQL(..),plugFields
-          , lookupCpt
-          , metaValues
-          , SqlField(..)
-          , Object(..)
-          , FPA(..)
-          , FPtype(..)
-          , FPcompl(..)
-          , PlugInfo(..)
-          , SqlType(..)
-          , SqlFieldUsage(..)
-          , getGeneralizations, getSpecializations
-          , RuleClause(..),DnfClause(..), dnf2expr
-          )
-where
-import DatabaseDesign.Ampersand.Core.AbstractSyntaxTree
-import DatabaseDesign.Ampersand.Classes
-import DatabaseDesign.Ampersand.Basics
-import DatabaseDesign.Ampersand.ADL1.Pair
-import DatabaseDesign.Ampersand.ADL1.Expression (notCpl)
---import Debug.Trace
-
-fatal :: Int -> String -> a
-fatal = fatalMsg "Fspec.Fspec"
-
-data Fspc = Fspc { fsName ::       String                   -- ^ The name of the specification, taken from the Ampersand script
-                 , fspos ::        [Origin]                 -- ^ The origin of the Fspc. An Fspc can be a merge of a file including other files c.q. a list of Origin.
-                 , themes ::       [String]                 -- ^ The names of patterns/processes to be printed in the functional specification. (for making partial documentation)
-                   , pattsInScope :: [Pattern]
-                   , procsInScope :: [Process]
-                   , rulesInScope :: [Rule]
-                   , declsInScope :: [Declaration]
-                   , concsInScope :: [A_Concept]
-                   , cDefsInScope :: [ConceptDef]
-                   , gensInScope  :: [A_Gen]
-                 , fsLang ::       Lang                     -- ^ The default language for this specification (always specified, so no Maybe here!).
-                 , vprocesses ::   [FProcess]               -- ^ All processes defined in the Ampersand script
-                 , vplugInfos ::   [PlugInfo]               -- ^ All plugs defined in the Ampersand script
-                 , plugInfos ::    [PlugInfo]               -- ^ All plugs (defined and derived)
-                 , interfaceS ::   [Interface]              -- ^ All interfaces defined in the Ampersand script
-                 , interfaceG ::   [Interface]              -- ^ All interfaces derived from the basic ontology (the Lonneker interface)
-                 , fSwitchboard :: Fswitchboard             -- ^ The code to be executed to maintain the truth of invariants
-                 , fActivities ::  [Activity]               -- ^ generated: One Activity for every ObjectDef in interfaceG and interfaceS 
-                 , fRoleRels ::    [(String,Declaration)]   -- ^ the relation saying which roles may change the population of which relation.
-                 , fRoleRuls ::    [(String,Rule)]          -- ^ the relation saying which roles may change the population of which relation.
-                 , fRoles ::       [String]                 -- ^ All roles mentioned in this context.
-                 , vrules ::       [Rule]                   -- ^ All user defined rules that apply in the entire Fspc
-                 , grules ::       [Rule]                   -- ^ All rules that are generated: multiplicity rules and identity rules
-                 , invars ::       [Rule]                   -- ^ All invariant rules
-                 , allRules::      [Rule]                   -- ^ All rules, both generated (from multiplicity and keys) as well as user defined ones.
-                 , allUsedDecls :: [Declaration]            -- ^ All relations that are used in the fSpec
-                 , allDecls ::     [Declaration]            -- ^ All relations that are declared in the fSpec
-                 , vrels ::        [Declaration]            -- ^ All user defined and generated relations plus all defined and computed totals.
-                                                            --   The generated relations are all generalizations and
-                                                            --   one declaration for each signal.
-                 , allConcepts ::  [A_Concept]              -- ^ All concepts in the fSpec
-                 , kernels ::      [[A_Concept]]            -- ^ All concepts, grouped by their classifications
-                 , vIndices ::     [IdentityDef]            -- ^ All keys that apply in the entire Fspc
-                 , vviews ::       [ViewDef]                -- ^ All views that apply in the entire Fspc
-                 , vgens ::        [A_Gen]                  -- ^ All gens that apply in the entire Fspc
-                 , vconjs ::       [RuleClause]             -- ^ All conjuncts generated (by ADL2Fspec)
-                 , vquads ::       [Quad]                   -- ^ All quads generated (by ADL2Fspec)
-                 , vEcas ::        [ECArule]                -- ^ All ECA rules generated (by ADL2Fspec)
-                 , fsisa ::        [(A_Concept, A_Concept)] -- ^ generated: The data structure containing the generalization structure of concepts
-                 , vpatterns ::    [Pattern]                -- ^ All patterns taken from the Ampersand script
-                 , conceptDefs ::  [ConceptDef]             -- ^ All concept definitions defined throughout a context, including those inside patterns and processes
-                 , fSexpls ::      [Purpose]                -- ^ All purposes that have been declared at the top level of the current specification, but not in the processes, patterns and interfaces.
-                 , metas ::        [Meta]                   -- ^ All meta relations from the entire context      
-                 , initialPops ::  [Population]             -- all user defined populations of relations and concepts
-                 , allViolations :: [(Rule,[Paire])]        -- all rules with violations.
-                 }
-metaValues :: String -> Fspc -> [String]
-metaValues key fSpec = [mtVal m | m <-metas fSpec, mtName m == key]
-
-data Atom = Atom { atmRoot :: A_Concept -- The root concept of the atom. (this implies that there can only be a single root for
-                 , atmVal :: String
-                 } deriving Eq
-
-concDefs :: Fspc -> A_Concept -> [ConceptDef]
-concDefs fSpec c = [ cdef | cdef<-conceptDefs fSpec, name cdef==name c ]
-
-instance ConceptStructure Fspc where
-  concs     fSpec = allConcepts fSpec                     -- The set of all concepts used in this Fspc
-  expressionsIn fSpec = foldr (uni) []
-                        [ (expressionsIn.interfaceS) fSpec
-                        , (expressionsIn.vrules) fSpec
-                        , (expressionsIn.vviews) fSpec
-                        , (expressionsIn.vIndices) fSpec
-                        ]
-  mp1Exprs  _ = fatal 77 "do not use mp1Exprs from an Fspc"
-  
-instance Language Fspc where
-  objectdef    fSpec = Obj { objnm   = name fSpec
-                           , objpos  = Origin "generated object by objectdef (Language Fspc)"
-                           , objctx  = EDcI ONE
-                           , objmsub = Just . Box ONE $ map ifcObj (interfaceS fSpec ++ interfaceG fSpec)
-                           , objstrs = []
-                           }
-   --REMARK: in the fSpec we do not distinguish between the disjoint relation declarations and rule declarations (yet?). 
-  relsDefdIn = vrels
-  udefrules  = vrules -- only user defined rules
-  invariants = invars
-  identities = vIndices
-  viewDefs   = vviews
-  gens       = vgens
-  patterns   = vpatterns
-
-data FProcess
-  = FProc { fpProc :: Process
-          , fpActivities :: [Activity]
-          }  
-instance Identified FProcess where
-  name = name . fpProc 
-
-instance Language FProcess where
-  objectdef  = objectdef.fpProc
-  relsDefdIn = relsDefdIn.fpProc
-  udefrules  = udefrules.fpProc
-  invariants = invariants.fpProc
-  identities = identities.fpProc
-  viewDefs   = viewDefs.fpProc
-  gens       = gens.fpProc
-  patterns   = patterns.fpProc
-
--- | A list of ECA rules, which is used for automated functionality.
-data Fswitchboard
-  = Fswtch { fsbEvIn :: [Event]
-           , fsbEvOut :: [Event]
-           , fsbConjs :: [(Rule, Expression)]
-           , fsbECAs :: [ECArule]
-           }
-
-    
---type Fields = [Field]
---data Field  = Att { fld_name :: String        -- The name of this field
---                  , fld_sub :: Fields        -- all sub-fields
---                  , fld_expr :: Expression    -- The expression by which this field is attached to the interface
---                  , fld_rel :: Relation      -- The relation to which the database table is attached.
---                  , fld_editable :: Bool          -- can this field be changed by the user of this interface?
---                  , fld_list :: Bool          -- can there be multiple values in this field?
---                  , fld_must :: Bool          -- is this field obligatory?
---                  , fld_new :: Bool          -- can new elements be filled in? (if no, only existing elements can be selected)
---                  , fld_sLevel :: Int           -- The (recursive) depth of the current servlet wrt the entire interface. This is used for documentation.
---                  , fld_insAble :: Bool          -- can the user insert in this field?
---                  , fld_onIns :: ECArule       -- the PAclause to be executed after an insert on this field
---                  , fld_delAble :: Bool          -- can the user delete this field?
---                  , fld_onDel :: ECArule       -- the PAclause to be executed after a delete on this field
---                  } 
-   
-
-{- from http://www.w3.org/TR/wsdl20/#InterfaceOperation
- - "The properties of the Interface Operation component are as follows:
- - ...
- - * {interface message references} OPTIONAL. A set of Interface Message Reference components for the ordinary messages the operation accepts or sends.
- - ..."
--}
-   
-data FSid = FS_id String     -- Identifiers in the Functional Specification Language contain strings that do not contain any spaces.
-        --  | NoName           -- some identified objects have no name...
-instance Identified Fspc where
-  name = fsName
-
-
-instance Identified FSid where
-  name (FS_id nm) = nm
-
-
-data Activity = Act { actRule ::   Rule
-                    , actTrig ::   [Declaration]
-                    , actAffect :: [Declaration]
-                    , actQuads ::  [Quad]
-                    , actEcas ::   [ECArule]
-                    , actPurp ::   [Purpose]
-                    }
-instance Identified Activity where
-  name act = name (actRule act)
--- | A Quad is used in the "switchboard" of rules. It represents a "proto-rule" with the following meaning:
---   whenever qRel is affected (i.e. tuples in qRel are inserted or deleted), qRule may have to be restored using functionality from qClauses.
---   The rule is taken along for traceability.
-       
-instance ConceptStructure Activity where
- concs         act = concs (actRule act) `uni` concs (actAffect act)
- expressionsIn act = expressionsIn (actRule act)
-
-data Quad
-     = Quad
-          { qDcl :: Declaration   -- The relation that, when affected, triggers a restore action.
-          , qClauses :: Clauses   -- The clauses
-          } deriving (Eq, Show)
- 
-instance Eq Activity where
-  a == a'  = actRule a == actRule a'
-
-data InsDel   = Ins | Del
-                 deriving (Show,Eq)
-data ECArule= ECA { ecaTriggr :: Event       -- The event on which this rule is activated
-                  , ecaDelta :: Declaration  -- The delta to be inserted or deleted from this rule. It actually serves very much like a formal parameter.
-                  , ecaAction :: PAclause    -- The action to be taken when triggered.
-                  , ecaNum :: Int            -- A unique number that identifies the ECArule within its scope.
-                  }
-instance Eq (ECArule) where
-   e==e' = ecaNum e==ecaNum e'
-   
-data Event = On { eSrt :: InsDel
-                , eDcl :: Declaration
-                } deriving (Show,Eq)
-
-data PAclause
-              = CHC { paCls :: [PAclause]                 -- precisely one clause is executed.
-                    , paMotiv :: [(Expression,[Rule] )]   -- tells which conjunct from which rule is being maintained
-                    }
-              | GCH { paGCls :: [(InsDel,Expression,PAclause)]    -- guarded choice; The rule is maintained if one of the clauses of which the expression is populated is executed.
-                    , paMotiv :: [(Expression,[Rule] )]   -- tells which conjunct from which rule is being maintained
-                    }
-              | ALL { paCls :: [PAclause]                 -- all clauses are executed.
-                    , paMotiv :: [(Expression,[Rule] )]
-                    }
-              | Do  { paSrt :: InsDel                     -- do Insert or Delete
-                    , paTo :: Declaration                 -- into toExpr    or from toExpr
-                    , paDelta :: Expression               -- delta
-                    , paMotiv :: [(Expression,[Rule] )]
-                    }
-              | New { paCpt :: A_Concept                  -- make a new instance of type c
-                    , paCl :: String->PAclause            -- to be done after creating the concept
-                    , paMotiv :: [(Expression,[Rule] )]
-                    }
-              | Rmv { paCpt :: A_Concept                  -- Remove an instance of type c
-                    , paCl :: String->PAclause            -- to be done afteremoving the concept
-                    , paMotiv :: [(Expression,[Rule] )]
-                    }
-              | Nop { paMotiv :: [(Expression,[Rule] )]   -- tells which conjunct from whichule is being maintained
-                    }
-              | Blk { paMotiv :: [(Expression,[Rule] )]   -- tells which expression from whichule has caused the blockage
-                    }
-              | Let { paExpr :: PAclause                  -- the expression that represents a condition to be tested.
-                    , paBody :: PAclause -> PAclause
-                    , paMotiv :: [(Expression,[Rule] )]
-                    }
-              | Ref { paVar :: String
-                    }
-
-   -- The data structure Clauses is meant for calculation purposes.
-   -- It must always satisfy for every i<length (cl_rule cl): cl_rule cl is equivalent to EIsc [EUni disj | (conj, dnfClauses)<-cl_conjNF cl, disj<-[conj!!i]]
-   -- Every rule is transformed to this form, as a step to derive eca-rules
-instance Eq PAclause where
-   CHC ds _ == CHC ds' _ = ds==ds'
-   GCH ds _ == GCH ds' _ = ds==ds'
-   ALL ds _ == ALL ds' _ = ds==ds'
-   p@Do{}   ==   p'@Do{} = paSrt p==paSrt p' && paTo p==paTo p' && paDelta p==paDelta p'
-   Nop _    ==     Nop _ = True
-   p@New{}  ==  p'@New{} = paCpt p==paCpt p'
-   p@Rmv{}  ==  p'@Rmv{} = paCpt p==paCpt p'
-   _ == _ = False
-
-
-data DnfClause = Dnf [Expression] [Expression] deriving (Show, Eq) -- Show is for debugging purposes only.
-
---
-dnf2expr :: DnfClause -> Expression
-dnf2expr (Dnf antcs conss)
- = case (antcs, conss) of
-    ([],[]) -> fatal 327 "empty dnf clause"
-    ([],_ ) -> foldr1 (.\/.) conss
-    (_ ,[]) -> notCpl (foldr1 (./\.) antcs)
-    (_ ,_ ) -> notCpl (foldr1 (./\.) antcs) .\/. (foldr1 (.\/.) conss)
-
-data Clauses  = Clauses
-                  { cl_conjNF :: [RuleClause]   -- The list of pairs (conj, dnfClauses) in which conj is a conjunct of the rule
-                                                    -- and dnfClauses contains all derived expressions to be used for eca-rule construction.
-                  , cl_rule :: Rule -- The rule that is restored by this clause (for traceability purposes)
-                  } deriving Show
-data RuleClause = RC { rc_int        :: Int  -- the index number of the expression for the rule. (must be unique for the rule)
-                     , rc_rulename   :: String -- the name of the rule
-                     , rc_conjunct   :: Expression
-                     , rc_dnfClauses :: [DnfClause]
-                     } deriving Show
-instance Eq Clauses where
-  cl==cl' = cl_rule cl==cl_rule cl'
-
-{-
-   showClauses :: Fspc -> Clauses -> String
-   showClauses _ cl
-    = "\nRule: "++showADL (cl_rule cl) ++concat
-       [if null dnfClauses then "\nNo clauses" else
-        "\nConjunct: "++showADL conj++
-        concat ["\n   Clause: "++showADL clause | clause<-dnfClauses]
-       | (conj, dnfClauses)<-cl_conjNF cl]
--}
-
-data FPA = FPA { fpType :: FPtype
-               , complexity :: FPcompl
-               } deriving (Show)
-
--- | These types are defined bij Nesma. See http://www.nesma.nl/sectie/fpa/hoefpa.asp
-data FPtype 
- = ILGV -- ^ bevat permanente, voor de gebruiker relevante gegevens. De gegevens worden door het systeem gebruikt en onderhouden. Onder "onderhouden" verstaat FPA het toevoegen, wijzigen of verwijderen van gegevens.
- | KGV  -- ^ bevat permanente, voor de gebruiker relevante gegevens. Deze gegevens worden door het systeem gebruikt, maar worden door een ander systeem onderhouden (voor dat andere systeem is het dus een ILGV).
- | IF   -- ^ verwerkt gegevens in een ILGV van het systeem. (dus create, update en delete functies)
- | UF   -- ^ presenteert gegevens uit het systeem. Voorbeelden: het afdrukken van alle debiteuren; het aanmaken van facturen; het aanmaken van een diskette met betalingsopdrachten; het medium is hierbij niet van belang: papier, scherm, magneetband, datacom, enzovoorts.
- | OF   -- ^ is een speciaal (eenvoudig) soort uitvoerfunctie. Een opvraagfunctie presenteert gegevens uit het systeem op basis van een uniek identificerend zoekgegeven, waarbij geen aanvullende bewerkingen (zoals berekeningen of het bijwerken van een gegevensverzameling) plaats hebben. Voorbeeld: Het tonen van de gegevens van de klant met klantnummer 123456789.
-          deriving (Eq, Show)
-
-data FPcompl = Eenvoudig | Gemiddeld | Moeilijk deriving (Eq, Show)
-
-
-
-
-data PlugInfo = InternalPlug PlugSQL 
-              | ExternalPlug ObjectDef
-                deriving (Show, Eq)
-instance Identified PlugInfo where
-  name (InternalPlug psql) = name psql
-  name (ExternalPlug obj)  = name obj
-instance ConceptStructure PlugInfo where
-  concs   (InternalPlug psql) = concs   psql
-  concs   (ExternalPlug obj)  = concs   obj
-  expressionsIn (InternalPlug psql) = expressionsIn psql
-  expressionsIn (ExternalPlug obj)  = expressionsIn obj
-instance ConceptStructure PlugSQL where
-  concs     p = concs   (plugFields p)
-  expressionsIn   p = expressionsIn (plugFields p)
-  mp1Exprs = fatal 458 "mp1Exprs is not meant to be for a plug."
-   
-
-data PlugSQL
-   -- | stores a related collection of relations: a kernel of concepts and attribute relations of this kernel
-   --   i.e. a list of SqlField given some A -> [target r | r::A*B,isUni r,isTot r, isInj r] 
-   --                                        ++ [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=fldexpr of kernel field holding instances of B, in practice r is I or a makeRelation(flipped declaration))
-   --      attribute relations = All concepts B, A in kernel for which there exists a r::A*B[UNI] and r not TOT and SUR
-   --              (r=fldexpr of attMor field, in practice r is a makeRelation(declaration))
- = TblSQL  { sqlname :: String
-           , fields :: [SqlField]                          -- ^ the first field is the concept table of the most general concept (e.g. Person)
-                                                           --   then follow concept tables of specializations. Together with the first field this is called the "kernel"
-                                                           --   the remaining fields represent attributes.
-           , cLkpTbl :: [(A_Concept,SqlField)]             -- ^ lookup table that links all kernel concepts to fields in the plug
-                                                           -- cLkpTbl is een lijst concepten die in deze plug opgeslagen zitten, en hoe je ze eruit kunt halen
-           , mLkpTbl :: [(Expression,SqlField,SqlField)]   -- ^ lookup table that links concepts to column names in the plug (kernel+attRels)
-                                                           -- mLkpTbl is een lijst met relaties die in deze plug opgeslagen zitten, en hoe je ze eruit kunt halen
-           }
-   -- | stores one relation r in two ordered columns
-   --   i.e. a tuple of SqlField -> (source r,target r) with (fldexpr=I/\r;r~, fldexpr=r) 
-   --   (note: if r TOT then (I/\r;r~ = I). Thus, the concept (source r) is stored in this plug too)
-   --   with tblcontents = [[Just x,Just y] |(x,y)<-contents r]. 
-   --   Typical for BinSQL is that it has exactly two columns that are not unique and may not contain NULL values
- | BinSQL  { sqlname :: String
-           , columns :: (SqlField,SqlField)
-           , cLkpTbl :: [(A_Concept,SqlField)] --given that mLkp cannot be (UNI or INJ) (because then r would be in a TblSQL plug)
-                                                --if mLkp is TOT, then the concept (source mLkp) is stored in this plug
-                                                --if mLkp is SUR, then the concept (target mLkp) is stored in this plug
-           , mLkp :: Expression -- the relation links concepts implemented by this plug
-           }
- -- |stores one concept c in one column
- --  i.e. a SqlField -> c
- --  with tblcontents = [[Just x] |(x,_)<-contents c].
- --  Typical for ScalarSQL is that it has exactly one column that is unique and may not contain NULL values i.e. fldexpr=I[c]
- | ScalarSQL
-           { sqlname :: String
-           , sqlColumn :: SqlField
-           , cLkp :: A_Concept -- the concept implemented by this plug
-           }
-   deriving (Show) 
-instance Identified PlugSQL where
-  name = sqlname
-instance Eq PlugSQL where
-  x==y = name x==name y
-instance Ord PlugSQL where
-  compare x y = compare (name x) (name y)
-
-plugFields :: PlugSQL->[SqlField]
-plugFields plug = case plug of
-    TblSQL{}    -> fields plug
-    BinSQL{}    -> [fst(columns plug),snd(columns plug)]
-    ScalarSQL{} -> [sqlColumn plug]
-
-
--- | This returns all column/table pairs that serve as a concept table for cpt. When adding/removing atoms, all of these
--- columns need to be updated 
-lookupCpt :: Fspc -> A_Concept -> [(PlugSQL,SqlField)]
-lookupCpt fSpec cpt = [(plug,fld) |InternalPlug plug@TblSQL{}<-plugInfos fSpec, (c,fld)<-cLkpTbl plug,c==cpt]++
-                 [(plug,fld) |InternalPlug plug@BinSQL{}<-plugInfos fSpec, (c,fld)<-cLkpTbl plug,c==cpt]++
-                 [(plug,sqlColumn plug) |InternalPlug plug@ScalarSQL{}<-plugInfos fSpec, cLkp plug==cpt]
-
-data SqlFieldUsage = TableKey Bool A_Concept  -- The field is the (primary) key of the table. (The boolean tells whether or not it is primary)
-                   | ForeignKey A_Concept  -- The field is a reference (containing the primary key value of) a TblSQL
-                   | PlainAttr             -- None of the above
-                   deriving (Eq, Show)
-
-data SqlField = Fld { fldname :: String
-                    , fldexpr :: Expression     -- ^ De target van de expressie geeft de waarden weer in de SQL-tabel-kolom.
-                    , fldtype :: SqlType
-                    , flduse ::  SqlFieldUsage
-                    , fldnull :: Bool           -- ^ True if there can be empty field-values (intended for data dictionary of DB-implementation)
-                    , flduniq :: Bool           -- ^ True if all field-values are unique? (intended for data dictionary of DB-implementation)
-                    } deriving (Eq, Show)
-
-instance Ord SqlField where
-  compare x y = compare (fldname x) (fldname y)
-instance ConceptStructure SqlField where
-  concs     f = [target e' |let e'=fldexpr f,isSur e']
-  expressionsIn   f = expressionsIn   (fldexpr f)
-  mp1Exprs = fatal 452 "mp1Exprs is not meant to be for a plug."
-
-                    
-                    
-data SqlType = SQLChar    Int
-             | SQLBlob              -- cannot compare, but can show (as a file)
-             | SQLPass              -- password, encrypted: cannot show, but can compare
-             | SQLSingle  
-             | SQLDouble  
-             | SQLText              -- cannot compare, but can show (as a text)
-             | SQLuInt    Int
-             | SQLsInt    Int
-             | SQLId                -- autoincrement integer
-             | SQLVarchar Int
-             | SQLBool              -- exists y/n
-             deriving (Eq,Show)
-
-getGeneralizations :: Fspc -> A_Concept -> [A_Concept]
-getGeneralizations fSpec = largerConcepts (gens fSpec)
-
-getSpecializations :: Fspc -> A_Concept -> [A_Concept]
-getSpecializations fSpec = smallerConcepts (gens fSpec)
-

− src/lib/DatabaseDesign/Ampersand/Fspec/GenerateUML.hs 
@@ -1,280 +0,0 @@-{-# OPTIONS_GHC -Wall #-}
-module DatabaseDesign.Ampersand.Fspec.GenerateUML (generateUML) where
-
-import DatabaseDesign.Ampersand.Basics
-import DatabaseDesign.Ampersand.Misc
-import DatabaseDesign.Ampersand.Core.AbstractSyntaxTree (explMarkup,aMarkup2String,Rule,Declaration,Purpose(..))
-import DatabaseDesign.Ampersand.Fspec.Graphic.ClassDiagram
-import DatabaseDesign.Ampersand.Fspec
-import Data.Map (Map)
-import Data.List
-import qualified Data.Map as Map
-import Control.Monad.State.Lazy  (State, gets, evalState, modify)
-
-fatal :: Int -> String -> a
-fatal = fatalMsg "Fspec.GenerateUML"
-
--- TODO: escape
--- TODO: names of model, package, assoc (empty?), etc.
-
-generateUML :: Fspc -> Options -> String
-generateUML fSpec flags = showUML (fSpec2UML fSpec flags)
-
-showUML :: UML -> String
-showUML uml = unlines $ evalState uml $ UMLState 0 Map.empty [] []
-
-fSpec2UML :: Fspc -> Options -> UML
-fSpec2UML fSpec flags = 
- do { packageId0 <- mkUnlabeledId "TopPackage"
-    ; packageId1 <- mkUnlabeledId "PackageClasses" 
-    ; packageId2 <- mkUnlabeledId "PackageReqs"
-    ; diagramId <- mkUnlabeledId "Diagram"
-    
-    ; _ <- mapM (mkLabeledId "Datatype") datatypeNames
-    ; _ <- mapM (mkLabeledId "Class") classNames
-
-    ; datatypesUML <- mapM genUMLDatatype datatypeNames
-    ; classesUML <- mapM genUMLClass (classes classDiag)
-    ; assocsUML <- mapM genUMLAssociation (assocs classDiag)
-    ; requirementsUML <- mapM genUMLRequirement (requirements flags fSpec)
-    ; diagramElements <- genDiagramElements 
-    ; customProfileElements <- genCustomProfileElements
-    ; customReqElements <- genCustomReqElements fSpec flags packageId2
-    ; return $ [ "<?xml version=\"1.0\" encoding=\"UTF-8\"?>"
-               , "<!-- Generated by "++ampersandVersionStr++" -->"
-               , "<xmi:XMI xmi:version=\"2.1\" xmlns:uml=\"http://schema.omg.org/spec/UML/2.1\" xmlns:xmi=\"http://schema.omg.org/spec/XMI/2.1\" xmlns:thecustomprofile=\"http://www.sparxsystems.com/profiles/thecustomprofile/1.0\">"
-               -- WHY is the exporter not something like `Ampersand` (in the string below)?
-               -- BECAUSE then for some reason the importer doesn't show the properties of the requirements.
-               , " <xmi:Documentation exporter=\"Enterprise Architect\" exporterVersion=\"6.5\"/>"
-               , " <uml:Model xmi:type=\"uml:Model\" name=\""++contextName++"\" visibility=\"public\">"
-               , "  <packagedElement xmi:type=\"uml:Package\" xmi:id="++show packageId0++" name="++show contextName++" visibility=\"public\">" ] ++
-               [ "   <packagedElement xmi:type=\"uml:Package\" xmi:id="++show packageId1++" name="++show ("classesOf_"++contextName)++" visibility=\"public\">" ] ++
-               concat datatypesUML ++
-               concat classesUML ++ 
-               concat assocsUML ++
-               [ "   </packagedElement>" ] ++
-               [ "   <packagedElement xmi:type=\"uml:Package\" xmi:id="++show packageId2++" name="++show ("RequirementsOf_"++contextName)++" visibility=\"public\">" ] ++
-               concat requirementsUML ++
-               [ "   </packagedElement>" ] ++
-               [ "  </packagedElement>" ] ++
-               customProfileElements ++
-               [ " </uml:Model>"
-               , " <xmi:Extension extender=\"Enterprise Architect\" extenderID=\"6.5\">"
-               , "  <elements>"] ++
-               [ "    <element xmi:idref="++show packageId0++" xmi:type=\"uml:Package\" name="++show contextName++" scope=\"public\">"]++
-               [ "    </element>"]++
-               [ "    <element xmi:idref="++show packageId1++" xmi:type=\"uml:Package\" name="++show ("classesOf_"++contextName)++" scope=\"public\">"]++
-               [ "     <model package2="++show packageId1++" package="++show packageId0++" tpos=\"0\" ea_eleType=\"package\"/>"]++
-               [ "    </element>"]++
-               [ "    <element xmi:idref="++show packageId2++" xmi:type=\"uml:Package\" name="++show ("RequirementsOf_"++contextName)++" scope=\"public\">"]++
-               [ "     <model package2="++show packageId2++" package="++show packageId0++" tpos=\"0\" ea_eleType=\"package\"/>"]++
-               [ "    </element>"]++
-               customReqElements ++
-               [ "  </elements>"
-               , "  <diagrams>"
-               , "   <diagram xmi:id=\""++diagramId++"\">"
-               , "    <model package=\""++packageId1++"\" owner=\""++packageId1++"\"/>"
-               , "    <properties name=\"Data Model\" type=\"Logical\"/>"
-               , "    <elements>" ] ++
-               diagramElements ++
-               [ "    </elements>"
-               , "   </diagram>"
-               , "  </diagrams>"
-               , " </xmi:Extension>"
-               , "</xmi:XMI>" ]
-    }
- where classDiag = cdAnalysis fSpec flags
-       contextName = cdName classDiag
-       allConcs = ooCpts classDiag
-       classNames    = map name (classes classDiag)
-       datatypeNames = map name allConcs >- classNames
-
-genUMLRequirement :: Req -> UML
-genUMLRequirement req =
- do { reqLId <- mkUnlabeledId "Req"
-    ; addReqToState (reqLId, req)
-    ; return $ [ "    <packagedElement xmi:type=\"uml:Class\" xmi:id=\""++reqLId++"\" name=\""++reqId req++"\" visibility=\"public\"/> " ] 
-    }
-
-genUMLDatatype :: String -> UML
-genUMLDatatype nm =
- do { datatypeId <- refLabeledId nm
-    ; addToDiagram datatypeId
-    ; return [ "    <packagedElement xmi:type=\"uml:DataType\" xmi:id=\""++datatypeId++"\" name=\""++nm++"\" visibility=\"public\"/> " ]
-    }
-
-genUMLClass :: Class -> UML
-genUMLClass cl =
- do { classId <- refLabeledId (clName cl)
-    ; addToDiagram classId
-    ; attributesUML <- mapM genUMAttribute (clAtts cl)
-    ; return $ [ "    <packagedElement xmi:type=\"uml:Class\" xmi:id=\""++classId++"\" name=\""++clName cl++"\" visibility=\"public\">"] ++
-               concat attributesUML ++
-               [ "    </packagedElement>"]
-    }
-
-genUMAttribute :: CdAttribute -> UML
-genUMAttribute  (OOAttr nm attrType optional) =
- do { attrId <- mkUnlabeledId "Attr"
-    ; lIntId <- mkUnlabeledId "Int"
-    ; uIntId <- mkUnlabeledId "Int"
-    ; classId <- refLabeledId attrType
-    ; return [ "       <ownedAttribute xmi:type=\"uml:Property\" xmi:id=\""++attrId++"\" name=\""++nm++"\" visibility=\"public\" isStatic=\"false\""++
-                                    " isReadOnly=\"false\" isDerived=\"false\" isOrdered=\"false\" isUnique=\"true\" isDerivedUnion=\"false\">"
-             , "        <type xmi:idref=\""++classId++"\"/>"
-             , "        <lowerValue xmi:type=\"uml:LiteralInteger\" xmi:id=\""++lIntId++"\" value=\""++(if optional then "0" else "1")++"\"/>"
-             , "        <upperValue xmi:type=\"uml:LiteralInteger\" xmi:id=\""++uIntId++"\" value=\"1\"/>"
-             , "       </ownedAttribute>"]
-    }
-
-genUMLAssociation :: Association -> UML
-genUMLAssociation ass = 
- do { assocId <- mkUnlabeledId "Assoc"
-    ; lMemberAndOwnedEnd <- genMemberAndOwnedEnd (asslhm ass) assocId (assSrc ass)
-    ; rMemberAndOwnedEnd <- genMemberAndOwnedEnd (assrhm ass) assocId (assTgt ass)
-        
-    ; return $
-        [ "    <packagedElement xmi:type=\"uml:Association\" xmi:id=\""++assocId++"\" name=\""++assrhr ass++"\" visibility=\"public\">"
-        ] ++
-        lMemberAndOwnedEnd ++
-        rMemberAndOwnedEnd ++
-        [ "    </packagedElement>"
-        ]
-    }
- where genMemberAndOwnedEnd (Mult minVal maxVal) assocId type' =
-        do { endId <- mkUnlabeledId "MemberEnd"
-           ; typeId <- refLabeledId (case type' of
-                                       Left c -> name c
-                                       Right s -> s
-                                    )
-           ; lIntId <- mkUnlabeledId "Int"
-           ; uIntId <- mkUnlabeledId "Int"
-           ; return 
-               [ "     <memberEnd xmi:idref=\""++endId++"\"/>"
-               , "     <ownedEnd xmi:type=\"uml:Property\" xmi:id=\""++endId++"\" visibility=\"public\" association=\""++assocId++"\" isStatic=\"false\""++
-                              " isReadOnly=\"false\" isDerived=\"false\" isOrdered=\"false\" isUnique=\"true\" isDerivedUnion=\"false\" aggregation=\"none\">"
-               , "      <type xmi:idref=\""++typeId++"\"/>"
-               , "      <lowerValue xmi:type=\"uml:LiteralInteger\" xmi:id=\""++lIntId++"\" value=\""++(if minVal == MinZero then "0" else "1")++"\"/>"
-               , case maxVal of
-                   MaxOne  -> "      <upperValue xmi:type=\"uml:LiteralInteger\" xmi:id=\""++uIntId++"\" value=\"1\"/>"
-                   MaxMany -> "      <upperValue xmi:type=\"uml:LiteralUnlimitedNatural\" xmi:id=\""++uIntId++"\" value=\"-1\"/>"
-               , "     </ownedEnd>"
-               ]
-           }
-           
-genDiagramElements :: UML
-genDiagramElements =
- do { elementIds <- gets diagramEltIds
-    ; return [ "      <element subject=\""++elementId++"\"/>" | elementId <- elementIds ]
-    }
-
-genCustomProfileElements :: UML
-genCustomProfileElements =
- do { reqVals <- gets reqValues
-    ; return  [reqUML req | req <- reverse reqVals]
-    }
-  where
-    reqUML :: ReqValue2 -> String
-    reqUML (xmiId, req) = intercalate "\n"
-     ( ["   <thecustomprofile:Functional base_Requirement="++show xmiId++"/>"]++
-       [tagUML xmiId count puprtxt reftxt | (count, (puprtxt, reftxt)) <- zip [0::Int ..] [(aMarkup2String (explMarkup p), intercalate ";" (explRefIds p)) | p <- reqPurposes req]]
-     )
-    tagUML xmiId nr value reftxt = intercalate "\n"
-      [ "     <thecustomprofile:"++keyMeaning++" base_Requirement="++show xmiId++" "++keyMeaning++"="++show value++"/>"
-      , "     <thecustomprofile:"++keyRef    ++" base_Requirement="++show xmiId++" "++keyRef++"="++show reftxt++"/>"
-      ]
-        where keyMeaning = "Meaning"++show nr
-              keyRef     = "Reference"++show nr
-              
-genCustomReqElements :: Fspc -> Options -> String -> UML
-genCustomReqElements fSpec _ parentPackageId =
- do { reqVals <- gets reqValues
-    ; return [reqUML req | req <- reverse reqVals]
-    }
-  where
-    reqUML :: ReqValue2 -> String
-    reqUML (xmiId, req) = intercalate "\n"
-     ([ "    <element xmi:idref="++show xmiId++" xmi:type=\"uml:Requirement\" name="++show (reqId req)++" scope=\"public\""++">"
-      , "      <model package="++show parentPackageId++" ea_eleType=\"element\"/>"
-      , "      <properties documentation="++show (maybe "" aMarkup2String (meaning (fsLang fSpec) req))++" isSpecification=\"false\" sType=\"Requirement\" nType=\"0\" scope=\"public\" stereotype=\"Functional\"/>"
-      , "      <tags>"]++
-      [ "         <tag name=\"Purpose"++nr++"\" value="++show p++" modelElement="++show xmiId++"/>" | (nr ,p) <- zip ("" : map show [1::Int ..]) ([aMarkup2String (explMarkup p) | p <- reqPurposes req])  ]++
-      [ "      </tags>"
-      , "    </element>"
-      ])
-
--- Requirements
-
-data Req = Req { reqId :: String
-            --   , reqRef :: String
-               , reqOrig :: Either Rule Declaration
-               , reqPurposes :: [Purpose]
-               }
-
-instance Meaning Req where
-  meaning l r = case reqOrig r of
-                  Right rul -> meaning l rul
-                  Left  dcl -> meaning l dcl
-
-requirements :: Options -> Fspc -> [Req]
-requirements _ fSpec
-   = [decl2req d | d <- vrels  fSpec]
-   ++[rule2req r | r <- vrules fSpec]
-  where
-    decl2req d = Req { reqId = name d
-                     , reqOrig = Right d
-                     , reqPurposes = purposesDefinedIn fSpec (fsLang fSpec) d
-                     }
-    rule2req r = Req { reqId = name r
-                     , reqOrig = Left r
-                     , reqPurposes = purposesDefinedIn fSpec (fsLang fSpec) r
-                     }
-                     
-
-
--- State and Monad
-
-data UMLState = UMLState { idCounter :: Int
-                         , labelIdMap :: Map String String
-                         , diagramEltIds :: [String]
-                         , reqValues :: [ReqValue2]
-                         }
-                         
-type StateUML a = State UMLState a
-                           
-
-type UML = StateUML [String]
-
-type ReqValue2 = ( String -- the xmi-id
-                , Req
-                )
-
-addToDiagram :: String -> StateUML ()
-addToDiagram elementId =
-  modify $ \state' -> state' { diagramEltIds = elementId : diagramEltIds state'} 
-
-addReqToState :: ReqValue2 -> StateUML ()
-addReqToState reqVal =
-  modify $ \state' -> state' { reqValues = reqVal : reqValues state'}
-
-mkUnlabeledId :: String -> StateUML String
-mkUnlabeledId tag =
- do { idC <- gets idCounter 
-    ; modify $ \state' -> state' { idCounter = idCounter state' + 1}
-    ; let unlabeledId = tag++"ID_"++show idC 
-    ; return unlabeledId
-    }
-
-refLabeledId :: String -> StateUML String
-refLabeledId label =
- do { lidMap <- gets labelIdMap
-    ; case Map.lookup label lidMap of
-          Just lid -> return lid
-          Nothing  -> fatal 147 $ "Requesting non-existent label "++label
-    }
-    
-mkLabeledId :: String -> String -> StateUML ()
-mkLabeledId tag label =
- do { let classId = tag++"ID_"++label 
-    ; modify $ \state' -> state' { labelIdMap =  Map.insert label classId (labelIdMap state') }
-    }
− src/lib/DatabaseDesign/Ampersand/Fspec/Graphic/ClassDiagram.hs 
@@ -1,514 +0,0 @@-{-# OPTIONS_GHC -Wall #-}
---TODO -> clean and stuff. Among which moving classdiagram2dot to Graphviz library implementation (see Classes/Graphics.hs).
---        I only helped it on its feet and I have put in the fSpec, now it generates stuff. I like stuff :)
-
-module DatabaseDesign.Ampersand.Fspec.Graphic.ClassDiagram
-         (ClassDiag(..), Class(..), CdAttribute(..), Association(..), Aggregation(..), Generalization(..), Deleting(..), Method(..),
-          Multiplicities(..), MinValue(..), MaxValue(..),
-          clAnalysis, cdAnalysis, tdAnalysis, classdiagram2dot)
-where
-   import Data.List
-   import DatabaseDesign.Ampersand.Basics
-   import DatabaseDesign.Ampersand.Classes
-   import DatabaseDesign.Ampersand.ADL1  hiding (Association,Box)
-   import DatabaseDesign.Ampersand.Fspec.Plug
-   import DatabaseDesign.Ampersand.Misc
-   import DatabaseDesign.Ampersand.Fspec.Fspec
-   import Data.String
-   import Data.Maybe
-   import Data.GraphViz.Types.Canonical hiding (attrs)
-   import Data.GraphViz.Attributes.Complete as GVcomp
-   import Data.GraphViz.Attributes as GVatt
-   import Data.GraphViz.Attributes.HTML as Html
-   
-   fatal :: Int -> String -> a
-   fatal = fatalMsg "Fspec.Graphic.ClassDiagram"
-
-   class CdNode a where
-    nodes :: a->[String]
-
-
-   instance CdNode ClassDiag where
-    nodes cd = nub (concat (  map nodes (classes cd)
-                            ++map nodes (assocs  cd)
-                            ++map nodes (aggrs   cd)
-                            ++map nodes (geners  cd)
-                   )       )
-
-
-   instance CdNode Class where
-    nodes cl = [clName cl]
-   instance CdNode a => CdNode [a] where
-    nodes = concatMap nodes
-
-   instance CdNode CdAttribute where
-    nodes (OOAttr _ t _) = [t]
-
-   instance CdNode Method where
-    nodes _ = []
-
-   instance CdNode Association where
-    nodes a = map nm [assSrc a,assTgt a]
-      where
-       nm (Left  c  ) = name c
-       nm (Right str) = str
-
-   instance CdNode Aggregation where
-    nodes (OOAggr _ s t) = map name [s,t]
-
-   instance CdNode Generalization where
-    nodes g = map name ((concs.genAgen) g)
-
-   -- | This function makes the classification diagram.
-   -- It focuses on generalizations and specializations.
-   clAnalysis :: Fspc -> Options -> ClassDiag
-   clAnalysis fSpec _ = 
-       OOclassdiagram { cdName  = "classification_"++name fSpec
-                      , classes = [ OOClass { clName = name c
-                                            , clcpt  = Just c
-                                            , clAtts = attrs c
-                                            , clMths = [] 
-                                            } | c<-cpts]
-                      , assocs  = []
-                      , aggrs   = []
-                      , geners  = map OOGener (gensInScope fSpec)
-                      , ooCpts  = concs fSpec
-                      }
-
-    where
-       cpts       = concs (gensInScope fSpec)
-       attrs c    = [ OOAttr (fldname fld) (if isPropty fld then "Bool" else  name (target (fldexpr fld))) (fldnull fld)
-                    | plug<-lookup' c, fld<-tail (plugFields plug), not (inKernel fld), source (fldexpr fld)==c]
-                    where inKernel fld = null([Uni,Inj,Sur]>-multiplicities (fldexpr fld)) && not (isPropty fld)
-       lookup' c = [plug |InternalPlug plug@TblSQL{}<-plugInfos fSpec , (c',_)<-cLkpTbl plug, c'==c]
-       isPropty fld = null([Sym,Asy]>-multiplicities (fldexpr fld))
-
-
-   -- | This function, cdAnalysis, generates a conceptual data model.
-   -- It creates a class diagram in which generalizations and specializations remain distinct entity types.
-   -- This yields more classes than plugs2classdiagram does, as plugs contain their specialized concepts.
-   -- Properties and identities are not shown.
-   cdAnalysis :: Fspc -> Options -> ClassDiag
-   cdAnalysis fSpec _ = 
-     OOclassdiagram { cdName  = "logical_"++name fSpec
-                    , classes = 
-                        [ OOClass{ clName = name root
-                                 , clcpt  = Just root
-                                 , clAtts = map ooAttr ooClass
-                                 , clMths = []
-                                 }
-                        | ooClass <- ooClasses, let root=source (head ooClass)]
-                    , assocs  = 
-                        [ OOAssoc { assSrc = Left (source r)
-                                  , assSrcPort = name d
-                                  , asslhm = (mults.flp) r
-                                  , asslhr = ""
-                                  , assTgt = Left (target r)
-                                  , assrhm = mults r
-                                  , assrhr = name d
-                                  }
-                        | r@(EDcD d) <- allrels, target r `elem` roots
-                        ]
-                    , aggrs   = []
-                    , geners  = []
-                    , ooCpts  = roots
-                    }
-
-    where
-      ooAttr :: Expression -> CdAttribute
-      ooAttr r = OOAttr { attNm = (name . head . relsMentionedIn) r
-                        , attTyp = (name.target) r
-                        , attOptional = (not.isTot) r
-                        }
-      mults r = let minVal = if isTot r then MinOne else MinZero
-                    maxVal = if isInj r then MaxOne else MaxMany
-                in  Mult minVal maxVal 
-      allrels = [ EDcD r -- restricted to those themes that must be printed.
-                | r@Sgn{} <- (nub.concat)
-                             ([relsDefdIn p ++ relsMentionedIn p  | p <- pattsInScope fSpec ]++
-                              [relsDefdIn p ++ relsMentionedIn p  | p <- procsInScope fSpec ])
-               , decusr r]
-      attribs = map flipWhenInj (filter isAttribRel allrels)
-          where isAttribRel r = isUni r || isInj r
-                flipWhenInj r = if isInj r then flp r else r
-      ooClasses = eqCl source attribs      -- an equivalence class wrt source yields the attributes that constitute an OO-class.
-      roots = map (source.head) ooClasses
-
-
-   -- | This function generates a technical data model.
-   -- It is based on the plugs that are calculated.
-   tdAnalysis :: Fspc -> Options -> ClassDiag
-   tdAnalysis fSpec _ = 
-     OOclassdiagram {cdName  = "technical_"++name fSpec
-                    ,classes = 
-                       [ OOClass{ clName = sqlname table
-                                , clcpt  = primKey table
-                                , clAtts = case table of
-                                              TblSQL{fields=attribs
-                                                    ,mLkpTbl=t} -> map (ooAttr.lookInFor t.fldexpr) attribs
-                                              BinSQL{columns=(a,b)}      -> 
-                                                 [OOAttr { attNm       = fldname a
-                                                         , attTyp      = (name.target.fldexpr) a
-                                                         , attOptional = False
-                                                         }
-                                                 ,OOAttr { attNm       = fldname b
-                                                         , attTyp      = (name.target.fldexpr) b
-                                                         , attOptional = False
-                                                         }
-                                                 ]
-                                              _     -> fatal 166 "Unexpeced type of table!"
-                                , clMths = []
-                                }
-                       | table <- tables]
-                    ,assocs  = allAssocs
-                    ,aggrs   = []
-                    ,geners  = []
-                    ,ooCpts  = roots
-                    }
-     where
-      lookInFor [] _ = fatal 191 "Expression not found!"
-      lookInFor ((expr,_,t):xs) a 
-                 | expr == a = t
-                 | otherwise = lookInFor xs a 
-      tables = [ pSql | InternalPlug pSql <- plugInfos fSpec, not (isScalar pSql)]
-         where isScalar ScalarSQL{} = True
-               isScalar _           = False 
-      roots :: [A_Concept]
-      roots = catMaybes (map primKey tables)
-      primKey TblSQL{fields=(f:_)} = Just (source (fldexpr f))
-      primKey _                    = Nothing
-      ooAttr :: SqlField -> CdAttribute
-      ooAttr f= OOAttr { attNm = fldname f 
-                       , attTyp = (name.target.fldexpr) f
-                       , attOptional = fldnull f
-                       }
-      allAssocs = [a | a<-concatMap relsOf tables
-                     , hasRootTarget a
-                  ]
-        where
-          hasRootTarget a = case assTgt a of
-                               Left c ->  c `elem`  kernelConcepts
-                               Right _ -> False
-          kernelConcepts = map fst (concatMap cLkpTbl tables)
-          rootOf c = head [(source.fldexpr.snd.head.cLkpTbl) t | t<-tables, c `elem` map fst ( cLkpTbl t)]
-          relsOf t = 
-            case t of
-              TblSQL{} -> map mkRel (catMaybes [relOf fld | fld <- fields t])
-              BinSQL{columns=(a,b)} -> 
-                        [ OOAssoc { assSrc = Right (sqlname t)
-                                  , assSrcPort = fldname a
-                                  , asslhm = Mult MinZero MaxMany
-                                  , asslhr = ""
-                                  , assTgt = (Left .target.fldexpr) a
-                                  , assrhm = Mult MinOne MaxOne
-                                  , assrhr = ""
-                                  }
-                        , OOAssoc { assSrc = Right (sqlname t)
-                                  , assSrcPort = fldname b
-                                  , asslhm = Mult MinZero MaxMany
-                                  , asslhr = ""
-                                  , assTgt = (Left .target.fldexpr) b
-                                  , assrhm = Mult MinOne MaxOne
-                                  , assrhr = ""
-                                  }
-                        ]
-              _  -> fatal 195 "Unexpeced type of table!"
-          relOf f = 
-            let expr = fldexpr f in
-            case expr of
-              EDcI{} -> Nothing
-              EDcD d -> if target d `elem` kernelConcepts then Just (expr,f) else Nothing
-              EFlp (EDcD d) -> if source d `elem` kernelConcepts then Just (expr,f) else Nothing
-              _ -> fatal 200 ("Unexpected expression: "++show expr)
-          mkRel :: (Expression,SqlField) -> Association
-          mkRel (expr,f) =
-               OOAssoc { assSrc = Left (source expr)
-                       , assSrcPort = fldname f
-                       , asslhm = (mults.flp) expr
-                       , asslhr = fldname f
-                       , assTgt = Left (rootOf (target expr))
-                       , assrhm = mults expr
-                       , assrhr = case [name d | d@Sgn{}<-relsMentionedIn expr] of h:_ -> h ; _ -> fatal 229 "no relations used in expr"
-                       }
-      mults r = let minVal = if isTot r then MinOne else MinZero
-                    maxVal = if isInj r then MaxOne else MaxMany
-                in  Mult minVal maxVal 
-
-
----- In order to make classes, all relations that are univalent and injective are flipped
----- attRels contains all relations that occur as attributes in classes.
---       attRels    = [r |r<-rels, isUni r, not (isInj r)]        ++[flp r |r<-rels, not (isUni r), isInj r] ++
---                    [r |r<-rels, isUni r,      isInj r, isSur r]++[flp r |r<-rels,      isUni r , isInj r, not (isSur r)]
----- assRels contains all relations that do not occur as attributes in classes
---       assRels    = [r |r<-relsLim, not (isUni r), not (isInj r)]
---       attrs rs   = [ OOAttr ((name.head.relsMentionedIn) r) (name (target r)) (not(isTot r))
---                    | r<-rs, not (isPropty r)]
---       isPropty r = null([Sym,Asy]>-multiplicities r)
-       
-   -- | translate a ClassDiagram to a DotGraph, so it can be used to show it as a picture. 
-   classdiagram2dot :: Options -> ClassDiag -> DotGraph String
-   classdiagram2dot flags  cd
-    = DotGraph { strictGraph     = False
-               , directedGraph   = True
-               , graphID         = Nothing
-               , graphStatements = dotstmts
-               }
-        where
-         dotstmts = DotStmts
-           { attrStmts =  [ GraphAttrs [ RankDir FromLeft
-                                       , bgColor White]
-                          ]
-                   --    ++ [NodeAttrs  [ ]]
-                       ++ [EdgeAttrs  [ FontSize 11
-                                      , MinLen 4
-                          ]           ]
-           , subGraphs = []
-           , nodeStmts = allNodes (classes cd) (nodes cd >- nodes (classes cd))
-           , edgeStmts = (map association2edge (assocs cd))  ++
-                         (map aggregation2edge (aggrs cd))  ++
-                         (concatMap generalization2edges (geners cd))
-           }
-        
-        
-          where
-          allNodes :: [Class] -> [String] -> [DotNode String]
-          allNodes cs others = 
-             map class2node cs ++ 
-             map nonClass2node others
-          
-          class2node :: Class -> DotNode String
-          class2node cl = DotNode 
-            { nodeID         = name cl
-            , nodeAttributes = [ Shape PlainText
-                               , GVcomp.Color [WC (X11Color Purple) Nothing]
-                               , Label (HtmlLabel (Table htmlTable))
-                               ]
-            } where 
-             htmlTable = HTable { tableFontAttrs = Nothing
-                                , tableAttrs     = [ Html.BGColor (X11Color White)
-                                                   , Html.Color (X11Color Black) -- the color used for all cellborders
-                                                   , Html.Border 0  -- 0 = no border
-                                                   , CellBorder 1  
-                                                   , CellSpacing 0
-                                                   ]
-                                , tableRows      = [ Cells -- Header row, containing the name of the class
-                                                      [ LabelCell 
-                                                            [ Html.BGColor (X11Color Gray10)
-                                                            , Html.Color   (X11Color Black)
-                                                            ]
-                                                            (Html.Text [ Html.Font [ Html.Color   (X11Color White)
-                                                                                 ]                                                            
-                                                                                 [Html.Str (fromString (name cl))]
-                                                                      ]
-                                                            )
-                                                      ]
-                                                   ]++ 
-                                                   map attrib2row (clAtts cl) ++
-                                                   map method2row (clMths cl) 
-                                                   
-                                                   
-                                } 
-                 where
-                   attrib2row a = Cells
-                                    [ Html.LabelCell [ Html.Align HLeft
-                                                     , (Port .PN .fromString) (attNm a)
-                                                     ] 
-                                         ( Html.Text [ Html.Str (fromString (if attOptional a then "o " else "+ "))
-                                                     , Html.Str (fromString (name a))
-                                                     , Html.Str (fromString " : ")
-                                                     , Html.Str (fromString (attTyp a))
-                                                     ]
-                                         ) 
-                                    ]
-                   method2row m = Cells
-                                    [ Html.LabelCell [ Html.Align HLeft] 
-                                         ( Html.Text [ Html.Str (fromString "+ ")
-                                                     , Html.Str (fromString (show m))
-                                                     ]
-                                         ) 
-                                    ]
-                    
-          nonClass2node :: String -> DotNode String
-          nonClass2node str = DotNode { nodeID = str
-                                      , nodeAttributes = [ Shape Box3D
-                                                         , Label (StrLabel (fromString str))
-                                                         ]
-                                      }
-          
-  -------------------------------
-  --        ASSOCIATIONS:      --
-  -------------------------------
-          association2edge :: Association -> DotEdge String
-          association2edge ass = 
-             DotEdge { fromNode       = (case assSrc ass of
-                                          Left c  -> name c
-                                          Right s -> s)
-                     , toNode         = case assTgt ass of
-                                          Left c  -> name c
-                                          Right s -> s
-                     , edgeAttributes = [ ArrowHead (AType [(ArrMod OpenArrow BothSides, NoArrow)])  -- No arrowHead
-                                        , ArrowTail (AType [(ArrMod OpenArrow BothSides, NoArrow)])  -- No arrowTail
-                                        , HeadLabel (mult2Lable (assrhm ass))
-                                        , TailLabel (mult2Lable (asslhm ass))
-                                        , Label     (StrLabel (fromString (assrhr ass)))
-                                        , LabelFloat True
-                                        ]
-                                      ++[(TailPort (LabelledPort (PN ((fromString.assSrcPort) ass)) Nothing))]
-                     }
-              where
-                 mult2Lable = StrLabel . fromString . mult2Str
-                 mult2Str (Mult MinZero MaxOne)  = "0-1"
-                 mult2Str (Mult MinZero MaxMany) = "*"
-                 mult2Str (Mult MinOne  MaxOne)  = "1"
-                 mult2Str (Mult MinOne  MaxMany) = "1-*"
-                  
-  -------------------------------
-  --        AGGREGATIONS:      --
-  -------------------------------
-          aggregation2edge :: Aggregation -> DotEdge String
-          aggregation2edge agg =
-             DotEdge { fromNode       = (name.aggSrc) agg
-                     , toNode         = (name.aggTgt) agg
-                     , edgeAttributes = [ ArrowHead (AType [(ArrMod OpenArrow BothSides, NoArrow)])  -- No arrowHead
-                                        , ArrowTail (AType [(ArrMod (case aggDel agg of 
-                                                                      Open -> OpenArrow
-                                                                      Close -> FilledArrow
-                                                                    ) BothSides , Diamond)
-                                                           ]) 
-                                        ]
-                     }
-                 
- 
- 
-  -------------------------------
-  --        GENERALIZATIONS:   --       -- Ampersand statements such as "GEN Dolphin ISA Animal" are called generalization.
-  --                           --       -- Generalizations are represented by a red arrow with a (larger) open triangle as arrowhead 
-  -------------------------------
-          generalization2edges :: Generalization -> [DotEdge String]
-          generalization2edges ooGen = sub2edges (genAgen ooGen)
-           where
-             sub2edges gen
-              = [DotEdge { fromNode = name gener
-                         , toNode   = name spec
-                         , edgeAttributes 
-                                    = [ ArrowTail (AType [(ArrMod OpenArrow BothSides, NoArrow)])  -- No arrowTail
-                                      , ArrowHead (AType [(ArrMod OpenArrow BothSides, Normal)])   -- Open normal arrowHead
-                                      , ArrowSize  2.0
-                                      ] ++
-                                      ( if blackWhite flags
-                                        then [Style [SItem Dashed []]]
-                                        else [GVcomp.Color [WC (X11Color Red) Nothing]]
-                                      )
-                         }
-                | (spec,gener)<-splits gen]
-             splits gen = case gen of 
-                                  Isa{} -> [(genspc gen, gengen gen)]
-                                  IsE{} -> [(genspc gen, x ) | x<-(genrhs gen)]
-
--------------- Class Diagrams ------------------
-   data ClassDiag = OOclassdiagram {cdName :: String
-                                   ,classes :: [Class]           --
-                                   ,assocs :: [Association]      --
-                                   ,aggrs ::  [Aggregation]      --
-                                   ,geners :: [Generalization]   --
-                                   ,ooCpts :: [A_Concept]}
-                            deriving Show
-   instance Identified ClassDiag where
-      name = cdName
-        
-   data Class          = OOClass  { clName :: String          -- ^ name of the class
-                                  , clcpt ::  Maybe A_Concept -- ^ Main concept of the class. (link tables do not have a main concept)
-                                  , clAtts :: [CdAttribute]   -- ^ Attributes of the class
-                                  , clMths :: [Method]        -- ^ Methods of the class
-                                  } deriving Show
-   instance Identified Class where
-      name = clName
-   data CdAttribute    = OOAttr   { attNm :: String            -- ^ name of the attribute
-                                  , attTyp :: String           -- ^ type of the attribute (Concept name or built-in type)
-                                  , attOptional :: Bool        -- ^ says whether the attribute is optional
-                                  } deriving Show
-   instance Identified CdAttribute where
-      name = attNm
-   data MinValue = MinZero | MinOne deriving (Show, Eq)
-   
-   data MaxValue = MaxOne | MaxMany deriving (Show, Eq)
-   
-   data Multiplicities = Mult MinValue MaxValue deriving Show
-   
-   data Association    = OOAssoc  { assSrc :: Either A_Concept String -- ^ source: the left hand side class. In case of a link table, the name of that table.
-                                  , assSrcPort :: String       -- ^ the name of the field in the source table
-                                  , asslhm :: Multiplicities   -- ^ left hand side multiplicities
-                                  , asslhr :: String           -- ^ left hand side role
-                                  , assTgt :: Either A_Concept String -- ^ target: the right hand side class. In case of a link table, the name of that table.
-                                  , assrhm :: Multiplicities   -- ^ right hand side multiplicities
-                                  , assrhr :: String           -- ^ right hand side role
-                                  }  deriving Show
-   data Aggregation    = OOAggr   { aggDel :: Deleting         -- 
-                                  , aggSrc :: A_Concept           --
-                                  , aggTgt :: A_Concept           --
-                                  } deriving (Show, Eq)
-   data Generalization = OOGener  { genAgen :: A_Gen             --
-                                  } deriving (Show)
-
-
-
-   data Deleting       = Open | Close                      --
-                                    deriving (Show, Eq)
-   data Method         = OOMethodC      String             -- name of this method, which creates a new object (producing a handle)
-                                        [CdAttribute]      -- list of parameters: attribute names and types
-                       | OOMethodR      String             -- name of this method, which yields the attribute values of an object (using a handle).
-                                        [CdAttribute]      -- list of parameters: attribute names and types
-                       | OOMethodS      String             -- name of this method, which selects an object using key attributes (producing a handle).
-                                        [CdAttribute]      -- list of parameters: attribute names and types
-                       | OOMethodU      String             -- name of this method, which updates an object (using a handle).
-                                        [CdAttribute]      -- list of parameters: attribute names and types
-                       | OOMethodD      String             -- name of this method, which deletes an object (using nothing but a handle).
-                       | OOMethod       String             -- name of this method, which deletes an object (using nothing but a handle).
-                                        [CdAttribute]      -- list of parameters: attribute names and types
-                                        String             -- result: a type
-
-   instance Show Method where
-    showsPrec _ (OOMethodC nm cs)  = showString (nm++"("++intercalate "," [ n | OOAttr n _ _<-cs]++"):handle")
-    showsPrec _ (OOMethodR nm as)  = showString (nm++"(handle):["++intercalate "," [ n | OOAttr n _ _<-as]++"]")
-    showsPrec _ (OOMethodS nm ks)  = showString (nm++"("++intercalate "," [ n | OOAttr n _ _<-ks]++"):handle")
-    showsPrec _ (OOMethodD nm)     = showString (nm++"(handle)")
-    showsPrec _ (OOMethodU nm cs)  = showString (nm++"(handle,"++intercalate "," [ n | OOAttr n _ _<-cs]++")")
-    showsPrec _ (OOMethod nm cs r) = showString (nm++"("++intercalate "," [ n | OOAttr n _ _<-cs]++"): "++r)
-
---
---   testCD
---    = OOclassdiagram
---      [ OOClass "Plan" [ooAttr "afkomst" "Actor"] []
---      , OOClass "Formulier" [ooAttr "plan" "Plan",ooAttr "van" "Actor",ooAttr "aan" "Actor",ooAttr "sessie" "Sessie"] []
---      , OOClass "Dossier" [ooAttr "eigenaar" "Actor"] []
---      , OOClass "Gegeven" [ooAttr "type" "Gegevenstype",ooAttr "in" "Dossier",ooAttr "veldnaam" "Veldnaam",ooAttr "waarde" "Waarde"] []
---      , OOClass "Veld" [ooAttr "type" "Veldtype",ooAttr "waarde" "Waarde"] []
---      , OOClass "Veldtype" [ooAttr "veldnaam" "Veldnaam",ooAttr "formuliertype" "Plan",ooAttr "gegevenstype" "Gegevenstype"] []
---      , OOClass "Sessie" [ooAttr "dossier" "Dossier",ooAttr "uitgevoerd" "Actor"] []
---      ]
---      [ OOAssoc "Plan" "0..n" "" "Plan" "0..n" "stap"
---      , OOAssoc "Formulier" "0..n" "" "Actor" "0..n" "inzage"
---      , OOAssoc "Formulier" "0..n" "" "Formulier" "0..n" "in"
---      , OOAssoc "Formulier" "0..n" "" "Plan" "0..n" "stap"
---      , OOAssoc "Autorisatie" "0..n" "" "Actor" "0..n" "aan"
---      , OOAssoc "Gegeven" "0..n" "" "Formulier" "0..n" "op"
---      , OOAssoc "Gegeven" "0..n" "" "Actor" "0..n" "inzage"
---      , OOAssoc "Actor" "0..n" "" "Actor" "0..n" "gedeeld"
---      , OOAssoc "Formulier" "0..n" "" "Actor" "0..n" "inzagerecht"
---      , OOAssoc "Gegeven" "0..n" "" "Actor" "0..n" "inzagerecht"
---      , OOAssoc "Autorisatie" "0..n" "" "Gegeven" "0..n" "object"
---      , OOAssoc "Actie" "0..n" "" "Gegeven" "0..n" "object"
---      , OOAssoc "Autorisatie" "0..n" "" "Actie" "0..n" "op"
---      , OOAssoc "Autorisatie" "0..n" "" "Actor" "0..n" "door"
---      , OOAssoc "Actie" "0..n" "" "Actor" "0..n" "door"
---      , OOAssoc "Veld" "0..n" "" "Gegeven" "0..n" "bindt"
---      , OOAssoc "Sessie" "0..1" "" "Actor" "0..1" "actief"
---      , OOAssoc "Formulier" "0..n" "" "Actor" "0..n" "openstaand"
---      , OOAssoc "Gegeven" "0..n" "" "Actor" "0..n" "openstaand"
---      ]
---      [ OOAggr Close "Dossier" "Formulier"
---      , OOAggr Close "Formulier" "Veld"
---      ]
---      []
---      ("NoPat",[])
---      where ooAttr nm t = OOAttr nm t True

− src/lib/DatabaseDesign/Ampersand/Fspec/Graphic/Graphics.hs 
@@ -1,534 +0,0 @@-{-# OPTIONS_GHC -Wall #-}
-module DatabaseDesign.Ampersand.Fspec.Graphic.Graphics 
-          (makePicture, writePicture, Picture(..), PictureReq(..),imagePath
-    )where
-
-import Data.GraphViz 
-import DatabaseDesign.Ampersand.ADL1 
-import DatabaseDesign.Ampersand.Fspec.Fspec
-import DatabaseDesign.Ampersand.Classes 
-import DatabaseDesign.Ampersand.Fspec.Switchboard
-import DatabaseDesign.Ampersand.Misc
-import DatabaseDesign.Ampersand.Basics
-import DatabaseDesign.Ampersand.Fspec.Graphic.ClassDiagram -- (ClassDiag,classdiagram2dot)
-import Data.GraphViz.Attributes.Complete
-import Data.List
-import Data.String
-
-import System.FilePath hiding (addExtension)
-import System.Directory
-
-fatal :: Int -> String -> a
-fatal = fatalMsg "Fspec.Graphic.Graphics"
-
-data PictureReq = PTClassDiagram 
-                | PTRelsUsedInPat Pattern
-                | PTDeclaredInPat Pattern
-                | PTProcess FProcess
-                | PTConcept A_Concept
-                | PTSwitchBoard Activity
-                | PTFinterface Activity
-                | PTIsaInPattern Pattern  -- Not used at all...
-                | PTSingleRule Rule
-                | PTLogicalDM
-                | PTTechnicalDM
-
-data Picture = Pict { pType :: PictureReq             -- ^ the type of the picture
-                    , scale :: String                 -- ^ a scale factor, intended to pass on to LaTeX, because Pandoc seems to have a problem with scaling.
-                    , dotSource :: DotGraph String    -- ^ the string representing the .dot
-                    , dotProgName :: GraphvizCommand  -- ^ the name of the program to use  ("dot" or "neato" or "fdp" or "Sfdp")
-                    , caption :: String               -- ^ a human readable name of this picture
-                    }
-
-
-makePicture :: Options -> Fspc -> PictureReq -> Picture
-makePicture flags fSpec pr =
-  case pr of 
-   PTClassDiagram      -> Pict { pType = pr
-                               , scale = scale'
-                               , dotSource = classdiagram2dot flags (clAnalysis fSpec flags)
-                               , dotProgName = Dot
-                               , caption = 
-                                   case fsLang fSpec of
-                                      English -> "Classification of " ++ name fSpec
-                                      Dutch   -> "Classificatie van " ++ name fSpec
-                               }
-   PTLogicalDM         -> Pict { pType = pr
-                               , scale = scale'
-                               , dotSource = classdiagram2dot flags (cdAnalysis fSpec flags)
-                               , dotProgName = Dot
-                               , caption = 
-                                   case fsLang fSpec of
-                                      English -> "Logical data model of " ++ name fSpec
-                                      Dutch   -> "Logisch gegevensmodel van " ++ name fSpec
-                               }
-   PTTechnicalDM       -> Pict { pType = pr
-                               , scale = scale'
-                               , dotSource = classdiagram2dot flags (tdAnalysis fSpec flags)
-                               , dotProgName = Dot
-                               , caption = 
-                                   case fsLang fSpec of
-                                      English -> "Technical data model of " ++ name fSpec
-                                      Dutch   -> "Technisch gegevensmodel van " ++ name fSpec
-                               }
-   PTConcept cpt       -> Pict { pType = pr
-                               , scale = scale'
-                               , dotSource = conceptualGraph' fSpec flags pr
-                               , dotProgName = graphVizCmdForConceptualGraph
-                               , caption = 
-                                   case fsLang fSpec of
-                                      English -> "Concept diagram of the rules about " ++ name cpt
-                                      Dutch   -> "Conceptueel diagram van de regels rond " ++ name cpt
-                               }
-   PTDeclaredInPat pat -> Pict { pType = pr
-                               , scale = scale'
-                               , dotSource = conceptualGraph' fSpec flags pr
-                               , dotProgName = graphVizCmdForConceptualGraph
-                               , caption = 
-                                   case fsLang fSpec of
-                                      English -> "Concept diagram of relations in " ++ name pat
-                                      Dutch   -> "Conceptueel diagram van relaties in " ++ name pat
-                               }
-   PTIsaInPattern pat  -> Pict { pType = pr
-                               , scale = scale'
-                               , dotSource = conceptualGraph' fSpec flags pr
-                               , dotProgName = graphVizCmdForConceptualGraph
-                               , caption = 
-                                   case fsLang fSpec of
-                                      English -> "Classifications of " ++ name pat
-                                      Dutch   -> "Classificaties van " ++ name pat
-                               }
-   PTRelsUsedInPat pat -> Pict { pType = pr
-                               , scale = scale'
-                               , dotSource = conceptualGraph' fSpec flags pr
-                               , dotProgName = graphVizCmdForConceptualGraph
-                               , caption = 
-                                   case fsLang fSpec of
-                                      English -> "Concept diagram of the rules in " ++ name pat
-                                      Dutch   -> "Conceptueel diagram van de regels in " ++ name pat
-                               }
-   PTFinterface act    -> Pict { pType = pr
-                               , scale = scale'
-                               , dotSource = conceptualGraph' fSpec flags pr
-                               , dotProgName = graphVizCmdForConceptualGraph
-                               , caption = 
-                                   case fsLang fSpec of
-                                      English -> "Concept diagram of interface " ++ name act
-                                      Dutch   -> "Conceptueel diagram van interface " ++ name act
-                               }
-   PTSingleRule rul    -> Pict { pType = pr
-                               , scale = scale'
-                               , dotSource = conceptualGraph' fSpec flags pr
-                               , dotProgName = graphVizCmdForConceptualGraph
-                               , caption = 
-                                   case fsLang fSpec of
-                                      English -> "Concept diagram of rule " ++ name rul
-                                      Dutch   -> "Conceptueel diagram van regel " ++ name rul
-                               }
-   PTProcess fp        -> Pict { pType = pr
-                               , scale = scale'
-                               , dotSource = processModel fp
-                               , dotProgName = graphVizCmdForConceptualGraph
-                               , caption = 
-                                   case fsLang fSpec of
-                                      English -> "Process model of " ++ name fp
-                                      Dutch   -> "Procesmodel van " ++ name fp
-                               }
-   PTSwitchBoard act   -> Pict { pType = pr
-                               , scale = scale'
-                               , dotSource = sbdotGraph (switchboardAct fSpec act)
-                               , dotProgName = graphVizCmdForConceptualGraph
-                               , caption = 
-                                   case fsLang fSpec of
-                                      English -> "Switchboard diagram of " ++ name act
-                                      Dutch   -> "Schakelpaneel van " ++ name act
-                               }
- where
-   scale' =
-      case pr of
-            PTClassDiagram -> "1.0"
-            PTRelsUsedInPat{}-> "0.7"
-            PTDeclaredInPat{}-> "0.5"
-            PTProcess{}      -> "0.4"
-            PTSwitchBoard{}  -> "0.4"
-            PTIsaInPattern{} -> "0.7"
-            PTSingleRule{}   -> "0.7"
-            PTConcept{}      -> "0.7"
-            PTFinterface{}   -> "0.7"
-            PTLogicalDM    -> "0.7"
-            PTTechnicalDM  -> "0.7"
-   graphVizCmdForConceptualGraph = Sfdp
-   
-pictureID :: PictureReq -> String
-pictureID pr = 
-     case pr of
-      PTClassDiagram   -> "Classification"
-      PTLogicalDM      -> "LogicalDataModel"
-      PTTechnicalDM    -> "TechnicalDataModel"
-      PTConcept cpt    -> "RulesWithConcept"++name cpt
-      PTDeclaredInPat pat -> "RelationsInPattern"++name pat
-      PTIsaInPattern  pat -> "IsasInPattern"++name pat
-      PTRelsUsedInPat pat -> "RulesInPattern"++name pat
-      PTProcess fp        -> "ProcessModel"++name fp
-      PTFinterface act    -> "KnowledgeGraph"++name act
-      PTSwitchBoard x     -> "SwitchBoard"++name x
-      PTSingleRule r      -> "SingleRule"++name r
-
-conceptualGraph' :: Fspc -> Options -> PictureReq -> DotGraph String
-conceptualGraph' fSpec flags pr = conceptual2Dot flags cstruct
-  where 
-    cstruct =
-      case pr of 
-        PTConcept c -> 
-          let gs = fsisa fSpec 
-              cpts' = concs rs
-              rs    = [r | r<-udefrules fSpec, c `elem` concs r]
-          in
-          CStruct { csCpts = nub$cpts' ++ [g |(s,g)<-gs, elem g cpts' || elem s cpts'] ++ [s |(s,g)<-gs, elem g cpts' || elem s cpts']
-                  , csRels = [r | r@Sgn{} <- relsMentionedIn rs   -- the use of "relsMentionedIn" restricts relations to those actually used in rs
-                             , not (isProp r)
-                             ]
-                  , csIdgs = [(s,g) |(s,g)<-gs, elem g cpts' || elem s cpts']  --  all isa edges
-                  }
-        --  PTRelsUsedInPat makes a picture of at least the relations within pat; 
-        --  extended with a limited number of more general concepts;
-        --  and rels to prevent disconnected concepts, which can be connected given the entire context.
-        PTRelsUsedInPat pat ->
-          let orphans = [c | c<-cpts, not(c `elem` map fst idgs || c `elem` map snd idgs || c `elem` map source rels  || c `elem` map target rels)]
-              xrels = nub [r | c<-orphans, r@Sgn{}<-relsDefdIn fSpec
-                        , (c == source r && target r `elem` cpts) || (c == target r  && source r `elem` cpts)
-                        , source r /= target r, decusr r
-                        ]
-              idgs = [(s,g) |(s,g)<-gs, g `elem` cpts, s `elem` cpts]    --  all isa edges within the concepts
-              gs   = fsisa fSpec 
-              cpts = cpts' `uni` [g |cl<-eqCl id [g |(s,g)<-gs, s `elem` cpts'], length cl<3, g<-cl] -- up to two more general concepts
-              cpts' = concs pat `uni` concs rels
-              rels = [r | r@Sgn{}<-relsMentionedIn pat
-                             , not (isProp r)    -- r is not a property
-                             ]
-          in
-          CStruct { csCpts = cpts' `uni` [g |cl<-eqCl id [g |(s,g)<-gs, s `elem` cpts'], length cl<3, g<-cl] -- up to two more general concepts
-                  , csRels = rels `uni` xrels -- extra rels to connect concepts without rels in this picture, but with rels in the fSpec
-                  , csIdgs = idgs
-                  }
-
-        -- PTDeclaredInPat makes a picture of relations and gens within pat only 
-        PTDeclaredInPat pat ->
-          let gs   = fsisa fSpec
-              cpts = concs decs `uni` concs (gens pat)
-              decs = relsDefdIn pat `uni` relsMentionedIn (udefrules pat)
-          in
-          CStruct { csCpts = cpts
-                  , csRels = [r | r@Sgn{}<-decs
-                             , not (isProp r), decusr r    -- r is not a property
-                             ]
-                  , csIdgs = [(s,g) |(s,g)<-gs, g `elem` cpts, s `elem` cpts]    --  all isa edges within the concepts
-                  }
-        PTIsaInPattern pat ->
-          let gs    = fsisa fSpec
-              cpts  = concs edges
-              cpts' = concs pat >- concs gs
-              edges = clos gs idgs
-              idgs  = [(s,g) |(s,g)<-gs, elem g cpts' || elem s cpts']  --  all isa edges
-              clos tuples ts = f (tuples>-ts) ts []
-               where f  []  new result = result++new
-                     f  _   []  result = result
-                     f tups new result = f (tups>-new) [ t |t<-tups, (not.null) (concs t `isc` concs result') ] result'
-                                             where result' = result++new
-          in
-          CStruct { csCpts = cpts
-                  , csRels = []
-                  , csIdgs = idgs
-                  }
-
-        PTFinterface ifc ->
-          let gs   = fsisa fSpec
-              cpts = nub $ cpts' ++ [c |(s,g)<-idgs, c<-[g,s]]
-              cpts'  = concs rs
-              rs         = [r | r<-udefrules fSpec, affected r]
-              affected r = (not.null) [d | d@Sgn{} <- relsMentionedIn r `isc` relsMentionedIn ifc]
-              idgs = [(s,g) |(s,g)<-gs, elem g cpts' || elem s cpts']  --  all isa edges
-              rels = [r | r@Sgn{}<-relsMentionedIn ifc, decusr r
-                        , not (isProp r)    -- r is not a property
-                     ]
-          in
-          CStruct { csCpts = cpts -- involve all concepts involved either in the affected rules or in the isa-links
-                  , csRels = rels
-                  , csIdgs = idgs -- involve all isa links from concepts touched by one of the affected rules
-                  }
-        PTSingleRule r ->
-          let idgs = [(s,g) | (s,g)<-fsisa fSpec
-                     , g `elem` concs r || s `elem` concs r]  --  all isa edges
-          in
-          CStruct { csCpts = nub $ concs r++[c |(s,g)<-idgs, c<-[g,s]]
-                  , csRels = [d | d@Sgn{}<-relsMentionedIn r, decusr d
-                             , not (isProp d)    -- d is not a property
-                             ]
-                  , csIdgs = idgs -- involve all isa links from concepts touched by one of the affected rules
-                  }
-        _  -> fatal 276 "No conceptual graph defined for this type."  
-
-
-writePicture :: Options -> Picture -> IO()
-writePicture flags pict
-    = sequence_ (
-      [createDirectoryIfMissing True  (takeDirectory (imagePath flags pict)) | genAtlas flags ]++
-      [writeDot Canon  | {- genFspec flags || -} genAtlas flags ]++
---      [writeDot XDot   | genFspec flags || genAtlas flags ]++
-      [writeDot Png    | genFspec flags || genAtlas flags ]++
-      [writeDot Cmapx  |                   genAtlas flags ]
-          )
-   where 
-     writeDot :: GraphvizOutput
-              -> IO ()
-     writeDot  gvOutput  = 
-         do verboseLn flags ("Generating "++show gvOutput++" using "++show gvCommand++".")
-            path <- addExtension (runGraphvizCommand gvCommand (dotSource pict)) gvOutput ((dropExtension . imagePath flags) pict)
-            verboseLn flags (path++" written.")
-       where  gvCommand = dotProgName pict
-              
-             
-class ReferableFromPandoc a where
-  imagePath :: Options ->a -> FilePath   -- ^ the full file path to the image file
-
-instance ReferableFromPandoc Picture where
-  imagePath flags p = 
-     (if genAtlas flags then dirPrototype flags </> "images" else dirOutput flags)
-     </> (escapeNonAlphaNum . pictureID . pType ) p <.> "png"
-
-class Identified a => Navigatable a where
-   interfacename :: a -> String 
-   itemstring :: a -> String 
-   theURL :: Options -> a -> EscString    -- url of the web page in Atlas used when clicked on a node or edge in a .map file
-   theURL flags x 
-     = fromString ("Atlas.php?content=" ++ interfacename x
-                   ++  "&User=" ++ user
-                   ++  "&Script=" ++ script
-                   ++  "&"++interfacename x ++"="++qualify++itemstring x
-                  )
-      where --copied from atlas.hs
-      script = fileName flags
-      user = namespace flags
-      qualify = "("++user ++ "." ++ script ++ ")"  
-
-
-instance Navigatable A_Concept where
-   interfacename _ = "Concept" --see Atlas.adl
-   itemstring = name  --copied from atlas.hs
- 
-instance Navigatable Declaration where 
-   interfacename _ = "Relatiedetails"
-   itemstring x = name x ++ "["
-                  ++ (if source x==target x then name(source x) else name(source x)++"*"++name(target x))
-                  ++ "]"
-
-
-
-data ConceptualStructure = CStruct { csCpts :: [A_Concept]               -- ^ The concepts to draw in the graph
-                                   , csRels :: [Declaration]   -- ^ The relations, (the edges in the graph)
-                                   , csIdgs :: [(A_Concept, A_Concept)]  -- ^ list of Isa relations
-                                   }
-
-conceptual2Dot :: Options -> ConceptualStructure -> DotGraph String
-conceptual2Dot flags (CStruct cpts' rels idgs)
-     = DotGraph { strictGraph = False
-                , directedGraph = True
-                , graphID = Nothing
-                , graphStatements 
-                      = DotStmts { attrStmts = [GraphAttrs (handleFlags TotalPicture flags)]
-                                 , subGraphs = []
-                                 , nodeStmts = conceptNodes ++ relationNodes
-                                 , edgeStmts = relationEdges ++ isaEdges
-                                 }
-                }
-       where
-        cpts = cpts' `uni` concs rels `uni` concs idgs
-        conceptNodes = [constrNode (baseNodeId c) (CptOnlyOneNode c) flags | c<-cpts]
-        (relationNodes,relationEdges) = (concat a, concat b) 
-              where (a,b) = unzip [relationNodesAndEdges r | r<-zip rels [1..]]
-        isaEdges = [constrEdge (baseNodeId s) (baseNodeId g) IsaOnlyOneEdge  flags | (s,g)<-idgs]
-              
-        baseNodeId :: A_Concept -> String  -- returns the NodeId of the node where edges to this node should connect to. 
-        baseNodeId c 
-            = case lookup c (zip cpts [(1::Int)..]) of
-                Just i -> "cpt_"++show i
-                _      -> fatal 169 $ "element "++name c++" not found by nodeLabel."
-
-        -- | This function constructs a list of NodeStatements that must be drawn for a concept.
-        relationNodesAndEdges ::
-             (Declaration,Int)           -- ^ tuple contains the declaration and its rank
-          -> ([DotNode String],[DotEdge String]) -- ^ the resulting tuple contains the NodeStatements and EdgeStatements
-        relationNodesAndEdges (r,n)
-          | doubleEdges flags
-             = (  [ relNameNode ]    -- node to place the name of the relation
-               ,  [ constrEdge (baseNodeId (source r)) (nodeID relNameNode)   (RelSrcEdge r) flags     -- edge to connect the source with the hinge
-                  , constrEdge (nodeID relNameNode)   (baseNodeId (target r)) (RelTgtEdge r) flags]     -- edge to connect the hinge to the target
-               )
-          | otherwise
-               = ( [] --No intermediate node
-                 , [constrEdge (baseNodeId (source r)) (baseNodeId (target r)) (RelOnlyOneEdge r)  flags]
-                 )
-          where
-        --    relHingeNode   = constrNode ("relHinge_"++show n) RelHingeNode   flags
-            relNameNode    = constrNode ("relName_"++show n) (RelIntermediateNode r) flags
-                                   
-constrNode :: a -> PictureObject -> Options -> DotNode a
-constrNode nodeId pObj flags
-  = DotNode { nodeID = nodeId
-            , nodeAttributes = [ FontSize 10
-                               , FontName (fromString(pangoFont flags))
-                           --    , Width 0.1
-                           --    , Height  0.1
-                               ]++handleFlags pObj flags
-            }
-
-constrEdge :: a -> a -> PictureObject -> Options -> DotEdge a
-constrEdge nodeFrom nodeTo pObj flags 
-  = DotEdge { fromNode = nodeFrom
-            , toNode   = nodeTo
-            , edgeAttributes = [ FontSize 12
-                               , FontName (fromString(pangoFont flags))
-                               , Dir Forward
-                            --   , LabelAngle (-25.0)
-                               , Color [WC(X11Color Gray35)Nothing]
-                               , LabelFontColor (X11Color Black)
-                               , LabelFloat False
-                               , Decorate False
-                            --   , LabelDistance 2.0
-                            --   , (HeadLabel . StrLabel . fromString) "Test"
-                               ]++handleFlags pObj flags
-            }
---DESCR -> a picture consists of arcs (relations), concepts, and ISA relations between concepts
---         arcs are attached to a source or target concept
---         arcs and concepts are points attached to a label
--- for Haddock support on GraphViz, click on:
---       http://hackage.haskell.org/packages/archive/graphviz/2999.6.0.0/doc/html/doc-index.html     or
---       http://hackage.haskell.org/packages/archive/graphviz/latest/doc/html/doc-index.html
-
-data PictureObject = CptOnlyOneNode A_Concept    -- ^ Node of a concept that serves as connector and shows the name
-                   | CptConnectorNode A_Concept  -- ^ Node of a concept that serves as connector of relations to that concept
-                   | CptNameNode A_Concept       -- ^ Node of a concept that shows the name
-                   | CptEdge                     -- ^ Edge of a concept to connect its nodes
-                   | RelOnlyOneEdge Declaration  -- ^ Edge of a relation that connects to the source and the target
-                   | RelSrcEdge     Declaration  -- ^ Edge of a relation that connects to the source
-                   | RelTgtEdge     Declaration  -- ^ Edge of a relation that connects to the target
-                   | RelIntermediateNode    Declaration  -- ^ Intermediate node, as a hindge for the relation edges
-                   | IsaOnlyOneEdge              -- ^ Edge of an ISA relation without a hinge node
-                   | TotalPicture                -- ^ Graph attributes
-         
-handleFlags :: PictureObject  -> Options -> [Attribute]
-handleFlags po flags = 
-    case po of
-      CptConnectorNode c 
-         -> if crowfoot flags
-            then 
-                 [ (Label . StrLabel . fromString . name) c
-                 , Shape PlainText
-                 , Style [filled]
-                 , URL (theURL flags c)
-                 ]
-            else [ Shape PointShape
-                 , Style [filled]
-                 ]
-      CptNameNode c  -> if crowfoot flags
-                        then [ Shape PointShape
-                             , Style [invis]]
-                        else 
-                             [ (Label . StrLabel . fromString . name) c
-                             , Shape PlainText
-                             , Style [filled]
-                             , URL (theURL flags c)
-                             ]
-      CptEdge    -> [Style [invis]
-                    ]
-      CptOnlyOneNode c -> 
-                          [(Label . StrLabel . fromString . name) c
-                          , Shape BoxShape
-                          , Style [filled] 
-                          , URL (theURL flags c)
-                          ]
-      RelOnlyOneEdge r -> [ URL (theURL flags r)
-                          , (XLabel . StrLabel .fromString.name) r
-                          ]
-                    --    ++[ (HeadLabel . StrLabel .fromString) "1" | isTot r && isUni r]
-                    --    ++[ (TailLabel . StrLabel .fromString) "1" | isSur r && isInj r]
-                        ++[ ArrowTail noArrow, ArrowHead noArrow
-                          , Dir Forward  -- Note that the tail arrow is not supported , so no crowfoot notation possible with a single edge.
-                          , Style [SItem Tapered []] , PenWidth 5
-                          ]
-      RelSrcEdge r -> [ ArrowHead ( if crowfoot flags  then normal                    else
-                                    if isFunction r    then noArrow                   else
-                                    if isInvFunction r then noArrow                   else
-                                    noArrow
-                                  )
-                      , ArrowTail ( if crowfoot flags  then crowfootArrowType False r else
-                                    if isFunction r    then noArrow                   else
-                                    if isInvFunction r then normal                    else
-                                    noArrow
-                                  )
-                      ,HeadClip False
-                --      , Dir Both  -- Needed because of change in graphviz. See http://www.graphviz.org/bugs/b1951.html
-                      ]
-      RelTgtEdge r -> [ (Label . StrLabel . fromString . name) r
-                      , ArrowHead ( if crowfoot flags  then crowfootArrowType True r  else
-                                    if isFunction r    then normal                    else
-                                    if isInvFunction r then noArrow                   else
-                                    noArrow
-                                  )
-                      , ArrowTail ( if crowfoot flags  then noArrow                   else
-                                    if isFunction r    then noArrow                   else
-                                    if isInvFunction r then AType [(noMod ,Inv)]      else
-                                    AType [(noMod ,Inv)]
-                                  )
-                   --   , Dir Both  -- Needed because of change in graphviz. See http://www.graphviz.org/bugs/b1951.html
-                      ,TailClip False
-                      ] 
-      RelIntermediateNode r -> 
-                       [ Label (StrLabel (fromString("")))
-                       , Shape PlainText
-                       , bgColor White
-                       , URL (theURL flags r) 
-                       ]
-      IsaOnlyOneEdge-> [ ArrowHead (AType [(open,Normal)])
-                       , ArrowTail noArrow
-                       , if blackWhite flags then Style [dotted] else Color [WC(X11Color Red)Nothing]
-                       ]
-      TotalPicture -> [ Sep (DVal (if doubleEdges flags then 1/2 else 2)) -- The minimal amount of whitespace between nodes
-                      , OutputOrder  EdgesFirst --make sure the nodes are always on top...
-                      , Overlap ScaleXYOverlaps
-                      , Splines PolyLine  -- SplineEdges could work as well.
-                      , Landscape False
-                      ]
-
-isInvFunction :: Declaration -> Bool
-isInvFunction d = isInj d && isSur d
-
-
-crowfootArrowType :: Bool -> Declaration -> ArrowType
-crowfootArrowType isHead r 
-   = AType (case isHead of
-               True  -> getCrowfootShape (isUni r) (isTot r)
-               False -> getCrowfootShape (isInj r) (isSur r)
-           )
-       where 
-         getCrowfootShape :: Bool -> Bool -> [( ArrowModifier , ArrowShape )]
-         getCrowfootShape a b =
-           case (a,b) of
-            (True ,True ) -> [my_tee          ]
-            (False,True ) -> [my_crow, my_tee ]
-            (True ,False) -> [my_odot, my_tee ]
-            (False,False) -> [my_crow, my_odot]
-             
-         my_tee :: ( ArrowModifier , ArrowShape )
-         my_tee = ( noMod , Tee )
-         my_odot :: ( ArrowModifier , ArrowShape )
-         my_odot= ( open, DotArrow )
-         my_crow :: ( ArrowModifier , ArrowShape )
-         my_crow= ( open, Crow )
-
-noMod :: ArrowModifier
-noMod = ArrMod { arrowFill = FilledArrow
-               , arrowSide = BothSides
-               }
-open :: ArrowModifier
-open  = noMod {arrowFill = OpenArrow}

− src/lib/DatabaseDesign/Ampersand/Fspec/Motivations.hs 
@@ -1,399 +0,0 @@-{-# OPTIONS_GHC -Wall #-}
---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
-module DatabaseDesign.Ampersand.Fspec.Motivations (Motivated(purposeOf,purposesDefinedIn,explanations,explForObj), Meaning(..))
-where
-import DatabaseDesign.Ampersand.Core.AbstractSyntaxTree
-import DatabaseDesign.Ampersand.Fspec.Fspec(Fspc(..),FProcess(..), Activity(..)) -- TODO FProc should not be in here at the first place... It has been put here because of the removal of Activities from Process
-import DatabaseDesign.Ampersand.Basics
-import Text.Pandoc
-
-fatal :: Int -> String -> a
-fatal = fatalMsg "Fspec.Motivations"
-
-
--- The general idea is that an Ampersand declaration such as:
---     PURPOSE RELATION r[A*B] IN ENGLISH
---     {+This text explains why r[A*B] exists-}
--- produces the exact right text in the functional specification
-
--- The class Motivated exists so that we can write the Haskell expression 'purposeOf fSpec l x'
--- anywhere we like for every type of x that could possibly be motivated in an Purpose.
--- 'purpose fSpec l x' produces all explanations related to x from the context (fSpec)
---  that are available in the language specified in 'l'.
--- The other functions in this class are solely meant to be used in the definition of purpose.
--- They are defined once for each instance of Explainable, not be used in other code.
--- TODO: Han, kan dat worden afgeschermd, zodat de programmeur alleen 'purpose' ziet en de andere functies
---       dus niet kan gebruiken?
---     @Stef: Ja, het is al zoveel mogelijk afgeschermd (zie definities die deze module exporteert, hierboven)
---     maar er wordt nog gebruik van gemaakt voor oa foutmeldingen in de atlas, en het prototype.
---     Zodra iemand iets anders verzint voor het gebruik van "ExplainOutputFormat(..),format",
---     kunnen deze uit de export-list van deze module worden verwijderd.
-class  Identified a => Motivated a where 
-  purposeOf :: Fspc -> Lang -> a -> Maybe [Purpose] -- ^ explains the purpose of a, i.e. the reason why a exists. The purpose could be either given by the user, or generated by Ampersand. 
-                                                    --   Multiple purposes are allowed for the following reasons:
-                                                    --  * Different purposes from different sources make me want to document them all.
-                                                    --  * Combining two overlapping scripts from (i.e. from different authors) may cause multiple purposes.
-  purposeOf fSpec l x = case expls of
-                        []  -> Nothing -- fatal 40 "No purpose is generated! (should be automatically generated and available in Fspc.)"
-                        ps  -> Just ps
-                        
-   where expls = [e | e<-explanations fSpec
-                    , explForObj x (explObj e)                  -- informally: "if x and e are the same"
-                    , markupMatchesLang (explMarkup e)
-                 ] 
-         markupMatchesLang m = amLang m == l
-  explForObj :: a -> ExplObj -> Bool    -- ^ Given an Explainable object and an ExplObj, return TRUE if they concern the identical object.
-  explanations :: a -> [Purpose]  -- ^ The explanations that are defined inside a (including that of a itself)
-  purposesDefinedIn :: Fspc -> Lang -> a -> [Purpose]  -- ^ The explanations that are defined inside a (including that of a itself)
-  purposesDefinedIn fSpec l x
-   = [e | e<-explanations fSpec
-        , amLang (explMarkup e) == l
-        , explForObj x (explObj e)                  -- informally: "if x and e are the same"
-     ]
-instance Motivated ConceptDef where
---  meaning _ cd = fatal 49 ("Concept definitions have no intrinsic meaning, (used with concept definition of '"++cdcpt cd++"')")
-  explForObj x (ExplConceptDef x') = x == x'
-  explForObj _ _ = False
-  explanations _ = []
-  
-instance Motivated A_Concept where
---  meaning _ c = fatal 54 ("Concepts have no intrinsic meaning, (used with concept '"++name c++"')")
-  explForObj x (ExplConceptDef cd) = name x == name cd
-  explForObj _ _ = False
-  explanations _ = []
-
-instance Motivated Declaration where
---  meaning l decl = if null (decMean decl)
---                   then concat [explCont expl | expl<-autoMeaning l decl, Just l == explLang expl || Nothing == explLang expl]
---                   else decMean decl
-  explForObj d1 (ExplDeclaration d2) = d1 == d2 
-  explForObj _ _ = False
-  explanations _ = []
---  autoMeaning lang d
---   = [Expl { explPos   = decfpos d
---           , explObj   = ExplDeclaration d 
---           , explLang  = Just lang
---           , explRefIds = []
---           , explCont  = [Para langInlines]
---           } ] 
---     where 
---      langInlines =
---       case lang of
---         English 
---              | null ([Sym,Asy]         >- multiplicities d) -> [Emph [Str (name d)]]
---                                                              ++[Str " is a property of a "]
---                                                              ++[Str ((unCap.name.source) d)]
---                                                              ++[Str "."]
---              | null ([Sym,Rfx,Trn]     >- multiplicities d) -> [Emph [Str (name d)]]
---                                                              ++[Str " is an equivalence relation on "]
---                                                              ++[Str ((unCap.plural English .name.source) d)]
---                                                              ++[Str "."]
---              | null ([Asy,Trn]         >- multiplicities d) -> [Emph [Str (name d)]]
---                                                              ++[Str " is an ordering relation on "]
---                                                              ++[Str ((unCap.plural English .name.source) d)]
---                                                              ++[Str "."]
---              | null ([Uni,Tot,Inj,Sur] >- multiplicities d) -> applyM d [Str ("each "++(unCap.name.source) d)]
---                                                                         [Str ("exactly one "++(unCap.name.target) d)]
---                                                              ++[Str " and vice versa."]
---              | null ([Uni,Tot,Inj    ] >- multiplicities d) -> applyM d [Str ("each "++(unCap.name.source) d)]
---                                                                         [Str ("exactly one "++(unCap.name.target) d)]
---                                                              ++[Str ", but not for each "]
---                                                              ++[Str ((unCap.name.target) d++" there must be a "++(unCap.name.source) d)]
---                                                              ++[Str "."]
---              | null ([Uni,Tot,    Sur] >- multiplicities d) -> applyM d [Str ("each "++(unCap.name.source) d)]
---                                                                         [Str ("exactly one "++(unCap.name.target) d)]
---                                                              ++[Str ", but each "]
---                                                              ++[Str ((unCap.name.target) d++" is related to one or more "++(unCap.plural English .name.source) d)]
---                                                              ++[Str "."]
---              | null ([Uni,    Inj,Sur] >- multiplicities d) -> [Str ("There is exactly one "++(unCap.name.source) d++" (")]
---                                                              ++[Math InlineMath "a"]
---                                                              ++[Str (") for each "++(unCap.name.target) d++" (")]
---                                                              ++[Math InlineMath "b"]
---                                                              ++[Str "), for which: "]
---                                                              ++applyM d [Math InlineMath "b"] [Math InlineMath "a"]
---                                                              ++[Str (", but not for each "++(unCap.name.source) d++" there must be a "++(unCap.name.target) d++".")]
---              | null ([    Tot,Inj,Sur] >- multiplicities d) -> [Str ("There is exactly one "++(unCap.name.source) d++" (")]
---                                                              ++[Math InlineMath "a"]
---                                                              ++[Str (") for each "++(unCap.name.target) d++" (")]
---                                                              ++[Math InlineMath "b"]
---                                                              ++[Str "), for which: "]
---                                                              ++applyM d [Math InlineMath "b"] [Math InlineMath "a"]
---                                                              ++[Str (", but each "++(unCap.name.source) d++" is related to one or more "++(unCap.plural English .name.target) d)]
---                                                              ++[Str "."]
---              | null ([Uni,Tot        ] >- multiplicities d) -> applyM d [Str ("each "++(unCap.name.source) d)]
---                                                                         [Str ("exactly one "++(unCap.name.target) d)]
---                                                              ++[Str "."]
---              | null ([Uni,    Inj    ] >- multiplicities d) -> applyM d [Str ("each "++(unCap.name.source) d)]
---                                                                         [Str ("at most one "++(unCap.name.target) d)]
---                                                              ++[Str (" and each "++(unCap.name.target) d++" is related to at most one "++(unCap.name.source) d)]
---                                                              ++[Str "."]
---              | null ([Uni,        Sur] >- multiplicities d) -> applyM d [Str ("each "++(unCap.name.source) d)]
---                                                                         [Str ("at most one "++(unCap.name.target) d)]
---                                                              ++[Str (", whereas each "++(unCap.name.target) d++" is related to at least one "++(unCap.name.source) d)]
---                                                              ++[Str "."]
---              | null ([    Tot,Inj    ] >- multiplicities d) -> applyM d [Str ("each "++(unCap.name.source) d)]
---                                                                         [Str ("at least one "++(unCap.name.target) d)]
---                                                              ++[Str (", whereas each "++(unCap.name.target) d++" is related to at most one "++(unCap.name.source) d)]
---                                                              ++[Str "."]
---              | null ([    Tot,    Sur] >- multiplicities d) -> applyM d [Str ("each "++(unCap.name.source) d)]
---                                                                         [Str ("at least one "++(unCap.name.target) d)]
---                                                              ++[Str (" and each "++(unCap.name.target) d++" is related to at least one "++(unCap.name.source) d)]
---                                                              ++[Str "."]
---              | null ([        Inj,Sur] >- multiplicities d) -> [Str ("There is exactly one "++(unCap.name.source) d++" (")]
---                                                              ++[Math InlineMath "a"]
---                                                              ++[Str (") for each "++(unCap.name.target) d++" (")]
---                                                              ++[Math InlineMath "b"]
---                                                              ++[Str "), for which: "]
---                                                              ++applyM d [Math InlineMath "b"] [Math InlineMath "a"]
---                                                              ++[Str "."]
---              | null ([            Sur] >- multiplicities d) -> [Str ("There is at least one "++(unCap.name.source) d++" (")]
---                                                              ++[Math InlineMath "a"]
---                                                              ++[Str (") for each "++(unCap.name.target) d++" (")]
---                                                              ++[Math InlineMath "b"]
---                                                              ++[Str "), for which: "]
---                                                              ++applyM d [Math InlineMath "b"] [Math InlineMath "a"]
---                                                              ++[Str "."]
---              | null ([        Inj    ] >- multiplicities d) -> [Str ("There is at most one "++(unCap.name.source) d++" (")]
---                                                              ++[Math InlineMath "a"]
---                                                              ++[Str (") for each "++(unCap.name.target) d++" (")]
---                                                              ++[Math InlineMath "b"]
---                                                              ++[Str "), for which: "]
---                                                              ++applyM d [Math InlineMath "b"] [Math InlineMath "a"]
---                                                              ++[Str "."]
---              | null ([    Tot        ] >- multiplicities d) -> applyM d [Str ("each "++(unCap.name.source) d)]
---                                                                         [Str ("at least one "++(unCap.name.target) d)]
---                                                              ++[Str "."]
---              | null ([Uni            ] >- multiplicities d) -> applyM d [Str ("each "++(unCap.name.source) d)]
---                                                                         [Str ("zero or one "++(unCap.name.target) d)]
---                                                              ++[Str "."]
---              | otherwise                                    -> [Str "The sentence: "]
---                                                              ++[Quoted DoubleQuote 
---                                                                  (applyM d [Math InlineMath ((var [].source) d)]
---                                                                            [Math InlineMath ((var [source d].target) d)])
---                                                                ]
---                                                              ++[Str (" is meaningful (i.e. it is either true or false) for any "++(unCap.name.source) d++" ")]
---                                                              ++[(Math InlineMath . var [] . source) d]
---                                                              ++[Str (" and "++(unCap.name.target) d++" ")]
---                                                              ++[(Math InlineMath . var [source d] . target) d]
---                                                              ++[Str "."]
---         Dutch
---              | null ([Sym,Asy]         >- multiplicities d) -> [Emph [Str (name d)]]
---                                                              ++[Str " is een eigenschap van een "]
---                                                              ++[Str ((unCap.name.source) d)]
---                                                              ++[Str "."]
---              | null ([Sym,Rfx,Trn]     >- multiplicities d) ->[Emph [Str (name d)]]
---                                                              ++[Str " is een equivalentierelatie tussen "]
---                                                              ++[Str ((unCap.plural Dutch .name.source) d)]
---                                                              ++[Str "."]
---              | null ([Asy,Trn]         >- multiplicities d) ->[Emph [Str (name d)]]
---                                                              ++[Str " is een ordeningsrelatie tussen "]
---                                                              ++[Str ((unCap.plural Dutch .name.source) d)]
---                                                              ++[Str "."]
---              | null ([Uni,Tot,Inj,Sur] >- multiplicities d) -> applyM d [Str ("elke "++(unCap.name.source) d)]
---                                                                              [Str ("precies één "++(unCap.name.target) d)]
---                                                              ++[Str " en vice versa."]
---              | null ([Uni,Tot,Inj]     >- multiplicities d) -> applyM d [Str ("elke "++(unCap.name.source) d)]
---                                                                         [Str ("precies één "++(unCap.name.target) d)]
---                                                              ++[Str ", maar niet voor elke "]
---                                                              ++[Str ((unCap.name.target) d)]
---                                                              ++[Str " hoeft er een "]
---                                                              ++[Str ((unCap.name.source) d)]
---                                                              ++[Str " te zijn."]
---              | null ([Uni,Tot,    Sur] >- multiplicities d) -> applyM d [Str ("elke "++(unCap.name.source) d)]
---                                                                         [Str ("precies één "++(unCap.name.target) d)]
---                                                              ++[Str ", maar elke "]
-----                                                            ++[Str ((unCap.name.target) d)]
---                                                              ++[Str (" is gerelateerd aan één of meer ")]
---                                                              ++[Str ((unCap.plural Dutch .name.source) d)]
---                                                              ++[Str "."]
---              | null ([Uni,    Inj,Sur] >- multiplicities d) -> [Str ("Er is precies één "++(unCap.name.source) d++" (")]
---                                                              ++[Math InlineMath "a"]
---                                                              ++[Str (") voor elke "++(unCap.name.target) d++" (")]
---                                                              ++[Math InlineMath "b"]
---                                                              ++[Str "), waarvoor geldt: "]
---                                                              ++applyM d [Math InlineMath "b"] [Math InlineMath "a"]
---                                                              ++[Str (", maar niet voor elke "++(unCap.name.source) d++" hoeft er een "++(unCap.name.target) d++" te zijn.")]
---              | null ([    Tot,Inj,Sur] >- multiplicities d) -> [Str ("Er is precies één "++(unCap.name.source) d++" (")]
---                                                              ++[Math InlineMath "a"]
---                                                              ++[Str (") voor elke "++(unCap.name.target) d++" (")]
---                                                              ++[Math InlineMath "b"]
---                                                              ++[Str "), waarvoor geldt: "]
---                                                              ++applyM d [Math InlineMath "b"] [Math InlineMath "a"]
---                                                              ++[Str (", maar elke "++(unCap.name.source) d++" mag gerelateerd zijn aan meerdere "++(unCap.plural Dutch .name.target) d++".")]
---              | null ([Uni,Tot        ] >- multiplicities d) -> applyM d [Str ("elke "++(unCap.name.source) d)]
---                                                                         [Str ("precies één "++(unCap.name.target) d)]
---                                                              ++[Str "."]
---              | null ([Uni,    Inj    ] >- multiplicities d) -> applyM d [Str ("elke "++(unCap.name.source) d)]
---                                                                         [Str ("ten hoogste één "++(unCap.name.target) d)]
---                                                              ++[Str " en elke "]
---                                                              ++[Str ((unCap.name.target) d)]
---                                                              ++[Str (" is gerelateerd aan ten hoogste één ")]
---                                                              ++[Str ((unCap.name.source) d++".")]
---                                                              ++[Str "."]
---              | null ([Uni,        Sur] >- multiplicities d) -> applyM d [Str ("elke "++(unCap.name.source) d)]
---                                                                         [Str ("ten hoogste één "++(unCap.name.target) d)]
---                                                              ++[Str ", terwijl elke "]
---                                                              ++[Str ((unCap.name.target) d)]
---                                                              ++[Str (" is gerelateerd aan tenminste één ")]
---                                                              ++[Str ((unCap.name.source) d)]
---                                                              ++[Str "."]
---              | null ([    Tot,Inj    ] >- multiplicities d) -> applyM d [Str ("elke "++(unCap.name.source) d)]
---                                                                         [Str ("tenminste één "++(unCap.name.target) d)]
---                                                              ++[Str ", terwijl elke "]
---                                                              ++[Str ((unCap.name.target) d)]
---                                                              ++[Str (" is gerelateerd aan ten hoogste één ")]
---                                                              ++[Str ((unCap.name.source) d)]
---                                                              ++[Str "."]
---              | null ([    Tot,    Sur] >- multiplicities d) -> applyM d [Str ("elke "++(unCap.name.source) d)]
---                                                                         [Str ("tenminste één "++(unCap.name.target) d)]
---                                                              ++[Str (" en elke "++(unCap.name.target) d++" is gerelateerd aan tenminste één "++(unCap.name.source) d++".")]
---              | null ([        Inj,Sur] >- multiplicities d) -> [Str ("Er is precies één "++(unCap.name.source) d++" (")]
---                                                              ++[Math InlineMath "a"]
---                                                              ++[Str (") voor elke "++(unCap.name.target) d++" (")]
---                                                              ++[Math InlineMath "b"]
---                                                              ++[Str "), waarvoor geldt: "]
---                                                              ++applyM d [Math InlineMath "b"] [Math InlineMath "a"]
---                                                              ++[Str "."]
---              | null ([            Sur] >- multiplicities d) -> [Str ("Er is tenminste één "++(unCap.name.source) d++" (")]
---                                                              ++[Math InlineMath "a"]
---                                                              ++[Str (") voor elke "++(unCap.name.target) d++" (")]
---                                                              ++[Math InlineMath "b"]
---                                                              ++[Str "), waarvoor geldt: "]
---                                                              ++applyM d [Math InlineMath "b"] [Math InlineMath "a"]
---                                                              ++[Str "."]
---              | null ([        Inj    ] >- multiplicities d) -> [Str ("Er is hooguit één "++(unCap.name.source) d++" (")]
---                                                              ++[Math InlineMath "a"]
---                                                              ++[Str (") voor elke "++(unCap.name.target) d++" (")]
---                                                              ++[Math InlineMath "b"]
---                                                              ++[Str "), waarvoor geldt: "]
---                                                              ++applyM d [Math InlineMath "b"] [Math InlineMath "a"]
---                                                              ++[Str "."]
---              | null ([    Tot        ] >- multiplicities d) -> applyM d [Str ("elke "++(unCap.name.source) d)]
---                                                                         [Str ("tenminste één "++(unCap.name.target) d)]
---                                                              ++[Str "."]
---              | null ([Uni            ] >- multiplicities d) -> applyM d [Str ("elke "++(unCap.name.source) d)]
---                                                                         [Str ("nul of één "++(unCap.name.target) d)]
---                                                              ++[Str "."]
---              | otherwise                                    -> [Str "De zin: "]
---                                                              ++[Quoted DoubleQuote 
---                                                                  (applyM d [(Math InlineMath . var [] . source) d]
---                                                                            [(Math InlineMath . var [source d] . target) d])
---                                                                ]
---                                                              ++[Str (" heeft betekenis (dus: is waar of niet waar) voor een "++(unCap.name.source) d++" ")]
---                                                              ++[(Math InlineMath . var [].source) d]
---                                                              ++[Str (" en een "++(unCap.name.target) d++" ")]
---                                                              ++[(Math InlineMath . var [source d].target) d]
---                                                              ++[Str "."]
---
---      applyM :: Declaration -> [Inline] -> [Inline] -> [Inline]
---      applyM decl a b =
---               case decl of
---                 Sgn{} | null (prL++prM++prR) 
---                            -> a++[Space,Str "corresponds",Space,Str "to",Space]++b++[Space,Str "in",Space,Str "relation",Space,Str(decnm decl)]
---                       | null prL
---                            -> a++[Space,Str prM,Space]++b++[Space,Str prR]
---                       | otherwise 
---                            -> [Str (upCap prL),Space]++a++[Space,Str prM,Space]++b++if null prR then [] else [Space,Str prR]
---                              where prL = decprL decl
---                                    prM = decprM decl
---                                    prR = decprR decl
---                 Isn{}     -> a++[Space,Str "equals",Space]++b
---                 Vs{}      -> [Str (show True)]
---            
---      var :: Identified a => [a] -> a -> String     -- TODO Vervangen door mkvar, uit predLogic.hs
---      var seen c = low c ++ ['\'' | c'<-seen, low c == low c']
---                      where low idt= if null (name idt) then "x" else [(toLower.head.name) idt]
-
-instance Motivated Rule where
---  meaning l rule
---   = head (expls++map explCont (autoMeaning l rule))
---     where
---        expls = [econt | Means l' econt<-rrxpl rule, l'==Just l || l'==Nothing]
-  explForObj x (ExplRule str) = name x == str
-  explForObj _ _ = False
-  explanations _ = []
---  autoMeaning lang r
---   = [Expl { explObj   = ExplRule (name r)
---           , explPos   = origin r
---           , explLang  = Just lang
---           , explRefIds = []
---           , explCont  = [Plain [RawInline (Text.Pandoc.Builder.Format "latex") (showPredLogic lang r++".")]] 
---           } ] 
-
-instance Motivated Theme where
-  explForObj (PatternTheme pat) eo = explForObj pat eo
-  explForObj (ProcessTheme prc) eo = explForObj prc eo
-  explanations (PatternTheme pat) = explanations pat
-  explanations (ProcessTheme prc) = explanations prc
-  
-instance Motivated Pattern where
---  meaning _ pat = fatal 324 ("Patterns have no intrinsic meaning, (used with pattern '"++name pat++"')")
-  explForObj x (ExplPattern str) = name x == str
-  explForObj _ _ = False
-  explanations = ptxps
-
-instance Motivated Process where
---  meaning _ prc = fatal 329 ("Processes have no intrinsic meaning, (used with process '"++name prc++"')")
-  explForObj x (ExplProcess str) = name x == str
-  explForObj _ _ = False
-  explanations = prcXps
-
-instance Motivated Interface where
---  meaning _ obj = fatal 342 ("Interfaces have no intrinsic meaning, (used with interface '"++name obj++"')")
-  explForObj x (ExplInterface str) = name x == str
-  explForObj _ _ = False
-  explanations _ = []
-
-class Meaning a where 
-  meaning :: Lang -> a -> Maybe A_Markup
-  meaning2Blocks :: Lang -> a -> [Block]
-  meaning2Blocks l a = case meaning l a of
-                         Nothing -> []
-                         Just m  -> amPandoc m 
-  
-instance Meaning Rule where
-  meaning l r = case filter isLang (ameaMrk (rrmean r)) of
-                  []   -> Nothing 
-                  [m]  -> Just m
-                  _    -> fatal 381 ("In the "++show l++" language, too many meanings given for rule "++name r ++".")
-                  where isLang m = l == amLang m
-  
-instance Meaning Declaration where
-  meaning l d = 
-    case d of
-      Sgn{} -> let isLang m = l == amLang m
-               in case filter isLang (ameaMrk (decMean d)) of
-                    []   -> Nothing 
-                    [m]  -> Just m
-                    _    -> fatal 388 ("In the "++show l++" language, too many meanings given for declaration "++name d ++".")
-      Isn{} -> fatal 370 "meaning is undefined for Isn"
-      Vs{}  -> fatal 371 "meaning is undefined for Vs"
-   
-instance Motivated Fspc where
---  meaning _ fSpec = fatal 329 ("No Fspc has an intrinsic meaning, (used with Fspc '"++name fSpec++"')")
-  explForObj x (ExplContext str) = name x == str
-  explForObj _ _ = False
-  explanations fSpec
-    = fSexpls fSpec ++
-      (concatMap explanations . vpatterns)  fSpec ++
-      (concatMap explanations . vprocesses) fSpec ++
-      (concatMap explanations . interfaceS) fSpec
-
-instance Motivated FProcess where
---  meaning l fp = meaning l (proc fp)
-  explForObj fp = explForObj (fpProc fp)
-  explanations fp = explanations (fpProc fp)
-
--- Ampersand allows multiple purposes for everything.
--- The diagnosis report must make mention of this (so the user will notice if (s)he reads the diagnosis).
--- Multiple purposes are simply concatenated, so the user sees them all.
-instance Motivated Activity where
-  explForObj _ _ = False
-  explanations activity = actPurp activity
-  purposeOf _ l x = case [ e | e <- actPurp x, amLang (explMarkup e) == l ] of
-                    []    -> Nothing
-                    purps -> Just purps
-
-
-   
− src/lib/DatabaseDesign/Ampersand/Fspec/Plug.hs 
@@ -1,406 +0,0 @@-{-# OPTIONS_GHC -Wall #-}--- SJC: is it possible to move this to the prototype part of ampersand? I mean,---      do functions like plugFields and plug-path really need to be here?---      perhaps we can at least move the largest part?-module DatabaseDesign.Ampersand.Fspec.Plug-     (Plugable(..), PlugInfo(..)-     ,SqlField(..)-     ,SqlFieldUsage(..)-     ,SqlType(..)-     ,showSQL-     ,requiredFields,requires,plugpath,eLkpTbl-     -     ,tblcontents-     ,fldauto-     ,isPlugIndex,kernelrels,attrels,bijectivefields-     ,PlugSQL(..)-     )-where-import DatabaseDesign.Ampersand.ADL1 -import DatabaseDesign.Ampersand.Classes (fullContents,atomsOf,Relational(..))-import DatabaseDesign.Ampersand.Basics-import Data.List(nub,transpose)-import GHC.Exts (sortWith)-import DatabaseDesign.Ampersand.Fspec.Fspec-import Prelude hiding (Ordering(..))--fatal :: Int -> String -> a-fatal = fatalMsg "Fspec.Plug"---------------------------------------------------Plug--------------------------------------------------TODO151210 -> define what a plug is and what it should do---Plugs are of the class Object just like Activities(??? => PHP plug isn't an instance of Object)---An Object is an entity to do things with like reading, updating, creating,deleting.---A Interface is an Object using only Plugs for reading and writing data; a Plug is a data service maintaining the rules for one object:--- + GEN Interface,Plug ISA Object--- + cando::Operation*Object--- + uses::Interface*Plug [TOT].--- + maintains::Plug*Rule.--- + signals::Interface*SignalRule.------Plugs can currently be implemented in PHP or SQL.---type Plugs = [Plug]---data Plug = PlugSql PlugSQL | PlugPhp PlugPHP deriving (Show,Eq)--class (Identified p, Eq p, Show p) => Plugable p where-  makePlug :: PlugInfo -> p-  -instance Plugable PlugSQL where-  makePlug (InternalPlug p) = p-  makePlug (ExternalPlug _) = fatal 112 "external plug is not Plugable"- ----------------------------------------------------PlugSQL--------------------------------------------------TblSQL, BinSQL, and ScalarSQL hold different entities. See their definition Fspec.hs----           all kernel fields can be related to an imaginary concept ID for the plug (a SqlField with type=SQLID)---             i.e. For all kernel fields k1,k2, where concept k1=A, concept k2=B, fldexpr k1=r~, fldexpr k2=s~---                  You can imagine :---                    - a relation value::ID->A[INJ] or value::ID->A[INJ,SUR]---                    - a relation value::ID->B[INJ] or value::ID->B[INJ,SUR]---                    such that s~=value~;value;r~ and r~=value~;value;s~---                    because value is at least uni,tot,inj, all NULL in k0 imply NULL in k1 xor v.v.---                    if value also sur then all NULL in k0 imply NULL in k1 and v.v.---           Without such an ID, the surjective or total property between any two kernel fields is required.---           Because you can imagine an ID concept the surjective or total property between two kernel field has become a design choice.------           With or without ID we choose to keep kernel = A closure of concepts A,B for which there exists a r::A->B[INJ] instead of r::A*B[UNI,INJ]---           By making this choice:---             - nice database table size---             - we do not need the imaginary concept ID  (and relation value::ID->A[INJ] or value::ID->A[INJ,SUR]), because:---                  with ID    -> there will always be one or more kernel field k1 such that (value;(fldexpr k1)~)[UNI,INJ,TOT,SUR].---                                any of those k1 can serve as ID of the plug (a.k.a. concept p / source p)---                  without ID -> any of those k1 can still serve as ID of the plug (a.k.a. concept p / source p)---               In other words, the imaginary concept is never needed ---                               because there always is an existing one with the correct properties by definition of kernel.---               Implementation without optional ID:---                        -> fldexpr of some kernel field k1 will be r~---                           k1 holds the target of r~---                           the source of r~ is a kernel concept too---                           r~ may be I---                        -> fldexpr of some attMor field a1 will be s---                           a1 holds the target of s---                           the source of s is a kernel concept---                        -> sqlRelFields r = (r,k1,a1) (or (r,k1,k2)) in mLkpTbl---                           is used to generate SQL code and PHP-objects without needing the ID field.---                           The ID field can be ignored and does not have to be generated because r=(fldexpr k1)~;(fldexpr a1)---                           You could generate the ID-field with autonum if you want, because it will not be used---                        -> TODO151210 -> sqlRelFields e where e is not in mLkpTbl---                           option1) Generate the ID field (see entityfield)---                                    sqlRelFields e = (e, idfld;k1, idfld;a1) where e=(fldexpr k1)~;value~;value;(fldexpr a1)---                                    remark: binary tables can be binary tables without kernels, but with ID field---                                            (or from a different perspective: ID is the only kernel field)---                                            sqlRelFields r = (r,idfld/\r;r~,idfld;m1) where r = (idfld/\r;r~)~;idfld;(fldexpr m1)---                                            (sqlRelFields r~  to get the target of r)---                                            (scalar tables can of course also have an ID field)---                           option2) sqlRelFields e = (e, k1;k2;..kn, a1) ---                                    where e=(fldexpr kn)~;..;(fldexpr k2)~;(fldexpr k1)~;(fldexpr k1)(fldexpr k2);..;(fldexpr kn);(fldexpr a1)---                           If I am right the function isTrue tries to support sqlRelFields e by ignoring the type error in kn;a1.---                           That is wrong! ----the entityfield is not implemented as part of the data type PlugSQL---It is a constant which may or may not be used (you may always imagine it)---TODO151210 -> generate the entityfield if options = --autoid -p---REMARK151210 -> one would expect I[entityconcept p], ---                but any p (as instance of Object) has one always existing concept p suitable to replace entityconcept p.---                concept p and entityconcept p are related uni,tot,inj,sur.----the entity stored in a plug is an imaginary concept, that is uni,tot,inj,sur with (concept p)---REMARK: there is a (concept p) because all kernel fields are related SUR with (concept p)-----Maintain rule: Object ObjectDef = Object (makeUserDefinedSqlPlug :: ObjectDef -> PlugSQL)---TODO151210 -> Build a check which checks this rule for userdefined/showADL generated plugs(::[ObjectDef]) ---TODO151210 -> The ObjectDef of a BinSQL plug for relation r is that:---           1) SQLPLUG mybinplug: r      , or---           2) SQLPLUG labelforsourcem : I /\ r;r~ --(or just I if r is TOT)---               = [labelfortargetm : r]---           The first option has been implemented in instance ObjectPlugSQL i.e. attributes=[], ctx=ERel r _-instance Object PlugSQL where- concept p = case p of-   TblSQL{mLkpTbl = []} -> fatal 263 $ "empty lookup table for plug "++name p++"."-   TblSQL{}             -> --TODO151210-> deze functieimplementatie zou beter moeten matchen met onderstaande beschrijving-                            --        nu wordt aangenomen dat de source van het 1e rel in mLkpTbl de source van de plug is.-                            --a relation between kernel concepts r::A*B is at least [UNI,INJ]-                            --to be able to point out one concept to be the source we are looking for one without NULLs in its field-                            -- i.e. there is a concept A such that-                            --      for all kernel field expr (s~)::B*C[UNI,INJ]:-                            --      s~ is total and there exists an expr::A*B[UNI,INJ,TOT,SUR] (possibly A=B => I[A][UNI,INJ,TOT,SUR]) -                            --If A is such a concept,-                            --   and A is not B,-                            --   and there exist an expr::A*B[UNI,INJ,TOT,SUR]-                            --then (concept PlugSQL{}) may be A or B-                            --REMARK -> (source p) used to be implemented as (source . fldexpr . head . fields) p. That is different!-                            head [source r |(r,_,_)<-mLkpTbl p]-   BinSQL{} -> source (mLkp p) --REMARK151210 -> the concept is actually ID such that I[ID]=I[source r]/\r;r~-   ScalarSQL{} -> cLkp p--- Usually source a==concept p. Otherwise, the attribute computation is somewhat more complicated. See ADL2Fspec for explanation about kernels.- attributes p@TblSQL{}-  = [ Obj (fldname tFld)                                                   -- objnm -          (Origin "This object is generated by attributes (Object PlugSQL)")                        -- objpos-          (if source a==concept p then a  else f (source a) [[a]])  -- objctx-          Nothing []                                                            -- objats and objstrs-    | (a,_,tFld)<-mLkpTbl p]-    where-     f c mms-      = case sortWith length stop of-         []  -> f c mms'  -- a path from c to a is not found (yet), so add another step to the recursion-         (hd:_) -> case hd of-                    []  -> fatal 201 "Empty head should be impossible."-                    _  -> case [(l,r) | (l,r)<-zip (init hd) (tail hd), target l/=source r] of-                            [] -> foldr1 (.:.) hd  -- pick the shortest path and turn it into an expression.-                            lrs -> fatal 204 ("illegal compositions " ++show lrs)-      where-        mms' = if [] `elem` mms -               then fatal 295 "null in mms."-               else [a:ms | ms<-mms, (a,_,_)<-mLkpTbl p, target a==source (head ms)]-        stop = if [] `elem` mms'-               then fatal 298 "null in mms'."-               else [ms | ms<-mms', source (head ms)==c]  -- contains all found paths from c to a - attributes _ = [] --no attributes for BinSQL and ScalarSQL- contextOf p@BinSQL{} = mLkp p - contextOf p = EDcI (concept p)---fldauto::SqlField->Bool -- is the field auto increment?-fldauto f = (fldtype f==SQLId) && not (fldnull f) && flduniq f -- && isIdent (fldexpr f)---showSQL :: SqlType -> String-showSQL (SQLChar    n) = "CHAR("++show n++")"-showSQL (SQLBlob     ) = "BLOB"-showSQL (SQLPass     ) = "VARCHAR(255)"-showSQL (SQLSingle   ) = "FLOAT" -- todo-showSQL (SQLDouble   ) = "FLOAT"-showSQL (SQLText     ) = "TEXT"-showSQL (SQLuInt    n) = "INT("++show n++") UNSIGNED"-showSQL (SQLsInt    n) = "INT("++show n++")"-showSQL (SQLId       ) = "INT"-showSQL (SQLVarchar n) = "VARCHAR("++show n++")"-showSQL (SQLBool     ) = "BOOLEAN"-          --- Every kernel field is a key, kernel fields are in cLkpTbl or the column of ScalarSQL (which has one column only)--- isPlugIndex refers to UNIQUE key -- TODO: this is wrong---isPlugIndex may contain NULL, but their key (the entityfield of the plug) must be unique for a kernel field (isPlugIndex=True)---the field that is isIdent and isPlugIndex (i.e. concept plug), or any similar (uni,inj,sur,tot) field is also UNIQUE key---IdentityDefs define UNIQUE key (fld1,fld2,..,fldn)---REMARK -> a kernel field does not have to be in cLkpTbl, in that cast there is another kernel field that is ---          thus I must check whether fldexpr isUni && isInj && isSur-isPlugIndex :: PlugSQL->SqlField->Bool-isPlugIndex plug f =-  case plug of -    ScalarSQL{} -> sqlColumn plug==f-    BinSQL{}  --mLkp is not uni or inj by definition of BinSQL, if mLkp total then the (fldexpr srcfld)=I/\r;r~=I i.e. a key for this plug-     | isUni(mLkp plug) || isInj(mLkp plug) -> fatal 366 "BinSQL may not store a univalent or injective rel, use TblSQL instead."-     | otherwise                            -> False --binary does not have key, but I could do a SELECT DISTINCT iff f==fst(columns plug) && (isTot(mLkp plug)) -    TblSQL{}    -> elem f (fields plug) && isUni(fldexpr f) && isInj(fldexpr f) && isSur(fldexpr f)----mLkpTbl stores the relation of some target field with one source field---an isPlugIndex target field is a kernel field related to some similar or larger kernel field---any other target field is an attribute field related to its kernel field-kernelrels::PlugSQL ->[(SqlField,SqlField)]-kernelrels plug@ScalarSQL{} = [(sqlColumn plug,sqlColumn plug)]-kernelrels (BinSQL{})       = fatal 375 "Binary plugs do not know the concept of kernel fields."-kernelrels plug@TblSQL{}    = [(sfld,tfld) |(_,sfld,tfld)<-mLkpTbl plug,isPlugIndex plug tfld] -attrels::PlugSQL ->[(SqlField,SqlField)]-attrels plug@ScalarSQL{}    = [(sqlColumn plug,sqlColumn plug)]-attrels BinSQL{}            = fatal 379 "Binary plugs do not know the concept of attribute fields."-attrels plug@TblSQL{}       = [(sfld,tfld) |(_,sfld,tfld)<-mLkpTbl plug,not(isPlugIndex plug tfld)] ------the kernel of SqlFields is ordered by existence of elements for some instance of the entity stored in the plug.---fldexpr of key is the relation with a similar or larger key.---(similar = uni,tot,inj,sur, includes = uni,inj,sur)------each kernel field is a key to attributes and itself (kfld), and each attribute field is related to one kernel field (kfld)---kfld may be smaller than the ID of the plug, but larger than other kernel fields in the plug---All (kernel) fields larger than or similar to kfld and their total attributes are required.---(remark that the total property of an attribute points to the relation of the att with its key, which is not the ID of the plug per se)---Smaller (kernel) fields and their total attributes may contain NULL where kfld does not and are not required.------auto increment fields are not considered to be required-requiredFields :: PlugSQL -> SqlField ->[SqlField]-requiredFields plug@ScalarSQL{} _ = [sqlColumn plug]-requiredFields plug@BinSQL{}    _ = [fst(columns plug),snd(columns plug)]-requiredFields plug@TblSQL{} fld - = [f |f<-requiredkeys++requiredatts, not (fldauto f)] -  where-  kfld | null findfld = fatal 401 $ "fld "++fldname fld++" must be in the plug "++name plug++"."-       | isPlugIndex plug fld = fld-       | otherwise = fst(head findfld) --fld is an attribute field, take its kernel field-  findfld = [(k,maybek) |(_,k,maybek)<-mLkpTbl plug,fld==maybek]-  requiredkeys = similar++requiredup -  requiredatts = [a |k<-requiredkeys,(k',a)<-attrels plug,k==k',isTot(fldexpr a)]-  ------------  --kernelclusters is a list of kernel field clusters clustered by similarity-  --similar is the cluster where kfld is in-  similar = [c |Cluster cs<-kernelclusters plug,kfld `elem` cs,c<-cs]-  --the kernel fields in which a similar field is included, but not a similar field-  --(clusterBy includeskey [Cluster [x]] (kernelrels plug) returns one inclusion chain (cluster) from ID to x -  --Thus, similar elements of elements in the chain (except x) are not taken into account yet (see similarskeysup and requiredup)-  keysup = nub[rf |x<-similar-                  ,cs<-map cslist(clusterBy includeskey [Cluster [x]] (kernelrels plug))-                  ,rf<-cs]-            >- similar-  --there can be a key1 similar to a key2 in keysup, but key1 is not in keysup.-  --key1 is required just like key2 because they are similar-  similarskeysup = nub[key1 | Cluster cs<-kernelclusters plug-                            , key1<-cs -                            , key2<-keysup-                            , key2 `elem` cs-                            , key1 `notElem` keysup]-  --the similarskeysup may have required fields not in keysup (recursion)-  --add those which are not in keysup yet-  requiredup = nub(keysup++requiredbysimilarkeysup)-  requiredbysimilarkeysup = nub[rf |x<-similarskeysup,rf<-requiredFields plug x]-  ---------------fld1 requires fld2 in plug?-requires :: PlugSQL -> (SqlField,SqlField) ->Bool-requires plug (fld1,fld2) = fld2 `elem` requiredFields plug fld1--composeCheck :: Expression -> Expression -> Expression-composeCheck l r- = if target l/=source r then fatal 316 ("\nl: "++show l++"with target "++show (target l)++"\nl: "++show r++"with source "++show (source r)) else-   l .:. r- ---composition from srcfld to trgfld, if there is an expression for that-plugpath :: PlugSQL -> SqlField -> SqlField -> Maybe Expression-plugpath p srcfld trgfld =- case p of-  BinSQL{}-   | srcfld==trgfld -> let tm=mLkp p --(note: mLkp p is the relation from fst to snd column of BinSQL)-                       in if srcfld==fst(columns p) -                          then Just$ tm .:. flp tm --domain of r-                          else Just$ flp tm .:. tm --codomain of r-   | srcfld==fst(columns p) && trgfld==snd(columns p) -> Just$ fldexpr trgfld-   | trgfld==fst(columns p) && srcfld==snd(columns p) -> Just$ flp(fldexpr srcfld)-   | otherwise -> fatal 444 $ "BinSQL has only two fields:"++show(fldname srcfld,fldname trgfld,name p)-  ScalarSQL{}-   | srcfld==trgfld -> Just$ fldexpr trgfld-   | otherwise -> fatal 447 $ "scalarSQL has only one field:"++show(fldname srcfld,fldname trgfld,name p)-  TblSQL{}  -   | srcfld==trgfld && isPlugIndex p trgfld -> Just$ EDcI (target (fldexpr trgfld))-   | srcfld==trgfld && not(isPlugIndex p trgfld) -> Just$ composeCheck (flp (fldexpr srcfld)) (fldexpr trgfld) --codomain of r of morAtt-   | (not . null) (paths srcfld trgfld)-      -> case head (paths srcfld trgfld) of-          []    -> fatal 338 ("Empty head (paths srcfld trgfld) should be impossible.")-          ps    -> Just$ foldr1 composeCheck ps-   --bijective kernel fields, which are bijective with ID of plug have fldexpr=I[X].-   --thus, path closures of these kernel fields are disjoint (path closure=set of fields reachable by paths),-   --      because these kernel fields connect to themselves by r=I[X] (i.e. end of path).-   --connect two paths over I[X] (I[X];srce)~;(I[X];trge) => filter I[X] => srcpath~;trgpath-   | (not.null) (pathsoverIs srcfld trgfld) -> Just$      foldr1 composeCheck (head (pathsoverIs srcfld trgfld))-   | (not.null) (pathsoverIs trgfld srcfld) -> Just$ flp (foldr1 composeCheck (head (pathsoverIs trgfld srcfld)))-   | otherwise -> Nothing-  --paths from s to t by connecting r from mLkpTbl-  --the (r,srcfld,trgfld) from mLkpTbl form paths longer paths if connected: (trgfld m1==srcfld m2) => (m1;m2,srcfld m1,trgfld m2)-  where-  paths s t = [e |(e,es,et)<-eLkpTbl p,s==es,t==et]-  --paths from I to field t-  pathsfromIs t = [(e,es,et) |(e,es,et)<-eLkpTbl p,et==t,not (null e),isIdent(head e)] -  --paths from s to t over I[X]-  pathsoverIs s t = [flpsrce++tail trge -                    |(srce,srces,_)<-pathsfromIs s-                    ,(trge,trges,_)<-pathsfromIs t-                    ,srces==trges, let flpsrce = (map flp.reverse.tail) srce] ----the expression LkpTbl of a plug is the transitive closure of the mLkpTbl of the plug---Warshall's transitive closure algorithm clos1 :: (Eq a) => [(a,a)] -> [(a,a)] is extended to combine paths i.e. r++r'---[Expression] implies a 'composition' from a kernel SqlField to another SqlField---use plugpath to get the Expression from srcfld to trgfld---plugpath also combines expressions with head I like (I;tail1)~;(I;tail2) <=> tail1;tail2-eLkpTbl::PlugSQL -> [([Expression],SqlField,SqlField)]-eLkpTbl p = clos1 [([r],s,t)|(r,s,t)<-mLkpTbl p]-  where-  clos1 :: [([Expression],SqlField,SqlField)] -> [([Expression],SqlField,SqlField)]     -- e.g. a list of SqlField pairs-  clos1 xs-     = foldl f xs (nub (map (\(_,x,_)->x) xs) `isc` nub (map (\(_,_,x)->x) xs))-       where-        f q x = q `uni` [( r++r' , a, b') | (r ,a, b) <- q, b == x, (r', a', b') <- q, a' == x]----bijective fields of f (incl. f)-bijectivefields::PlugSQL -> SqlField -> [SqlField]-bijectivefields p f = [bij |Cluster fs<-kernelclusters p, f `elem` fs,bij<-fs]----the clusters of kernel sqlfields that are similar because they relate uni,inj,tot,sur-kernelclusters ::PlugSQL -> [Cluster SqlField]-kernelclusters plug@ScalarSQL{} = [Cluster [sqlColumn plug]]-kernelclusters (BinSQL{})       = [] --a binary plugs has no kernel (or at most (entityfield plug))-kernelclusters plug@TblSQL{}    = clusterBy similarkey [] (kernelrels plug)----similar key: some source key s that is not equal to target key t (i.e. not the identity), but related uni,tot,inj,sur in some other way-similarkey::(SqlField,SqlField)->Bool-similarkey (s,t) = s/=t && isTot (fldexpr t) && isSur (fldexpr t) && isInj (fldexpr t) && isUni (fldexpr t)----includes key: some target key t that is related to source key s uni,inj,sur but not tot-includeskey::(SqlField,SqlField)->Bool-includeskey (_,t) = not(isTot (fldexpr t)) && isSur (fldexpr t) && isInj (fldexpr t) && isUni (fldexpr t)----clusterBy clusters similar items like eqClass clusters equal items---[(a,a)] defines flat relations between items (not closed)---((a,a) -> Bool) defines some transitive relation between two items (for example similarity, equality, inclusion)---[Cluster a] defines the initial set of clusters which may be [] ---            EXAMPLE USE -> ---            if the relation is not symmetric and you need one chain from x to the top---            then set [Cluster [x]]---            (note: ClusterBy does not take into account any other relation than the one provided!)---TODO -> test plugs that require more than one run (i.e. a composition of kernel fields n>2: ID(fld1;fld2;..;fldn)KernelConcept )---REMARK151210 -> I have made a data type of cluster instead of just list to distinguish between lists and clusters (type checked and better readable code)---                It is an idea to do the same for eqCl and eqClass (Class=Cluster or v.v.)-data Cluster a = Cluster [a] deriving (Eq,Show)-cslist :: Cluster a -> [a]-cslist (Cluster xs) = xs-clusterBy :: (Show a,Eq a) => ((a,a) -> Bool) -> [Cluster a] -> [(a,a)] -> [Cluster a]-clusterBy f [] xs = clusterBy f [Cluster [b] |(_,b)<-xs] xs --initial clusters, for every target there will be a cluster at first (see mergeclusters)-clusterBy f cs xs  -   | cs==nxtrun = mergeclusters cs -   | otherwise = clusterBy f (mergeclusters nxtrun) xs-   where -   nxtrun = [Cluster (addtohead (head ys)++ys) |Cluster ys<-cs, not(null ys)]-   addtohead y =[fst x | x<-xs, snd x==y, f x] --if x=(fst x);y and (f x), then fst x is chained to y -   --we can merge clusters with equal heads, because-   -- + similar things are chained to the head of the cluster-   -- + and the head of mergeclusters == head of every cluster in cs' because we mergecluster each time we add one thing to the head of some cluster-   mergeclusters cs' = [Cluster (nub(concat cl)) |cl<-eqClass eqhead (map cslist cs')] -   eqhead c1 c2 -     | null (c1++c2) = fatal 547 "clusters are not expected to be empty at this point."-     | otherwise = head c1==head c2----- | tblcontents 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 String is used rather than String.-type TblRecord = [Maybe String]-tblcontents :: [A_Gen] -> [Population] -> PlugSQL -> [TblRecord]-tblcontents gens udp plug@ScalarSQL{}-   = [[Just x] | x<-atomsOf gens udp (cLkp plug)]-tblcontents gens udp plug@BinSQL{}-   = [[(Just . srcPaire) p,(Just . trgPaire) p] |p<-fullContents gens udp (mLkp plug)]-tblcontents gens udp plug@TblSQL{}- --TODO15122010 -> remove the assumptions (see comment data PlugSQL)- --fields are assumed to be in the order kernel+other, - --where NULL in a kernel field implies NULL in the following kernel fields- --and the first field is unique and not null- --(r,s,t)<-mLkpTbl: s is assumed to be in the kernel, fldexpr t is expected to hold r or (flp r), s and t are assumed to be different- | null(fields plug) = fatal 593 "no fields in plug."- | otherwise = transpose-                 ( map Just cAtoms-                 : [case fExp of-                       EDcI c -> [ if a `elem` atomsOf gens udp c then Just a else Nothing | a<-cAtoms ]-                       _      -> [ (lkp a . fullContents gens udp) fExp | a<-cAtoms ]-                   | fld<-tail (fields plug), let fExp=fldexpr fld-                   ]-                 )-                 where-                   cAtoms = (atomsOf gens udp . source . fldexpr . head . fields) plug-                   lkp a pairs-                    = case [ p | p<-pairs, a==srcPaire p ] of-                       [] -> Nothing-                       [p] -> Just (trgPaire p)-                       ps -> fatal 428 ("Multiple values in one field: "++show ps)
− src/lib/DatabaseDesign/Ampersand/Fspec/ShowADL.hs 
@@ -1,537 +0,0 @@-{-# OPTIONS_GHC -Wall #-}
-{-# LANGUAGE FlexibleInstances #-}
-  -- The purpose of ShowADL is to print things in Ampersand source format.
-  -- Rule: The semantics of each fSpec produced by the compiler is identical to the semantics  of (parse (showADL fSpec)).
-  -- Rule: The standard show is used only for simple error messages during testing.
-  -- Question (SJC): If STRING is the code produced by showADL, would STRING == showADL (parse STRING) (context (parse STRING)) be true?
-  -- Answer (SJ):   No, not for every STRING. Yet, for every fSpec we want  semantics fSpec == semantics (parse (showADL fSpec)).
-  --                Note that 'parse' and 'semantics' do not exist in this shape, so the actual expression is slightly more complicated.
-  --
-  -- Every Expression should be disambiguated before printing to ensure unambiguity.
-module DatabaseDesign.Ampersand.Fspec.ShowADL
-    ( ShowADL(..), LanguageDependent(..), showPAclause, showREL)
-where
-import DatabaseDesign.Ampersand.Core.ParseTree
-import DatabaseDesign.Ampersand.Core.AbstractSyntaxTree
-import DatabaseDesign.Ampersand.Basics      (fatalMsg,eqCl,Collection(..),Identified(..))
-import DatabaseDesign.Ampersand.Classes
-import DatabaseDesign.Ampersand.ADL1 (insParentheses)
-import DatabaseDesign.Ampersand.Fspec.Fspec
-import Data.List hiding (head)
-import Prelude hiding (head)
---import Debug.Trace
-
-head :: [a] -> a
-head [] = fatal 30 "head must not be used on an empty list!"
-head (a:_) = a
-
-
-fatal :: Int -> String -> a
-fatal = fatalMsg "Fspec.ShowADL"
-
-class ShowADL a where
- showADL :: a -> String
-
--- there are data types yielding language dependent data like an Expression
--- the LanguageDependent class provides function(s) to map language dependent functions on those data if any.
--- for example to print all expressions in a data structure with a practical amount of type directives
--- (instances have been created when needed)
---
--- LanguageDependent is part of ShowAdl because the only application at time of writing is to disambiguate expressions for the purpose of printing
--- SJ 31-12-2012: Since 'disambiguate' has become obsolete, do we still need this?
-class LanguageDependent a where
-  mapexprs :: (Language l, ConceptStructure l, Identified l) => (l -> Expression -> Expression) -> l -> a -> a
-  mapexprs _ _ = id
-
-instance LanguageDependent a => LanguageDependent (Maybe a) where
-  mapexprs _ _ Nothing  = Nothing
-  mapexprs f l (Just x) = Just $ mapexprs f l x
-
-instance LanguageDependent (a, Expression) where
-  mapexprs f l (x,e) = (x, f l e)
-instance LanguageDependent Rule where
-  mapexprs f l rul = rul{rrexp = f l (rrexp rul)}
-instance LanguageDependent Interface where
-  mapexprs f l ifc = ifc{ifcObj = mapexprs f l (ifcObj ifc)}
-instance LanguageDependent ObjectDef where
-  mapexprs f l obj = obj{objctx = f l (objctx obj), objmsub = mapexprs f l $ objmsub obj}
-instance LanguageDependent SubInterface where
-  mapexprs _ _ iref@(InterfaceRef _) = iref
-  mapexprs f l (Box o objs) = Box o $ map (mapexprs f l) objs
-instance LanguageDependent Declaration where
-  mapexprs _ _ = id
-instance LanguageDependent ECArule where
-  mapexprs _ _ = id
-instance LanguageDependent Event where
-  mapexprs _ _ = id
---------------------------------------------------------------
-instance ShowADL (P_SubIfc a) where
-  showADL (P_Box{}) = "BOX"
-  showADL (P_InterfaceRef _ nm) = " INTERFACE "++showstr nm
-  
-
-instance ShowADL ObjectDef where
--- WHY (HJ)? In deze instance van ShowADL worden diverse zaken gebruikt die ik hier niet zou verwachten.
---              Het vertroebelt de code ook een beetje, want nu moeten er dingen als 'source' en
---              'target' hier al bekend zijn.
---              Dat lijkt me hier nog niet op z'n plaats, als je alleen maar wat wilt kunnen 'prettyprinten'. 
--- BECAUSE (SJ): Dit blijft nog even zo, omdat showADL gebruikt wordt in het genereren van interfaces.
---              Zolang we dat nog niet onder de knie hebben blijft de code wat troebel.
- showADL obj = " : "++showADL (objctx obj)++
-               recur "\n  " (objmsub obj)
-  where recur :: String -> Maybe SubInterface -> String
-        recur _   Nothing = ""
-        recur ind (Just (InterfaceRef nm)) = ind++" INTERFACE "++showstr nm
-        recur ind (Just (Box _ objs))
-         = ind++" BOX [ "++
-           intercalate (ind++"     , ") 
-                               [ showstr (name o)++
-                                  (if null (objstrs o) then "" else " {"++intercalate ", " [showstr (unwords ss) | ss<-objstrs o]++"}")++
-                                  " : "++showADL (objctx o)++
-                                  recur (ind++"      ") (objmsub o)
-                               | o<-objs
-                               ]++
-           ind++"     ]"
-
-instance ShowADL Meta where
- showADL (Meta _ metaObj nm val) = 
-   "META "++(if null $ showADL metaObj then "" else showADL metaObj++" ") ++show nm++" "++show val
-
-instance ShowADL MetaObj where
- showADL ContextMeta = ""
- 
-instance ShowADL Purpose where
- showADL expl = "PURPOSE "++showADL (explObj expl)
-                ++showADL (amLang (explMarkup expl))
-                ++showADL (amFormat (explMarkup expl))
-                ++(if null (explRefIds expl) then "" else " REF "++intercalate ";" (explRefIds expl))
-                ++ "{+"++aMarkup2String (explMarkup expl)++"-}"
-
-instance ShowADL PandocFormat where
- showADL LaTeX = "LATEX"
- showADL HTML  = "HTML"
- showADL ReST  = "REST"
- showADL Markdown = "MARKDOWN"
- 
-instance ShowADL A_Markup where
- showADL m 
-     = "IN " ++showADL (amLang m) 
-    ++ " "++showADL (amFormat m) 
-    ++ "{+"++aMarkup2String m++"-}"
-    
-instance ShowADL Lang where
- showADL Dutch   = "DUTCH"
- showADL English = "ENGLISH"
-   
---instance ShowADL (Maybe Lang) where
--- showADL  Nothing       = "IN DUTCH"
--- showADL (Just Dutch  ) = "IN DUTCH"
--- showADL (Just English) = "IN ENGLISH"
-   
-instance ShowADL ExplObj where
- showADL e = case e of
-      ExplConceptDef cd  -> "CONCEPT "++cdcpt cd
-      ExplDeclaration d  -> "RELATION "++show (name d)
-      ExplRule str       -> "RULE "++showstr str
-      ExplIdentityDef str-> "IDENT "++showstr str
-      ExplViewDef str    -> "VIEW "++showstr str
-      ExplPattern str    -> "PATTERN "++ showstr str
-      ExplProcess str    -> "PROCESS "++str
-      ExplInterface str  -> "INTERFACE "++showstr str
-      ExplContext str    -> "CONTEXT "++showstr str
-
-showstr :: String -> String
-showstr str = "\""++str++"\""
-
-instance ShowADL Process where
- showADL prc
-  = "PROCESS " ++ name prc 
-    ++ (if null (udefrules prc) then "" else "\n  " ++intercalate "\n  " (map showADL (udefrules prc)) ++ "\n")
-    ++ (if null (maintains prc) then "" else "\n  " ++                        showRM prc               ++ "\n")
-    ++ (if null (mayEdit prc)   then "" else "\n  " ++                        showRR prc               ++ "\n")
--- concept definitions are not printed, because we have no way of telling where they come from.... 
-    ++ (if null (prcIds prc)    then "" else "\n  " ++intercalate "\n  " (map showADL (prcIds prc))    ++ "\n")
-    ++ (if null (prcXps prc)    then "" else "\n  " ++intercalate "\n  " (map showADL (prcXps prc))    ++ "\n")
--- The relations declared in the pattern are supplemented by all relations used by the rules.
--- Thus, the resulting pattern is self-contained with respect to declarations.
-    ++ (if null decls           then "" else "\n  " ++intercalate "\n  " (map showADL decls)           ++ "\n")
-    ++ "ENDPROCESS"
-    where
-      decls = [d | d@Sgn{}<-relsDefdIn prc `uni` relsMentionedIn prc]
- -- TODO: the following definitions should be unneccessary, but 'map showADL (maintains prc)' and "map showADL (mayEdit prc)" don't work...
-      showRM :: Process -> String
-      showRM pr = intercalate "\n  " [ "ROLE "++role++" MAINTAINS "++intercalate ", " [name rul | (_,rul)<-cl]
-                                     | cl<-eqCl fst (maintains pr), let role = fst (head cl)]
-      showRR :: Process -> String
-      showRR pr = intercalate "\n  " [ "ROLE "++role++" EDITS "++intercalate ", " [name rul | (_,rul)<-cl]
-                                     | cl<-eqCl fst (mayEdit pr), let role = fst (head cl)]
-
-instance ShowADL (String,Rule) where
- showADL (role,rul) = "ROLE "++role++" MAINTAINS "++show (name rul)
-
-instance ShowADL (String,Declaration) where
- showADL           (role,rel) = "ROLE "++role++" EDITS "++showADL rel
-
-instance ShowADL (String,Interface) where
- showADL (role,ifc) = "ROLE "++role++" USES "++show (name ifc)
- 
-instance ShowADL Pattern where
- showADL pat
-  = "PATTERN " ++ showstr (name pat) ++ "\n"
-    ++ (if null (ptrls pat)  then "" else "\n  " ++intercalate "\n  " (map showADL (ptrls pat)) ++ "\n")
-    ++ (if null (ptgns pat)  then "" else "\n  " ++intercalate "\n  " (map showADL (ptgns pat)) ++ "\n")
-    ++ (if null (ptdcs pat)  then "" else "\n  " ++intercalate "\n  " (map showADL (ptdcs pat)) ++ "\n")
--- concept definitions are not printed, because we have no way of telling where they come from.... 
-    ++ (if null (ptids pat)  then "" else "\n  " ++intercalate "\n  " (map showADL (ptids pat)) ++ "\n")
-    ++ "ENDPATTERN"
-
-instance ShowADL (PairViewSegment Expression) where
- showADL (PairViewText str)         = "TXT " ++ show str
- showADL (PairViewExp srcOrTgt e) = showADL srcOrTgt ++ " " ++ showADL e
-
-instance ShowADL SrcOrTgt where
- showADL Src = "source"
- showADL Tgt = "target"
- 
---showADLSrcOrTgt :: SrcOrTgt -> String
---showADLSrcOrTgt Src = "SRC"
---showADLSrcOrTgt Tgt = "TGT"
-        
-instance ShowADL Rule where
- showADL r
-  = "RULE \""++rrnm r++"\" : "++showADL (rrexp r)
-     ++ concat ["\n     MEANING "++showADL mng | mng <- ameaMrk $ rrmean r ]
-     ++ concat ["\n     MESSAGE "++showADL msg | msg <- rrmsg r]
-     ++ case rrviol r of
-          Nothing                -> ""
-          Just (PairView pvSegs) -> "\n     VIOLATION ("++intercalate ", " (map showADL pvSegs)++")"
-       
-instance ShowADL A_Gen where
- showADL g =
-   case g of
-    Isa{} -> "CLASSIFY "++showADL (genspc g)++" ISA "++showADL (gengen g)
-    IsE{} -> "CLASSIFY "++showADL (genspc g)++" IS "++intercalate " /\\ " (map showADL (genrhs g))
-
-instance ShowADL RoleRelation where
- showADL r
-  = "ROLE "++intercalate ", " (map show (rrRoles r))++" EDITS "++intercalate ", " (map showADL (rrRels r))
-
-instance ShowADL RoleRule where
- showADL r = "ROLE "++intercalate ", " (map show (mRoles r))++" MAINTAINS "++intercalate ", " (map show (mRules r))
-
-instance ShowADL Interface where
- showADL ifc 
-  = "INTERFACE "++showstr(name ifc)
-          ++(if null (ifcParams ifc) then "" else "("++intercalate ", " [showADL r | r<-ifcParams ifc]++")")
-          ++(if null (ifcArgs ifc) then "" else "{"++intercalate ", " [showstr(unwords strs) | strs<-ifcArgs ifc]++"}")
-          ++(if null (ifcRoles ifc) then "" else " FOR "++intercalate ", " [ r | r<-ifcRoles ifc])
-          ++showADL (ifcObj ifc)
-
-instance ShowADL IdentityDef where
- showADL identity 
-  = "IDENT "++idLbl identity
-          ++ ": " ++name (idCpt identity)
-          ++ "(" ++intercalate ", " (map showADL $ identityAts identity) ++ ")"
-
-instance ShowADL IdentitySegment where
- showADL (IdentityExp objDef) = (if null (name objDef) then "" else "\""++name objDef++"\":") ++ showADL (objctx objDef)
-
-instance ShowADL ViewDef where
- showADL vd 
-  = "VIEW "++vdlbl vd
-          ++ ": " ++name (vdcpt vd)
-          ++ "(" ++intercalate ", " (map showADL $ vdats vd) ++ ")"
-
-instance ShowADL ViewSegment where
- showADL (ViewExp objDef) = (if null (name objDef) then "" else "\""++name objDef++"\":") ++ showADL (objctx objDef)
- showADL (ViewText str) = "TXT " ++ show str
- showADL (ViewHtml str) = "PRIMHTML " ++ show str
-
--- showADL Relation only prints complete signatures to ensure unambiguity.
--- therefore, when printing expressions, do not apply this function to print relations, but apply one that prints names only
---instance ShowADL Relation where
--- showADL rel = show rel
-
-instance ShowADL Expression where
- showADL = showExpr (" = ", " |- ", " /\\ ", " \\/ ", " - ", " / ", " \\ ", " <> ", ";", "!", "*", "*", "+", "~", ("-"++), "(", ")", "[", "*", "]")
--- NOTE: retain space after \\, because of unexpected side effects if it is used just before an 'r' or 'n'....
-   where 
-     showExpr :: (String,String,String,String,String,String,String,String,String,String,String,String,String,String,String -> String,String,String,String,String,String)
-            -> Expression -> String
-     showExpr    (equi,  impl,  inter, union',diff,  lresi, rresi, rDia, rMul  , rAdd , rPrd ,closK0,closK1,flp',  compl,           lpar,  rpar,  lbr,   star,  rbr)  expr
-      = --let c = PlainConcept "A" in trace (showchar (insParentheses (ECps (ECps (EDcI c,EDcI c),ECps (EDcI c,EDcI c))))) $
-        showchar (insParentheses expr)
-        where
-          showchar (EEqu (l,r)) = showchar l++equi++showchar r
-          showchar (EImp (l,r)) = showchar l++impl++showchar r
-          showchar (EIsc (l,r)) = showchar l++inter++showchar r
-          showchar (EUni (l,r)) = showchar l++union'++showchar r
-          showchar (EDif (l,r)) = showchar l++diff ++showchar r
-          showchar (ELrs (l,r)) = showchar l++lresi++showchar r
-          showchar (ERrs (l,r)) = showchar l++rresi++showchar r
-          showchar (EDia (l,r)) = showchar l++rDia++showchar r
-          showchar (ECps (l,r)) = showchar l++rMul++showchar r
-          showchar (ERad (l,r)) = showchar l++rAdd++showchar r
-          showchar (EPrd (l,r)) = showchar l++rPrd++showchar r
-          showchar (EKl0 e)     = showchar e++closK0
-          showchar (EKl1 e)     = showchar e++closK1
-          showchar (EFlp e)     = showchar e++flp'
-          showchar (ECpl e)     = compl (showchar e)
-          showchar (EBrk e)     = lpar++showchar e++rpar
-          showchar (EDcD dcl)   = name dcl
-          showchar (EDcI c)     = "I"++lbr++name c++rbr
-          showchar (EEps i _)   = "Eps{"++name i++"}"
-          showchar (EDcV sgn)   = "V"++lbr++name (source sgn)++star++name (target sgn)++rbr
-          showchar (EMp1 a c)   = "'"++a++"'"++lbr++name c++rbr
-
-instance ShowADL DnfClause where
- showADL dnfClause = showADL (dnf2expr dnfClause)
-
-instance ShowADL Declaration where
- showADL decl = 
-  case decl of
-     Sgn{} -> name decl++" :: "++name (source decl)++(if null ([Uni,Tot]>-multiplicities decl) then " -> " else " * ")++name (target decl)++
-              (let mults=if null ([Uni,Tot]>-multiplicities decl) then multiplicities decl>-[Uni,Tot] else multiplicities decl in
-               if null mults then "" else "["++intercalate "," (map showADL mults)++"]")++
-              (if null(decprL decl++decprM decl++decprR decl) then "" else
-               " PRAGMA "++unwords (map show [decprL decl,decprM decl,decprR decl]))
-               ++ concatMap meaning (ameaMrk (decMean decl))
-     Isn{} -> "I["++show (detyp decl)++"]" -- Isn{} is of type Declaration and it is implicitly defined
-     Vs{}  -> "V"++show (decsgn decl)      -- Vs{}  is of type Declaration and it is implicitly defined
-   where
-     meaning :: A_Markup -> String
-     meaning pmkup = " MEANING "++showADL pmkup
-
-showREL :: Declaration-> String
-showREL decl = show decl
-{-
-  case decl of
-     Sgn{} -> name decl++showSign (sign decl)
-     Isn{} -> "I["++show (detyp decl)++"]" -- Isn{} is of type Declaration and it is implicitly defined
-     Vs{}  -> "V"++show (decsgn decl)
--}
-
-instance ShowADL P_Markup where
- showADL (P_Markup lng fmt str) = case lng of
-                                     Nothing -> ""
-                                     Just l  -> "IN "++show l++" "
-                                 ++
-                                  case fmt of
-                                     Nothing -> ""
-                                     Just f  -> " "++show f++" "
-                                 ++
-                                  "{+"++str++"-} "
- 
-instance ShowADL Prop where
- showADL = show
-
-instance ShowADL A_Concept where
- showADL c = show (name c)
-
-instance ShowADL ConceptDef where
- showADL cd
-  = "\n  CONCEPT "++show (cdcpt cd)++" "++show (cddef cd)++" "++(if null (cdref cd) then "" else show (cdref cd))
-
-instance ShowADL A_Context where
- showADL context
-  = "CONTEXT " ++name context
-    ++ (if null (ctxmetas context) then "" else "\n"      ++intercalate "\n\n" (map showADL (ctxmetas context))++ "\n")
-    ++ (if null (ctxprocs context) then "" else "\n"      ++intercalate "\n\n" (map showADL (ctxprocs context))++ "\n") -- All processes
-    ++ (if null (ctxifcs context)  then "" else "\n"      ++intercalate "\n\n" (map showADL (ctxifcs context)) ++ "\n")
-    ++ (if null (ctxpats context)  then "" else "\n"      ++intercalate "\n\n" (map showADL (ctxpats context)) ++ "\n")
-    ++ (if null (ctxrs context)    then "" else "\n"      ++intercalate "\n"   (map showADL (ctxrs context))   ++ "\n")
-    ++ (if null (ctxds context)    then "" else "\n"      ++intercalate "\n"   (map showADL (ctxds context))   ++ "\n")
-    ++ (if null (ctxks context)    then "" else "\n"      ++intercalate "\n"   (map showADL (ctxks context))   ++ "\n")
-    ++ (if null (ctxgs context)    then "" else "\n"      ++intercalate "\n"   (map showADL (ctxgs context))   ++ "\n")
-    ++ (if null (ctxcds context)   then "" else "\n"      ++intercalate "\n"   (map showADL (ctxcds context))  ++ "\n")
-    ++ (if null (ctxpopus context) then "" else "\n"      ++intercalate "\n"   (map showADL (ctxpopus context))++ "\n")
-    ++ (if null (ctxsql context)   then "" else "\n"      ++intercalate "\n\n" (map showADL (ctxsql context)) ++ "\n")
-    ++ (if null (ctxphp context)   then "" else "\n"      ++intercalate "\n\n" (map showADL (ctxphp context)) ++ "\n")
-    ++ "\n\nENDCONTEXT"
-
-instance ShowADL Fspc where
- showADL fSpec
-  = "CONTEXT " ++name fSpec
-    ++ (if null (map ifcObj [] {- map fsv_ifcdef (fActivities fSpec) -})     
-        then "" 
-        else "\n"++intercalate "\n\n" (map (showADL . ifcObj) [] {- map fsv_ifcdef (fActivities fSpec) -})     ++ "\n")
-    ++ (if null (metas fSpec)    then "" else "\n"++intercalate "\n\n" (map showADL (metas fSpec))    ++ "\n")
-    ++ (if null (patterns fSpec)    then "" else "\n"++intercalate "\n\n" (map showADL (patterns fSpec))    ++ "\n")
---    ++ (if null (vprocesses fSpec)    then "" else "\n"++intercalate "\n\n" (map showADL (vprocesses fSpec))    ++ "\n")  -- TODO implement ShowADL FProcess
-    ++ (if null (conceptDefs fSpec) then "" else "\n"++intercalate "\n"   (map showADL (conceptDefs fSpec)) ++ "\n")
-    ++ (if null (gens fSpec) then "" else "\n"++intercalate "\n"   (map showADL (gens fSpec)) ++ "\n")
-    ++ (if null (identities fSpec)       then "" else "\n"++intercalate "\n"   (map showADL (identities fSpec >- concatMap identities (patterns fSpec)))       ++ "\n")
-    ++ (if null decls then "" else "\n"++intercalate "\n"   (map showADL decls) ++ "\n")
-    ++ (if null (udefrules fSpec) then "" else "\n"++intercalate "\n"   (map showADL (udefrules fSpec >- concatMap udefrules (patterns fSpec))) ++ "\n")
-    ++ (if null (fSexpls fSpec) then "" else "\n"++intercalate "\n"   (map showADL (fSexpls fSpec)) ++ "\n")
-    ++ "TODO: Populations are not shown..\n" --TODO.
---    ++ (if null showADLpops         then "" else "\n"++intercalate "\n\n" showADLpops                                    ++ "\n")
-    ++ (if null (interfaceS fSpec)    then "" else "\n"++intercalate "\n\n" (map showADL (interfaceS fSpec))    ++ "\n")
-    ++ "\n\nENDCONTEXT"
-    where decls = relsDefdIn fSpec >- (concatMap relsDefdIn (patterns fSpec) `uni` concatMap relsDefdIn (vprocesses fSpec))
-instance ShowADL (Maybe String) where
-  showADL _ = ""
-instance ShowADL ECArule where
-  showADL eca = "ECA #"++show (ecaNum eca)
-
-instance ShowADL Event where
-  showADL ev = " On " ++show (eSrt ev)++" "++showREL (eDcl ev)
-
-instance (ShowADL a, ShowADL b) => ShowADL (a,b) where
- showADL (a,b) = "(" ++ showADL a ++ ", " ++ showADL b ++ ")"
-
-instance ShowADL P_Population where
- showADL pop
-  = "POPULATION "++name pop
-  ++ case pop of
-        P_TRelPop{} -> "["++(name.pSrc.p_type) pop++"*"++(name.pTgt.p_type) pop++"]"
-        _ -> ""
-  ++ " CONTAINS\n"
-  ++ if (case pop of
-            P_RelPopu{} -> null (p_popps pop)
-            P_TRelPop{} -> null (p_popps pop)
-            P_CptPopu{} -> null (p_popas pop)
-        ) 
-     then "" 
-     else indent++"[ "++intercalate ("\n"++indent++", ") showContent++indent++"]"
-    where indent = "   "
-          showContent = case pop of
-                          P_RelPopu{} -> map showPaire (p_popps pop)
-                          P_TRelPop{} -> map showPaire (p_popps pop)
-                          P_CptPopu{} -> map showAtom  (p_popas pop)
-showPaire :: Paire -> String
-showPaire p = showAtom (srcPaire p)++" * "++ showAtom (trgPaire p)
-
-instance ShowADL Population where
- showADL pop
-  = "POPULATION "
-  ++ case pop of
-        PRelPopu{} -> (name.popdcl) pop++(show.sign.popdcl) pop
-        PCptPopu{} -> (name.popcpt) pop
-  ++ " CONTAINS\n"
-  ++ if (case pop of
-            PRelPopu{} -> null (popps pop)
-            PCptPopu{} -> null (popas pop)
-        ) 
-     then "" 
-     else indent++"[ "++intercalate ("\n"++indent++", ") showContent++indent++"]"
-    where indent = "   "
-          showContent = case pop of
-                          PRelPopu{} -> map showPaire (popps pop)
-                          PCptPopu{} -> map showAtom  (popas pop)
-
-
--- showADL (PRelPopu r pairs)
---  = "POPULATION "++showADL r++" CONTAINS\n"++
---    indent++"[ "++intercalate ("\n"++indent++", ") (map (\(x,y)-> showatom x++" * "++ showatom y) pairs)++indent++"]"
---    where indent = "   "
-
-
-showAtom :: String -> String
-showAtom x = "'"++[if c=='\'' then '`' else c|c<-x]++"'"              
-
-instance ShowADL TermPrim where
- showADL (PI _)                                   = "I"
- showADL (Pid _ c)                                = "I["++showADL c++"]"
- showADL (Patm _ a Nothing)                       = "'"++a++"'"
- showADL (Patm _ a (Just c))                      = "'"++a++"'["++show c++"]"
- showADL (PVee _)                                 = "V"
- showADL (Pfull _ s t)                            = "V["++show s++"*"++show t++"]"
- showADL (Prel _ rel)                             = rel
- showADL (PTrel _ rel psgn)                       = rel++showsign psgn
-  where     showsign (P_Sign src trg)                         = "["++showADL src++"*"++showADL trg++"]"
-
-
---used to compose error messages at p2a time
-instance (ShowADL a, Traced a) => ShowADL (Term a) where
- showADL = showPExpr (" = ", " |- ", " /\\ ", " \\/ ", " - ", " / ", " \\ ", "<>", ";", "!", "*", "*", "+", "~", "(", ")")
-   where
-    showPExpr (equi,impl,inter,union',diff,lresi,rresi,rDia,rMul,rAdd,rPrd,closK0,closK1,flp',lpar,rpar) expr
-     = showchar (insP_Parentheses expr)
-      where
-       showchar (Prim a) = showADL a
-       showchar (Pequ _ l r)                             = showchar l++equi++showchar r
-       showchar (Pimp _ l r)                             = showchar l++impl++showchar r
-       showchar (PIsc _ l r)                             = showchar l++inter++showchar r
-       showchar (PUni _ l r)                             = showchar l++union'++showchar r
-       showchar (PDif _ l r)                             = showchar l++diff ++showchar r
-       showchar (PLrs _ l r)                             = showchar l++lresi++showchar r
-       showchar (PRrs _ l r)                             = showchar l++rresi++showchar r
-       showchar (PDia _ l r)                             = showchar l++rDia++showchar r
-       showchar (PCps _ l r)                             = showchar l++rMul++showchar r
-       showchar (PRad _ l r)                             = showchar l++rAdd++showchar r
-       showchar (PPrd _ l r)                             = showchar l++rPrd++showchar r
-       showchar (PKl0 _ e)                               = showchar e++closK0
-       showchar (PKl1 _ e)                               = showchar e++closK1
-       showchar (PFlp _ e)                               = showchar e++flp'
-       showchar (PCpl _ e)                               = '-':showchar e
-       showchar (PBrk _ e)                               = lpar++showchar e++rpar
-
-insP_Parentheses :: (Traced a) => Term a -> Term a
-insP_Parentheses = insPar 0
-      where
-       wrap :: (Traced a) => Integer -> Integer -> Term a -> Term a
-       wrap i j e' = if i<=j then e' else PBrk (origin e') e'
-       insPar :: (Traced a) => Integer -> Term a -> Term a
-       insPar i (Pequ o l r) = wrap i     0 (Pequ o (insPar 1 l) (insPar 1 r))
-       insPar i (Pimp o l r) = wrap i     0 (Pimp o (insPar 1 l) (insPar 1 r))
-       insPar i (PIsc o l r) = wrap (i+1) 2 (PIsc o (insPar 2 l) (insPar 2 r))
-       insPar i (PUni o l r) = wrap (i+1) 2 (PUni o (insPar 2 l) (insPar 2 r))
-       insPar i (PDif o l r) = wrap i     4 (PDif o (insPar 5 l) (insPar 5 r))
-       insPar i (PLrs o l r) = wrap i     6 (PLrs o (insPar 7 l) (insPar 7 r))
-       insPar i (PRrs o l r) = wrap i     6 (PRrs o (insPar 7 l) (insPar 7 r))
-       insPar i (PDia o l r) = wrap i     6 (PDia o (insPar 7 l) (insPar 7 r))
-       insPar i (PCps o l r) = wrap (i+1) 8 (PCps o (insPar 8 l) (insPar 8 r))
-       insPar i (PRad o l r) = wrap (i+1) 8 (PRad o (insPar 8 l) (insPar 8 r))
-       insPar i (PPrd o l r) = wrap (i+1) 8 (PPrd o (insPar 8 l) (insPar 8 r))
-       insPar _ (PKl0 o e)   = PKl0 o (insPar 10 e)
-       insPar _ (PKl1 o e)   = PKl1 o (insPar 10 e)
-       insPar _ (PFlp o e)   = PFlp o (insPar 10 e)
-       insPar _ (PCpl o e)   = PCpl o (insPar 10 e)
-       insPar i (PBrk _ e)   = insPar i e
-       insPar _ x            = x
-
-
---used to compose error messages at p2a time
-instance ShowADL P_Concept where
- showADL = name
-
-instance ShowADL PAclause where
-    showADL = showPAclause "\n "
-
-showPAclause :: String -> PAclause -> String
-showPAclause indent pa@Do{}
-       = ( case paSrt pa of
-            Ins -> "INSERT INTO "
-            Del -> "DELETE FROM ")++
-         showREL (paTo pa) ++
-         indent++" SELECTFROM "++
-         showADL (paDelta pa)++
-         indent++motivate indent "TO MAINTAIN " (paMotiv pa)
-showPAclause indent (New c clause cj_ruls)
-       = "NEW x:"++show c++";"++indent'++showPAclause indent' (clause "x")++motivate indent "MAINTAINING" cj_ruls
-         where indent'  = indent++"  "
-showPAclause indent (Rmv c clause cj_ruls)
-       = "REMOVE x:"++show c++";"++indent'++showPAclause indent' (clause "x")++motivate indent "MAINTAINING" cj_ruls
-         where indent'  = indent++"  "
-showPAclause indent (CHC ds cj_ruls)
-       = "ONE OF "++intercalate indent' [showPAclause indent' d | d<-ds]++motivate indent "MAINTAINING" cj_ruls
-         where indent'  = indent++"       "
-showPAclause indent (GCH ds cj_ruls)
-       = "ONE NONEMPTY ALTERNATIVE OF "++intercalate indent'
-         ["PICK a,b FROM "++showADL links++indent'++"THEN "++showPAclause (indent'++"     ") p| (_,links,p)<-ds]++
-         motivate indent "MAINTAINING" cj_ruls
-         where indent'  = indent++"       "
-showPAclause indent (ALL ds cj_ruls)
-       = "ALL of "++intercalate indent' [showPAclause indent' d | d<-ds]++motivate indent "MAINTAINING" cj_ruls
-         where indent'  = indent++"       "
-showPAclause indent (Nop cj_ruls)
-       = "DO NOTHING"++motivate indent "TO MAINTAIN" cj_ruls
-showPAclause indent (Blk cj_ruls)
-       = "BLOCK"++motivate indent "CANNOT CHANGE" cj_ruls
-showPAclause  _ (Let _ _ _)  = fatal 55 "showPAclause is missing for `Let`. Contact your dealer!"
-showPAclause  _ (Ref _)      = fatal 56 "showPAclause is missing for `Ref`. Contact your dealer!"
-                     
-motivate :: [Char] -> [Char] -> [(Expression, [Rule])] -> [Char]
-motivate indent motive motives = concat [ indent++showConj cj_rul | cj_rul<-motives ]
-   where showConj (conj,rs) = "("++motive++" "++showADL conj++" FROM "++intercalate ", " (map name rs) ++")"
− src/lib/DatabaseDesign/Ampersand/Fspec/ShowECA.hs 
@@ -1,20 +0,0 @@-{-# OPTIONS_GHC -Wall #-}
-module DatabaseDesign.Ampersand.Fspec.ShowECA (showECA) where
-   import DatabaseDesign.Ampersand.Fspec.Fspec
-   import DatabaseDesign.Ampersand.Fspec.ShowADL            (showPAclause, showREL)
-
-   class ECA a where 
-    showECA :: String -> a -> String
-
-   instance ECA ECArule where
-    showECA indent er = showECA indent (ecaTriggr er)++ " EXECUTE    -- (ECA rule "
-                                                     ++ show (ecaNum er)
-                                                     ++ ")"
-                                                     ++
-                        indent++showECA indent (ecaAction er)
-   instance ECA Event where
-    showECA _ (On Ins rel) = "ON INSERT Delta IN " ++ showREL rel
-    showECA _ (On Del rel) = "ON DELETE Delta FROM " ++ showREL rel
-
-   instance ECA PAclause where
-    showECA indent = showPAclause indent

− src/lib/DatabaseDesign/Ampersand/Fspec/ShowHS.hs 
@@ -1,897 +0,0 @@-{-# OPTIONS_GHC -Wall -XFlexibleInstances #-}-module DatabaseDesign.Ampersand.Fspec.ShowHS (ShowHS(..),ShowHSName(..),fSpec2Haskell,haskellIdentifier)-where-   import DatabaseDesign.Ampersand.Core.ParseTree-   import DatabaseDesign.Ampersand.Core.AbstractSyntaxTree-   import Text.Pandoc hiding (Meta)-   import Data.Char                  (isAlphaNum)-   import DatabaseDesign.Ampersand.Basics-   import DatabaseDesign.Ampersand.Fspec.Plug-   import DatabaseDesign.Ampersand.Fspec.Fspec-   import DatabaseDesign.Ampersand.Fspec.ShowADL    (ShowADL(..))  -- for traceability, we generate comment in the Haskell code.---   import DatabaseDesign.Ampersand.Fspec.FPA   (fpa)-   import Data.List-   import DatabaseDesign.Ampersand.Classes-   import qualified DatabaseDesign.Ampersand.Input.ADL1.UU_Scanner-   import DatabaseDesign.Ampersand.Misc-   import Data.Hashable-   import Data.Ord-   import Data.Function-   -   fatal :: Int -> String -> a-   fatal = fatalMsg "Fspec.ShowHS"--   fSpec2Haskell :: Fspc -> Options -> String-   fSpec2Haskell fSpec flags-           = "{-# OPTIONS_GHC -Wall #-}"-             ++"\n{-Generated code by "++ampersandVersionStr++" at "++show (genTime flags)++"-}"-             ++"\nmodule Main where"-             ++"\n  import DatabaseDesign.Ampersand"-             ++"\n  import Text.Pandoc hiding (Meta)"-             ++"\n  import Prelude hiding (writeFile,readFile,getContents,putStr,putStrLn)"-             ++"\n"-             ++"\n  main :: IO ()"-             ++"\n  main = do flags <- getOptions"-             ++"\n            putStr (showHS flags \"\\n  \" fSpec_"++baseName flags++")"-             ++"\n  fSpec_"++baseName flags++" :: Fspc"-             ++"\n  fSpec_"++baseName flags++"\n   = "++showHS flags "\n     " fSpec---   wrap :: String->String->(String->a->String)->[a]->String-   wrap initStr indent f xs-    = initStr++-      case xs of-        []  -> "[]"-        [x] -> "[ "++f (indent++"  ") x++" ]"-        _   -> "[ "++intercalate (indent++", ") [f (indent++"  ") x | x<-xs]++indent++"]"--   class ShowHSName a where-    showHSName :: a -> String-    -   class ShowHS a where-    showHS :: Options -> String -> a -> String--   instance ShowHSName a => ShowHSName [a] where-    showHSName xs = "["++intercalate "," (map showHSName xs)++"]"-   -   instance ShowHS a => ShowHS [a] where-    showHS flags indent = wrap "" (indent++" ") (showHS flags)-    -   instance ShowHSName a => ShowHSName (Maybe a) where-    showHSName Nothing  = "Nothing"-    showHSName (Just x) = showHSName x-    -   instance ShowHS a => ShowHS (Maybe a) where-    showHS _ _ Nothing  = "Nothing"-    showHS flags indent (Just x) = "Just (" ++ showHS flags indent x ++ ")"---   instance (ShowHSName a , ShowHSName b) => ShowHSName (a,b) where -    showHSName (a,b) = "( "++showHSName a++" , "++showHSName b++" )"-   -- | The following is used to showHS flags for signs: (Concept, Concept)---   instance (ShowHS a , ShowHS b) => ShowHS (a,b) where---    showHS flags indent (a,b) = "("++showHS flags (indent++" ") a++","++showHS flags (indent++" ") b++")"-  -   --   instance ShowHSName PlugSQL where-    showHSName plug = haskellIdentifier ("plug_"++name plug)--   instance ShowHS PlugSQL where-    showHS flags indent plug-      = case plug of-          TblSQL{} -> intercalate indent -                      ["let " ++ intercalate (indent++"    ")-                                             [showHSName f++indent++"     = "++showHS flags (indent++"       ") f | f<-fields plug] ++indent++"in"-                      ,"TblSQL { sqlname = " ++ (show.name) plug-                      ,"       , fields  = ["++intercalate ", " (map showHSName (fields plug))++"]"-                      ,"       , cLkpTbl = [ "++intercalate (indent++"                   , ") ["("++showHSName c++", "++showHSName cn++")" | (c,cn)<-cLkpTbl plug] ++ "]"-                      ,"       , mLkpTbl = [ "++intercalate (indent++"                   , ") ["("++showHS flags "" r++", "++showHSName ms++", "++showHSName mt++")" | (r,ms,mt)<-mLkpTbl plug] ++ "]"-                  --    ,"       , sqlfpa  = " ++ showHS flags "" (fpa plug)-                      ,"       }"-                      ]-          BinSQL{} -> intercalate indent -                      ["let " ++ showHSName (fst (columns plug))++indent++"     = "++showHS flags (indent++"       ") (fst (columns plug))-                              ++ (indent++"    ") ++ showHSName (snd (columns plug))++indent++"     = "++showHS flags (indent++"       ") (snd (columns plug))-                              ++indent++"in"-                      ,"BinSQL { sqlname = " ++ (show.name) plug-                      ,"       , columns = ("++showHSName (fst (columns plug))++ ", " ++showHSName (snd (columns plug))++")"-                      ,"       , cLkpTbl = [ "++intercalate (indent++"                   , ") ["("++showHSName c++", "++showHSName cn++")" | (c,cn)<-cLkpTbl plug] ++ "]"-                      ,"       , mLkp = "++showHS flags "" (mLkp plug)-                  --    ,"       , sqlfpa  = " ++ showHS flags "" (fpa plug)-                      ,"       }"-                      ]-          ScalarSQL{} -> intercalate indent -                      ["ScalarSQL { sqlname   = "++ (show.name) plug-                      ,"          , sqlColumn = "++ showHS flags (indent++"                     ") (sqlColumn plug)-                      ,"          , cLkp      = "++ showHSName (cLkp plug)-                  --    ,"          , sqlfpa    = "++ showHS flags "" (fpa plug)-                      ,"          }"-                      ]--   instance ShowHSName (ECArule) where-    showHSName r = "ecaRule"++show (ecaNum r)--   instance ShowHS (ECArule) where-    showHS flags indent r   -      =         "ECA { ecaTriggr = " ++ showHS flags "" (ecaTriggr r) ++-        indent++"    , ecaDelta  = " ++ showHS flags (indent++"                  ")  (ecaDelta r)++-        indent++"    , ecaAction = " ++ showHS flags (indent++"                  ")  (ecaAction r)++-        indent++"    , ecaNum    = " ++ show (ecaNum r)++-        indent++"    }"--   instance ShowHS Event where-    showHS _ indent e   -      = if "\n" `isPrefixOf` indent-        then "On " ++ show (eSrt e)++indent++"   " ++ showHSName (eDcl e)++indent++"   "-        else "On " ++ show (eSrt e)++          " " ++ showHSName (eDcl e)++           ""--   instance ShowHS (InsDel, Expression, PAclause) where-    showHS flags indent (tOp, links, p)  -      = "( "++show tOp++indent++", "++showHS flags (indent++"  ") links++indent++", "++showHS flags (indent++"  ") p++indent++")"--   instance ShowHS PAclause where-    showHS flags indent p   -      = case p of-           CHC{} -> wrap "CHC " (indent ++"    ") (showHS flags) (paCls p)++-                    wrap (if null ms then "" else indent ++"    ") (indent ++"    ") showMotiv ms-           GCH{} -> wrap "GCH " (indent ++"    ") (showHS flags) (paGCls p)++-                    wrap (if null ms then "" else indent ++"    ") (indent ++"    ") showMotiv ms-           ALL{} -> wrap "ALL " (indent ++"    ") (showHS flags) (paCls p)++-                    wrap (if null ms then "" else indent ++"    ") (indent ++"    ") showMotiv ms-           Do{}  ->  "Do "++show (paSrt p)++ " ("++showHS flags (indent++"        ") (paTo p)++indent++"       )"++-                            indent++"       ("++showHS flags (indent++"        ") (paDelta p)++indent++"       )"++-                    wrap (if null ms then "" else indent ++"    ") (indent ++"    ") showMotiv ms-           New{} -> "New ("++showHS flags "" (paCpt p)++")"++-                    indent++"    (\\x->"++showHS flags (indent++"        ") (paCl p "x")++indent++"    )"++-                    wrap (if null ms then "" else indent ++"    ") (indent ++"    ") showMotiv ms-           Rmv{} -> "Rmv ("++showHS flags "" (paCpt p)++")"++-                    indent++"    (\\x->"++showHS flags (indent++"        ") (paCl p "x")++indent++"    )"++-                    wrap (if null ms then "" else indent ++"    ") (indent ++"    ") showMotiv ms-           Nop{} -> "Nop "++wrap "" (indent ++"    ") showMotiv ms-           Blk{} -> "Blk "++wrap "" (indent ++"    ") showMotiv ms-           Let{} -> wrap "Let " (indent ++"    ") (showHS flags) (paCls p)++-                    "TODO: paBody of Let clause"++-                    wrap (if null ms then "" else indent ++"    ") (indent ++"    ") showMotiv ms             -           Ref{} -> "Ref "++paVar p-        where ms = paMotiv p-              showMotiv ind (conj,rs) = "( "++showHS flags (ind++"  ") conj++" -- conjunct:  "++showADL conj++ind++", "++showHSName rs++ind++")"--   instance ShowHSName SqlField where-    showHSName sqFd = haskellIdentifier ("sqlFld_"++fldname sqFd)--   instance ShowHS SqlField where-    showHS flags indent sqFd-      = intercalate indentA-          [  "Fld { fldname = " ++ show (fldname sqFd)-          ,      ", fldexpr = " ++ showHS flags indentB (fldexpr sqFd)-          ,      ", fldtype = " ++ showHS flags "" (fldtype sqFd)-          ,      ", flduse  = " ++ showHS flags "" (flduse sqFd)-          ,      ", fldnull = " ++ show (fldnull sqFd)-          ,      ", flduniq = " ++ show (flduniq sqFd)-          ,      "}"-          ] where indentA = indent ++"    "         -- adding the width of "Fld "-                  indentB = indentA++"            " -- adding the width of ", fldexpr = " --   instance ShowHS SqlFieldUsage where-    showHS _ _ (TableKey isPrimary aCpt) = "TableKey "  ++show isPrimary++" "++showHSName aCpt-    showHS _ _ (ForeignKey aCpt)         = "ForeignKey "++showHSName aCpt-    showHS _ _ PlainAttr                 = "PlainAttr "--   instance ShowHS SqlType where-    showHS _ indent (SQLChar i)    = indent++"SQLChar   "++show i-    showHS _ indent SQLBlob        = indent++"SQLBlob   "-    showHS _ indent SQLPass        = indent++"SQLPass   "-    showHS _ indent SQLSingle      = indent++"SQLSingle "-    showHS _ indent SQLDouble      = indent++"SQLDouble "-    showHS _ indent SQLText        = indent++"SQLText   "-    showHS _ indent (SQLuInt i)    = indent++"SQLuInt   "++show i-    showHS _ indent (SQLsInt i)    = indent++"SQLsInt   "++show i-    showHS _ indent SQLId          = indent++"SQLId     "-    showHS _ indent (SQLVarchar i) = indent++"SQLVarchar "++show i-    showHS _ indent SQLBool        = indent++"SQLBool   "--   instance ShowHSName Quad where-    showHSName q-      = haskellIdentifier ("quad_"++(showHSName.qDcl) q++"_"++(name.cl_rule.qClauses) q)--   instance ShowHS Quad where-    showHS flags indent q -      = intercalate indent-               [ "Quad{ qDcl     = " ++ showHSName (qDcl q)-               , "    , qClauses = " ++ showHS flags newindent (qClauses q)-               , "    }"-               ]-       where-         newindent = indent ++ "                 "-         -   instance ShowHS Fswitchboard where-    showHS flags indent fsb-      = intercalate indent-          [ "Fswtch { fsbEvIn  = " ++ showHS flags newindent (fsbEvIn  fsb)-          , "       , fsbEvOut = " ++ showHS flags newindent (fsbEvOut fsb)-          ,wrap-            "       , fsbConjs = " newindent' (\_->shConj) (fsbConjs  fsb)-          ,wrap-            "       , fsbECAs  = " newindent' (\_->showHSName) (fsbECAs  fsb)-          , "       }"-          ]-       where -         newindent   = indent ++ "                   "-         newindent'  = newindent ++ " "-         newindent'' = newindent' ++ "    "-         shConj (r,conj) = "( "++showHSName r++newindent++"   , "++showHS flags newindent'' conj++newindent++"   )"--   instance ShowHS Clauses where-    showHS _ indent c-      = intercalate indent-          [ "Clauses{ cl_conjNF = " ++ showHSName (cl_conjNF c)-          , "       , cl_rule   = " ++ showHSName (cl_rule c)-          , "       }"-          ]--   instance ShowHS DnfClause where-    showHS flags indent (Dnf antcs conss)-      = intercalate indent-          [ wrap "Dnf " (indent++"    ") (\_->showHS flags (indent++"      ")) antcs-          , wrap "    " (indent++"    ") (\_->showHS flags (indent++"      ")) conss-          ]--   instance ShowHSName RuleClause where-    showHSName x = haskellIdentifier ("conj_"++rc_rulename x++"["++show (rc_int x)++"]")-    -   instance ShowHS RuleClause where-    showHS flags indent x-      = intercalate (indent ++"  ")-          [   "RC{ rc_int        = " ++ show (rc_int x)-          ,     ", rc_rulename   = " ++ show (rc_rulename x)-          ,     ", rc_conjunct   = " ++ showHS flags indentA (rc_conjunct x)-          ,wrap ", rc_dnfClauses = " indentA (\_->showHS flags (indentA++"  ")) (rc_dnfClauses x)-          ,     "}" -          ]-        where indentA = indent ++"                    "--   instance ShowHSName Fspc where-    showHSName fSpec = haskellIdentifier ("fSpc_"++name fSpec)-   -   instance ShowHS Fspc where-    showHS flags indent fSpec-     = intercalate (indent ++"    ") -           [ "Fspc{ fsName        = " ++ show (name fSpec)-           ,wrap ", fspos         = " indentA (showHS flags) (fspos fSpec)-           ,     ", fsLang        = " ++ show (fsLang fSpec) ++ "  -- the default language for this specification"-           ,     ", themes        = " ++ show (themes fSpec) ++ "  -- the names of themes to be printed in the documentation, meant for partial documentation.  Print all if empty..."-           ,wrap ", pattsInScope  = " indentA (\_->showHSName) (pattsInScope fSpec)-           ,wrap ", procsInScope  = " indentA (\_->showHSName) (procsInScope fSpec)-           ,wrap ", rulesInScope  = " indentA (\_->showHSName) (rulesInScope fSpec)-           ,wrap ", declsInScope  = " indentA (\_->showHSName) (declsInScope fSpec)-           ,wrap ", cDefsInScope  = " indentA (\_->showHS flags (indentA++"  ")) (cDefsInScope fSpec)-           ,wrap ", gensInScope   = " indentA (showHS flags)   (gensInScope fSpec)-           ,wrap ", vprocesses    = " indentA (\_->showHSName) (vprocesses fSpec)-           ,wrap ", vplugInfos    = " indentA (\_->showHS flags (indentA++"  ")) (vplugInfos fSpec)-           ,wrap ", plugInfos     = " indentA (\_->showHS flags (indentA++"  ")) (plugInfos  fSpec)-           ,     ", interfaceS    = interfaceS'"-           ,     ", interfaceG    = interfaceG'"-           ,wrap ", fActivities   = " indentA (\_->showHS flags (indentA++"  ")) (fActivities fSpec)-           ,     ", fRoleRels     = " ++-                 case fRoleRels fSpec of-                   []        -> "[]"-                   [(r,rel)] -> "[ ("++show r++", "++showHS flags "" rel++") ]"-                   _         -> "[ "++intercalate (indentA++", ") ["("++show r++","++showHS flags "" rel++")" | (r,rel)<-fRoleRels fSpec]++indentA++"]"-           ,     ", fRoleRuls     = " ++-                 case fRoleRuls fSpec of-                   []        -> "[]"-                   [(r,rul)] -> "[ ("++show r++", "++showHSName rul++") ]"-                   _         -> "[ "++intercalate (indentA++", ") ["("++show r++","++showHSName rul++")" | (r,rul)<-fRoleRuls fSpec]++indentA++"]"-           ,wrap ", fRoles        = " indentA (\_->id) (fRoles fSpec)-           ,wrap ", vrules        = " indentA (\_->showHSName) (vrules fSpec)-           ,wrap ", grules        = " indentA (\_->showHSName) (grules fSpec)-           ,wrap ", invars        = " indentA (\_->showHSName) (invars fSpec)-           ,wrap ", allRules      = " indentA (\_->showHSName) (allRules fSpec)-           ,wrap ", allUsedDecls  = " indentA (\_->showHSName) (allUsedDecls fSpec)-           ,wrap ", allDecls      = " indentA (\_->showHSName) (allDecls fSpec)-           ,wrap ", vrels         = " indentA (\_->showHSName) (vrels fSpec)-           ,wrap ", allConcepts   = " indentA (\_->showHSName) (allConcepts fSpec)-           ,wrap ", kernels       = " indentA (\_->showHSName) (kernels fSpec)-           ,wrap ", vIndices      = " indentA (\_->showHSName) (vIndices fSpec)-           ,wrap ", vviews        = " indentA (\_->showHSName) (vviews fSpec)-           ,wrap ", vgens         = " indentA (showHS flags)   (vgens fSpec)-           ,wrap ", fsisa         = " indentA (\_->showHSName) (fsisa fSpec)-           ,wrap ", vconjs        = " indentA (\_->showHSName) (vconjs fSpec)-           ,wrap ", vquads        = " indentA (\_->showHSName) (vquads fSpec)-           ,wrap ", vEcas         = " indentA (\_->showHSName) (vEcas fSpec)-           ,     ", fSwitchboard  = "++showHS flags indentA (fSwitchboard fSpec)-           ,wrap ", vpatterns     = " indentA (\_->showHSName) (patterns fSpec)-           ,wrap ", conceptDefs   = " indentA (showHS flags) (conceptDefs fSpec)-           ,wrap ", fSexpls       = " indentA (showHS flags)   (fSexpls fSpec)-           ,     ", metas         = allMetas"-           ,wrap ", initialPops   = " indentA (showHS flags)   (initialPops fSpec)-           ,wrap ", allViolations = " indentA showViolatedRule (allViolations fSpec)-           ,"}" -           ] ++   -       indent++"where"++-        "\n -- ***Interfaces Specified in Ampersand script***: "++-       indent++" interfaceS' = "++(if null (interfaceS fSpec) then "[]" else-                                 "[ "++intercalate (indentB++"  , ") (map showHSName (interfaceS fSpec))++indentB++"  ]")++-        "\n -- ***Activities Generated by the Ampersand compiler ***: " ++-       indent++" interfaceG' = "++(if null (interfaceG fSpec) then "[]" else-                                 "[ "++intercalate (indentB++", ") (map showHSName (interfaceG fSpec))++indentB++"]")++-       indent++" allMetas = "++(if null (metas fSpec) then "[]" else-                                 "[ "++intercalate (indentB++", ") (map (showHS flags (indent ++ "         ")) (metas fSpec))++indentB++"]") ++---- WHY?  staan hier verschillende lijstjes met interfaces?--- BECAUSE! Een Ampersand engineer besteedt veel tijd om vanuit een kennismodel (lees: een graaf met concepten en relaties)---          alle interfaces met de hand te verzinnen.---          Je kunt natuurlijk ook een interfaces-generator aan het werk zetten, die een aantal interfaces klaarzet bij wijze---          van steiger (scaffold). Dat bespaart een hoop werk. De functie interfaceG is zo'n generator.---          Door de gegenereerde interfaces af te drukken, kun je dus heel snel Ampersand sourcecode maken met correct-vertaalbare interfaces.---          Heb je eenmaal een goed werkend pakket interfaces, dan wil je wellicht alleen de door jezelf gespecificeerde interfaces---          gebruiken. Dat gebeurt in interfaceS.--       (if null  (interfaceS fSpec) then ""  else-        "\n -- *** User defined interfaces (total: "++(show.length.interfaceS) fSpec++" interfaces) ***: "++-        concat [indent++" "++showHSName s++indent++"  = "++showHS flags (indent++"    ") s | s<-interfaceS fSpec]++"\n"-       )++-       (if null (interfaceG fSpec ) then "" else-        "\n -- *** Generated interfaces (total: "++(show.length.interfaceG) fSpec++" interfaces) ***: "++-        concat [indent++" "++showHSName x++indent++"  = "++showHS flags (indent++"    ") x |x<-interfaceG fSpec ]++"\n"-       )++        -       (let ds fs = allDecls fs `uni` allUsedDecls fs `uni` vrels fSpec `uni` nub (map qDcl (vquads fs)) in-        if null (ds fSpec)     then "" else-        "\n -- *** Declared relations (in total: "++(show.length.ds) fSpec++" relations) ***: "++-        concat [indent++" "++showHSName x++indent++"  = "++showHS flags (indent++"    ") x |x<-ds fSpec]++"\n"-       ) ++-       (if null (vIndices fSpec)     then "" else-        "\n -- *** Indices (total: "++(show.length.vIndices) fSpec++" indices) ***: "++-        concat [indent++" "++showHSName x++indent++"  = "++showHS flags (indent++"    ") x |x<-vIndices fSpec]++"\n"-       ) ++-       (if null (vviews fSpec)     then "" else-        "\n -- *** Views (total: "++(show.length.vviews) fSpec++" views) ***: "++-        concat [indent++" "++showHSName x++indent++"  = "++showHS flags (indent++"    ") x |x<-vviews fSpec]++"\n"-       ) ++-       (if null (vprocesses fSpec ) then "" else-        "\n -- *** Processes (total: "++(show.length.vprocesses) fSpec++" processes) ***: "++-        concat [indent++" "++showHSName x++indent++"  = "++showHS flags (indent++"    ") x |x<-vprocesses fSpec ]++"\n"++-        concat [indent++" "++showHSName x++indent++"  = "++showHS flags (indent++"    ") x |x<-map fpProc (vprocesses fSpec) ]++"\n"-       ) ++-       (if null (vrules   fSpec ) then "" else-        "\n -- *** User defined rules (total: "++(show.length.vrules) fSpec++" rules) ***: "++-        concat [indent++" "++showHSName x++indent++"  = "++showHS flags (indent++"    ") x |x<-vrules     fSpec ]++"\n"++-        concat [indent++" "++showHSName x++indent++"  = "++showHS flags (indent++"    ") x |x<-map srrel (vrules fSpec)]++"\n"-       )++-       (if null (grules   fSpec ) then "" else-        "\n -- *** Generated rules (total: "++(show.length.grules) fSpec++" rules) ***: "++-        concat [indent++" "++showHSName x++indent++"  = "++showHS flags (indent++"    ") x |x<-grules     fSpec ]++"\n"++-        concat [indent++" "++showHSName x++indent++"  = "++showHS flags (indent++"    ") x |x<-map srrel (grules fSpec)]++"\n"-       )++-       (if null (vconjs fSpec ) then "" else-        "\n -- *** Conjuncts (total: "++(show.length.vconjs) fSpec++" conjuncts) ***: "++-        concat [indent++" "++showHSName x++indent++"  = "++showHS flags (indent++"    ") x |x<-vconjs     fSpec ]++"\n"-       )++-       (if null (vquads fSpec ) then "" else-        "\n -- *** Quads (total: "++(show.length.vquads) fSpec++" quads) ***: "++-        concat [indent++" "++showHSName x++indent++"  = "++showHS flags (indent++"    ") x |x<-vquads     fSpec ]++"\n"-       )++-       (if null (vEcas fSpec ) then "" else-        "\n -- *** ECA rules (total: "++(show.length.vEcas) fSpec++" ECA rules) ***: "++-        concat [indent++" "++showHSName eca++indent++"  = "++showHS flags (indent++"    ") eca |eca<-vEcas fSpec ]++"\n"++-        concat [indent++" "++showHSName rel++indent++"  = "++showHS flags (indent++"    ") rel |rel<-nub(map ecaDelta (vEcas fSpec)) ]++"\n"-       )++-       (if null (plugInfos fSpec ) then "" else-        "\n -- *** PlugInfos (total: "++(show.length.plugInfos) fSpec++" plugInfos) ***: "++-        concat [indent++" "++showHSName p++indent++"  = "++showHS flags (indent++"    ") p |InternalPlug p<-sortBy (compare `on` name) (plugInfos fSpec) ]++"\n"-       )++-       (if null (vpatterns fSpec) then "" else-        "\n -- *** Patterns (total: "++(show.length.vpatterns) fSpec++" patterns) ***: "++-        concat [indent++" "++showHSName x++indent++"  = "++showHS flags (indent++"    ") x |x<-vpatterns fSpec]++"\n"-       )++---       (if null (conceptDefs fSpec) then "" else---        "\n -- *** ConceptDefs (total: "++(show.length.conceptDefs) fSpec++" conceptDefs) ***: "++---        concat [indent++" "++showHSName cd++indent++"  = "++showHS flags (indent++"    ") cd | c<-concs fSpec, cd<-concDefs fSpec c]++"\n"---       )++-       (if null (allConcepts fSpec) then "" else-        "\n -- *** Concepts (total: "++(show.length.allConcepts) fSpec++" concepts) ***: "++-        concat [indent++" "++showHSName x++indent++"  = "++showHS flags (indent++"    ") x-             ++ indent++"    "++showAtomsOfConcept x |x<-sortBy (comparing showHSName) (allConcepts fSpec)]++"\n"-       )-           where indentA = indent ++"                      "-                 indentB = indent ++"             "-                 showAtomsOfConcept c =-                              "-- atoms: [ "++ intercalate indentC strs++"]"-                     where-                       strs = map show (sort (atomsOf (gens fSpec)(initialPops fSpec) c))-                       indentC = if sum (map length strs) > 300-                                 then indent ++ "    --        , "-                                 else ", "-                 showViolatedRule :: String -> (Rule,Pairs) -> String-                 showViolatedRule indent' (r,ps)-                    = intercalate indent'-                        [        " ( "++showHSName r++" -- This is "++(if isSignal r then "a process rule." else "an invariant")++-                         indent'++" , "++ wrap "" (indent'++"   ") (let showPair _ p = show p --"( "++ (show.fst) p++", "++(show.snd) p++")"-                                                                      in showPair) ps++-                         indent'++" )"-                        ] --   instance ShowHS Meta where-    showHS f i (Meta pos obj nm val) = "Meta ("++showHS f i pos ++ ") "++ show obj ++ " " ++ show nm ++ " " ++ show val ---   instance ShowHSName PlugInfo where-    showHSName (InternalPlug p) = haskellIdentifier ("ipl_"++name p)-- TODO-    showHSName (ExternalPlug _) = fatal 336 "a PlugInfo is anonymous with respect to showHS flags"--   instance ShowHS PlugInfo where-    showHS _ _ (InternalPlug p)-     = "InternalPlug "++showHSName p-    showHS flags ind (ExternalPlug o)-     = "ExternalPlug "++showHS flags (ind++"    ") o-   --   instance ShowHS RoleRelation where-    showHS flags ind rr-     = "RR "++show (rrRoles rr)++" "++showHS flags (ind++"    ") (rrRels rr)++" "++showHS flags (ind++"    ") (rrPos rr)-   -   instance ShowHS RoleRule where-    showHS flags ind rs-     = "Maintain "++show (mRoles rs)++" "++show (mRules rs)++" "++showHS flags (ind++"    ") (mPos rs)-   --   instance ShowHSName FSid where-    showHSName (FS_id nm ) = haskellIdentifier nm --   instance ShowHS FSid where-    showHS _ _ (FS_id nm) -      = "(FS_id " ++ show nm ++ ")"-     --   instance ShowHSName Pattern where-    showHSName pat = haskellIdentifier ("pat_"++name pat)-   -   instance ShowHS Pattern where-    showHS flags indent pat-     = intercalate indentA-        [ "A_Pat { ptnm  = "++show (name pat)-        , ", ptpos = "++showHS flags "" (ptpos pat)-        , ", ptend = "++showHS flags "" (ptend pat)-        , ", ptrls = [" ++intercalate ", " [showHSName r | r<-ptrls pat] ++ concat [" {- no rules -} "        | null (ptrls pat)] ++"]"-        , wrap ", ptgns = " indentB (showHS flags) (ptgns pat)-        , ", ptdcs = [ " ++intercalate (indentB++", ") [showHSName d | d<-ptdcs pat] ++ concat [" {- no relations -} " | null (ptdcs pat)] ++indentB++"]"-        , wrap ", ptups = " indentB (showHS flags) (ptups pat) -        , case ptrruls pat of-           []          -> ", ptrruls = [] {- no role-rule assignments -}"-           [(rol,rul)] -> ", ptrruls = [ ("++show rol++", "++showHSName rul++") ]"-           rs          -> ", ptrruls = [ "++intercalate (indentB++", ") ["("++show rol++", "++showHSName rul++")" | (rol,rul)<-rs] ++indentB++"]"-        , case ptrrels pat of-           []          -> ", ptrrels = [] {- no role-relation assignments -}"-           [(rol,rel)] -> ", ptrrels = [ ("++show rol++", "++showHS flags "" rel++") ]"-           rs          -> ", ptrrels = [ "++intercalate (indentB++", ") ["("++show rol++", "++showHS flags "" rel++")" | (rol,rel)<-rs] ++indentB++"]"-        , wrap ", ptids = " indentB (showHS flags) (ptids pat)-        , wrap ", ptxps = " indentB (showHS flags) (ptxps pat)-        , "}"-        ] where indentA = indent ++"      "     -- adding the width of "A_Pat "-                indentB = indentA++"          " -- adding the width of ", ptrls = "--   instance ShowHSName FProcess where-    showHSName prc = haskellIdentifier ("fprc_"++name (fpProc prc))-   -   instance ShowHS FProcess where-    showHS flags indent prc-     = intercalate indentA-        [ "FProc { fpProc       = "++showHSName (fpProc prc)-        , wrap  ", fpActivities = " indentB (showHS flags) (fpActivities prc)-        , "      }"-        ] where indentA = indent ++"      "     -- adding the width of "FProc "-                indentB = indentA++"                 " -- adding the width of ", fpActivities = "- -   instance ShowHSName Process where-    showHSName prc = haskellIdentifier ("prc_"++name prc)--   instance ShowHS Process where-    showHS flags indent prc-     = intercalate indentA-        [ "Proc { prcNm = "++show (name prc)-        , ", prcPos = "++showHS flags "" (prcPos prc)-        , ", prcEnd = "++showHS flags "" (prcEnd prc)-        , ", prcRules = [" ++intercalate ", " [showHSName r | r<-prcRules prc] ++ concat [" {- no rules -} "                     | null (prcRules prc)] ++"]"-        , wrap ", prcGens = " indentB (showHS flags) (prcGens prc)-        , ", prcDcls = ["  ++intercalate ", " [showHSName d | d<-prcDcls  prc] ++ concat [" {- no relations -} "              | null (prcDcls  prc)] ++"]"-        , wrap ", prcUps = " indentB (showHS flags) (prcUps prc) -        , case prcRRuls prc of-           []          -> ", prcRRuls = [] {- no role-rule assignments -}"-           [(rol,rul)] -> ", prcRRuls = [ ("++show rol++", "++showHSName rul++") ]"-           rs          -> ", prcRRuls = [ "++intercalate (indentB++", ") ["("++show rol++", "++showHSName rul++")" | (rol,rul)<-rs] ++indentB++"]"-        , case prcRRels prc of-           []          -> ", prcRRels = [] {- no role-relation assignments -}"-           [(rol,rel)] -> ", prcRRels = [ ("++show rol++", "++showHS flags "" rel++") ]"-           rs          -> ", prcRRels = [ "++intercalate (indentB++", ") ["("++show rol++", "++showHS flags "" rel++")" | (rol,rel)<-rs] ++indentB++"]"-        , wrap ", prcIds = " indentB (showHS flags) (prcIds prc)-        , wrap ", prcVds = " indentB (showHS flags) (prcVds prc)-        , wrap ", prcXps = " indentB (showHS flags) (prcXps prc)-        , "}"-        ] where indentA = indent ++"      "     -- adding the width of "FProc "-                indentB = indentA++"             " -- adding the width of ", prcRules = "---   instance ShowHS Activity where-    showHS flags indent act = -       intercalate indentA-        [ "Act { actRule   = "++showHSName (actRule act)-        , wrap ", actTrig   = " indentB (\_->showHSName) (actTrig   act)-        , wrap ", actAffect = " indentB (\_->showHSName) (actAffect act)-        , wrap ", actQuads  = " indentB (\_->showHSName) (actQuads  act)-        , wrap ", actEcas   = " indentB (\_->showHSName) (actEcas   act)-        , wrap ", actPurp   = " indentB (\_->(showHS flags indentB)) (actPurp act)-        , "      }"-        ]-       where indentA = indent ++replicate (length "Act "          ) ' ' -             indentB = indentA++replicate (length ", actAffect = ") ' '--   instance ShowHS PPurpose where-    showHS flags _ expl = -       "PRef2 ("++showHS flags "" (pexPos     expl)++") "++-             "("++showHS flags "" (pexObj     expl)++") "++-             "("++showHS flags "" (pexMarkup  expl)++") "-                ++show (intercalate ";" (pexRefIDs expl))++" "-                -   instance ShowHS PRef2Obj where-    showHS _ _ peObj-     = case peObj of -            PRef2ConceptDef str               -> "PRef2ConceptDef " ++show str-            PRef2Declaration (PTrel _ nm sgn) -> "PRef2Declaration "++show nm++show sgn-            PRef2Declaration (Prel _ nm)      -> "PRef2Declaration "++show nm-            PRef2Declaration expr             -> fatal 583 ("Expression "++show expr++" should never occur in PRef2Declaration")-            PRef2Rule str                     -> "PRef2Rule "       ++show str-            PRef2IdentityDef str              -> "PRef2IdentityDef "++show str-            PRef2ViewDef str                  -> "PRef2ViewDef "    ++show str-            PRef2Pattern str                  -> "PRef2Pattern "    ++show str-            PRef2Process str                  -> "PRef2Process "    ++show str-            PRef2Interface str                -> "PRef2Interface "  ++show str-            PRef2Context str                  -> "PRef2Context "    ++show str-            PRef2Fspc str                     -> "PRef2Fspc "       ++show str-                           -   instance ShowHS Purpose where-    showHS flags _ expla = -       "Expl "++"("++showHS flags "" (explPos expla)++") "-              ++"("++showHS flags "" (explObj expla)++") "-                   ++showHS flags "" (explMarkup  expla)++" "-                   ++show (explUserdefd expla)++" "-                   ++show (explRefIds expla)++" "--   instance ShowHS ExplObj where-    showHS flags i peObj = case peObj of-             ExplConceptDef cd  -> "ExplConceptDef " ++showHS flags i cd-             ExplDeclaration d  -> "ExplDeclaration "++showHSName d-             ExplRule str       -> "ExplRule "       ++show str-             ExplIdentityDef str-> "ExplIdentityDef "++show str-             ExplViewDef str    -> "ExplViewDef "    ++show str-             ExplPattern str    -> "ExplPattern "    ++show str-             ExplProcess str    -> "ExplProcess "    ++show str-             ExplInterface str  -> "ExplInterface "  ++show str-             ExplContext str    -> "ExplContext "    ++show str-           -   instance ShowHS P_Markup where-    showHS _ indent m-      = intercalate indent -        ["P_Markup{ mLang   = "++ show (mLang m)-        ,"        , mFormat = "++ show (mFormat m)-        ,"        , mString = "++ show (mString m)-        ,"        }"-        ]--   instance ShowHS A_Markup where-    showHS _ indent m-      = intercalate indent -        ["A_Markup{ amLang   = "++ show (amLang m)-        ,"        , amFormat = "++ show (amFormat m)-        ,"        , amPandoc = "++ show (amPandoc m)-        ,"        }"-        ]--   instance ShowHS (PairView Expression) where-     showHS flags indent (PairView pvs) = "PairView "++showHS flags indent pvs-     -   instance ShowHS (PairViewSegment Expression) where-     showHS _     _ (PairViewText txt) = "PairViewText "++show txt-     showHS flags _ (PairViewExp srcOrTgt e) = "PairViewExp "++show srcOrTgt++" ("++showHS flags "" e++")"---   instance ShowHSName Rule where-    showHSName r = haskellIdentifier ("rule_"++ rrnm r)--   instance ShowHS Rule where-    showHS flags indent r@(Ru _ _ _ _ _ _ _ _ _ _ _ _)  -- This pattern matching occurs so Haskell will detect any change in the definition of Ru.-      = intercalate indent -        ["Ru{ rrnm   = " ++ show (rrnm   r)-        ,"  , rrexp  = -- " ++ showADL (rrexp  r) ++ indent++"             " ++ showHS flags (indent++"             ") (rrexp  r)-        ,"  , rrfps  = " ++ showHS flags "" (rrfps  r)-        ,"  , rrmean = " ++ showHS flags (indent++"             ") (rrmean r)-        ,"  , rrmsg  = " ++ showHS flags "" (rrmsg  r)-        ,"  , rrviol = " ++ showHS flags "" (rrviol r)-        ,"  , rrtyp  = " ++ showHS flags "" (rrtyp  r)-        ,"  , rrdcl  = " ++ case rrdcl r of-                              Just (p,d) -> "Just ("++showHSName p++", "++showHSName d++" )"-                              Nothing    -> "Nothing"-        ,"  , r_env  = " ++ show (r_env  r)-        ,"  , r_usr  = " ++ show (r_usr  r)-        ,"  , isSignal = " ++ show (isSignal  r)-        ,"  , srrel  = " ++ showHSName (srrel  r)-        ,"  }"-        ]--   instance ShowHS AMeaning where-     showHS flags indent (AMeaning x) = "AMeaning " ++ showHS flags (indent++"        ") x --   instance ShowHS RuleType where-     showHS _ _ Truth          = "Truth"-     showHS _ _ Equivalence    = "Equivalence"-     showHS _ _ Implication    = "Implication"-   --   instance ShowHSName IdentityDef where-    showHSName identity = haskellIdentifier ("identity_"++name identity)-   -   instance ShowHS IdentityDef where-    showHS flags indent identity-     = "Id ("++showHS flags "" (idPos identity)++") "++show (idLbl identity)++" ("++showHSName (idCpt identity)++")"-       ++indent++"  [ "++intercalate (indent++"  , ") (map (showHS flags indent) $ identityAts identity)++indent++"  ]"-   --   -   instance ShowHS IdentitySegment where-    showHS flags indent (IdentityExp objDef) = "IdentityExp ("++ showHS flags indent objDef ++ ")"---   instance ShowHSName ViewDef where-    showHSName vd = haskellIdentifier ("vdef_"++name vd)-   -   instance ShowHS ViewDef where-    showHS flags indent vd-     = "Vd ("++showHS flags "" (vdpos vd)++") "++show (vdlbl vd)++" "++showHSName (vdcpt vd)-       ++indent++"  [ "++intercalate (indent++"  , ") (map (showHS flags indent) $ vdats vd)++indent++"  ]"-   --   --instance ShowHSName ViewSegment where-   -- showHSName vd = haskellIdentifier ("vdef_"++name vd)-   -   instance ShowHS ViewSegment where-    showHS _     _      (ViewText str)   = "ViewText "++show str-    showHS _     _      (ViewHtml str)   = "ViewHtml "++show str-    showHS flags indent (ViewExp objDef) = "ViewExp "++ showHS flags (indent++"            ") objDef-   -   instance ShowHS Population where-    showHS _ indent pop-     = case pop of -         PRelPopu{} -> "PRelPopu { popdcl = "++showHSName (popdcl pop)-             ++indent++"         , popps  = [ "++intercalate -              (indent++"                    , ") (map show (popps pop))-             ++indent++"                    ]"-             ++indent++"         }"-         PCptPopu{} -> "PCptPopu { popcpt = "++showHSName (popcpt pop)-             ++indent++"         , popas  = [ "++intercalate-              (indent++"                    , ") (map show (popas pop))-             ++indent++"                    ]"-             ++indent++"         }"-   -   instance ShowHSName ObjectDef where-    showHSName obj = haskellIdentifier ("oDef_"++name obj)--   instance ShowHS ObjectDef where-    showHS flags indent r -     = intercalate indent-           ["Obj{ objnm   = " ++ show(objnm r)-           ,"   , objpos  = " ++ showHS flags "" (objpos r)  -           ,"   , objctx  = " ++ showHS flags (indent++"               ") (objctx r)-           ,"   , objmsub = " ++ showHS flags (indent++"                    ") (objmsub r)-           ,"   , objstrs = " ++ show(objstrs r)-           ]++indent++"   }"--   instance ShowHSName Interface where-    showHSName obj = haskellIdentifier ("ifc_"++name obj)-   -   instance ShowHS Interface where-    showHS flags indent ifc-     = intercalate indent -           [ wrap "Ifc { ifcParams = " (indent++"                  ") (showHS flags) (ifcParams ifc)-           , "    , ifcArgs   = " ++ show(ifcArgs ifc)-           , "    , ifcRoles  = " ++ show(ifcRoles ifc)-           , "    , ifcObj"++indent++"       = " ++ showHS flags (indent++"         ") (ifcObj ifc)-           , "    , ifcPos    = " ++ showHS flags "" (ifcPos ifc)-           , "    , ifcPrp    = " ++ show(ifcPrp ifc)-           ]++indent++"    }"--   instance ShowHS SubInterface where-    showHS _     _      (InterfaceRef n) = "InterfaceRef "++show n -    showHS flags indent (Box x objs) = "Box ("++showHS flags indent x++")"++indent++"     ("++showHS flags (indent++"     ") objs++")" --   instance ShowHS Expression where-    showHS flags indent (EEqu (l,r)) = "EEqu ("++showHS flags (indent++"      ") l++indent++"     ,"++showHS flags (indent++"      ") r++indent++"     )"-    showHS flags indent (EImp (l,r)) = "EImp ("++showHS flags (indent++"      ") l++indent++"     ,"++showHS flags (indent++"      ") r++indent++"     )"-    showHS flags indent (EIsc (l,r)) = "EIsc ("++showHS flags (indent++"      ") l++indent++"     ,"++showHS flags (indent++"      ") r++indent++"     )"-    showHS flags indent (EUni (l,r)) = "EUni ("++showHS flags (indent++"      ") l++indent++"     ,"++showHS flags (indent++"      ") r++indent++"     )"-    showHS flags indent (EDif (l,r)) = "EDif ("++showHS flags (indent++"      ") l++indent++"     ,"++showHS flags (indent++"      ") r++indent++"     )"-    showHS flags indent (ELrs (l,r)) = "ELrs ("++showHS flags (indent++"      ") l++indent++"     ,"++showHS flags (indent++"      ") r++indent++"     )"-    showHS flags indent (ERrs (l,r)) = "ERrs ("++showHS flags (indent++"      ") l++indent++"     ,"++showHS flags (indent++"      ") r++indent++"     )"-    showHS flags indent (EDia (l,r)) = "EDia ("++showHS flags (indent++"      ") l++indent++"     ,"++showHS flags (indent++"      ") r++indent++"     )"-    showHS flags indent (ECps (l,r)) = "ECps ("++showHS flags (indent++"      ") l++indent++"     ,"++showHS flags (indent++"      ") r++indent++"     )"-    showHS flags indent (ERad (l,r)) = "ERad ("++showHS flags (indent++"      ") l++indent++"     ,"++showHS flags (indent++"      ") r++indent++"     )"-    showHS flags indent (EPrd (l,r)) = "EPrd ("++showHS flags (indent++"      ") l++indent++"     ,"++showHS flags (indent++"      ") r++indent++"     )"-    showHS flags indent (EKl0 e    ) = "EKl0 ("++showHS flags (indent++"      ") e++")"-    showHS flags indent (EKl1 e    ) = "EKl1 ("++showHS flags (indent++"      ") e++")"-    showHS flags indent (EFlp e    ) = "EFlp ("++showHS flags (indent++"      ") e++")"-    showHS flags indent (ECpl e    ) = "ECpl ("++showHS flags (indent++"      ") e++")"-    showHS flags indent (EBrk e    ) = "EBrk ("++showHS flags (indent++"      ") e++")"-    showHS _     _      (EDcD dcl  ) = "EDcD "++showHSName dcl-    showHS _     _      (EDcI c    ) = "EDcI "++showHSName c-    showHS flags _      (EEps i sgn) = "EEps ("++showHS flags "" i++") ("++showHS flags "" sgn++")"-    showHS flags _      (EDcV sgn  ) = "EDcV ("++showHS flags "" sgn++")"-    showHS _     _      (EMp1 a c  ) = "EMp1 " ++show a++" "++showHSName c--   instance ShowHS Sign where-    showHS _ _ sgn = "Sign "++showHSName (source sgn)++" "++showHSName (target sgn)-   -   instance ShowHS A_Gen where-    showHS _ _ gen =-      case gen of -        Isa{} -> "Isa "++showHSName (genspc gen)++" "++showHSName (gengen gen)++" "-        IsE{} -> "IsE "++showHSName (genspc gen)++" ["++intercalate ", " (map showHSName (genrhs gen))++"] "-   -   instance ShowHSName Declaration where-    showHSName d@Isn{}       = haskellIdentifier ("rel_"++name d++"_"++name (source d)) -- identity relation-    showHSName d@Vs{}        = haskellIdentifier ("rel_"++name d++"_"++name (source d)++name (target d)) -- full relation-    showHSName d | decusr d  = haskellIdentifier ("rel_"++name d++name (source d)++name (target d)) -- user defined relations-                 | deciss d  = haskellIdentifier ("sgn_"++name d++name (source d)++name (target d)) -- relations generated for signalling-                 | otherwise = haskellIdentifier ("vio_"++name d++name (source d)++name (target d)) -- relations generated per rule-   -   instance ShowHS Declaration where-    showHS flags indent d -       = case d of -          Sgn{}     -> intercalate indent-                        ["Sgn{ decnm   = " ++ show (decnm d)-                        ,"   , decsgn  = " ++ showHS flags "" (sign d)-                        ,"   , decprps = " ++ showL(map (showHS flags "") (decprps d))-                        ,"   , decprps_calc = " ++ case decprps_calc d of-                                                    Nothing -> "Nothing"-                                                    Just ps -> "Just "++showL(map (showHS flags "") ps)-                        ,"   , decprL  = " ++ show (decprL d)-                        ,"   , decprM  = " ++ show (decprM d)-                        ,"   , decprR  = " ++ show (decprR d)-                        ,"   , decMean = " ++ show (decMean d)-                        ,"   , decfpos = " ++ showHS flags "" (decfpos d)-                        ,"   , deciss  = " ++ show (deciss d)-                        ,"   , decusr  = " ++ show (decusr d)-                        ,"   , decpat  = " ++ show (decpat d)-                        ,"   , decplug = " ++ show (decplug d)-                        ]++"}"-          Isn{}     -> "Isn{ detyp   = " ++ showHSName (detyp d)++"}"-          Vs{}      -> "Vs { decsgn  = " ++ showHS flags "" (sign d)++"}"-----   instance ShowHSName ConceptDef where---    showHSName cd = haskellIdentifier ("cDef_"++cdcpt cd)--   instance ShowHS ConceptDef where-    showHS flags _ cd-     = " Cd ("++showHS flags "" (cdpos cd)++") "++show (cdcpt cd)++" "++show (cdplug cd)++" "++show (cddef cd)++" "++show (cdtyp cd)++" "++show (cdref cd)++" "++show (cdfrom cd)-   instance ShowHSName Char where-    showHSName c = show c-   instance ShowHS Char where-    showHS _ _ c = show c-   instance ShowHSName A_Concept where-    showHSName ONE = haskellIdentifier "cptOne"-    showHSName c = haskellIdentifier ("cpt_"++name c) -   instance ShowHS A_Concept where-    showHS _ _ c = case c of-                       PlainConcept{} -> "PlainConcept "++show (name c)-                       ONE -> "ONE"--   instance ShowHS FPcompl where-    showHS _ _   = show--   instance ShowHS FPA where-    showHS _ _ (FPA t c) = "FPA "++show t++" "++show c-   -   instance ShowHSName Prop where-    showHSName Uni = "Uni"-    showHSName Inj = "Inj"-    showHSName Sur = "Sur"-    showHSName Tot = "Tot"-    showHSName Sym = "Sym"-    showHSName Asy = "Asy"-    showHSName Trn = "Trn"-    showHSName Rfx = "Rfx"-    showHSName Irf = "Irf"--   instance ShowHS Prop where-    showHS _ _ = showHSName-    -   instance ShowHS FilePos where-    showHS _ _ (FilePos (fn,DatabaseDesign.Ampersand.Input.ADL1.UU_Scanner.Pos l c,sym))-      = "FilePos ("++show fn++",Pos "++show l++" "++show c++","++show sym++")"--   instance ShowHSName Origin where-    showHSName ori = "Orig"++show x++show (hash x)-      where x = case ori of-                 FileLoc l -> "FileLoc (" ++ show l++")"-                 DBLoc l   -> "DBLoc " ++ show l-                 Origin s  -> "Origin " ++ show s-                 OriginUnknown -> "OriginUnknown"-   -   instance ShowHS Origin where-    showHS flags indent (FileLoc l) = "FileLoc (" ++ showHS flags indent l++")"-    showHS _     _      (DBLoc l)   = "DBLoc "  ++ show l-    showHS _     _      (Origin s)  = "Origin " ++ show s-    showHS _     _    OriginUnknown = "OriginUnknown"---   instance ShowHS Block where-    showHS _ _   = show---   instance ShowHS Inline where-    showHS _ _   = show----   instance ShowHS InfTree where---    showHS flags indent itree =---        case itree of---          InfExprs irt (ratype,raobj) itrees -> ---              "InfExprs " ++ showHS flags indent irt ++ ---              indent ++ "   (" ++ showRaType ratype ++ "," ++ "RelAlgObj{-"++show raobj++"-}" ++ ")" ++---              indent ++ showHS flags (indent ++ "     ") itrees---          InfRel drt ratype _ _ -> ---              "InfRel " ++ showHS flags indent drt ++ " " ++ showRaType ratype---      where ---       showRaType rat = "RelAlgType{-"++show rat++"-}"------   instance ShowHS RelDecl where---    showHS _ indent d = case d of ---                          RelDecl{}-> "RelDecl{ dname  = " ++ show (dname d) ++ indent---                                   ++ "        ,dtype  = " ++ showRaType dtype ++ indent---                                   ++ "        ,isendo = " ++ show (isendo d) ---                          IDecl    -> "IDecl"---                          VDecl    -> "VDecl"---      where ---       showRaType _ = "RelAlgType{- ++TODO++ -}"---------   instance ShowHS DeclRuleType where---    showHS _ _ drt = case drt of---                                         D_rel     -> "D_rel"---                                         D_rel_h   -> "D_rel_h"---                                         D_rel_c   -> "D_rel_c"---                                         D_rel_c_h -> "D_rel_c_h"---                                         D_id      -> "D_id"---                                         D_v       -> "D_v"---                                         D_id_c    -> "D_id_c"---                                         D_v_c     -> "D_v_c"---                        ---   instance ShowHS InfRuleType where---    showHS _ _ irt = case irt of---                                         ISect_cs  -> "ISect_cs"---                                         ISect_ncs -> "ISect_ncs"---                                         ISect_mix -> "ISect_mix"---                                         Union_mix -> "Union_mix"---                                         Comp_ncs  -> "Comp_ncs"---                                         Comp_c1   -> "Comp_c1"---                                         Comp_c2   -> "Comp_c2"---                                         Comp_cs   -> "Comp_cs"---                                         RAdd_ncs  -> "RAdd_ncs"---                                         RAdd_c1   -> "RAdd_c1"---                                         RAdd_c2   -> "RAdd_c2"---                                         RAdd_cs   -> "RAdd_cs"---                                         Conv_nc   -> "Conv_nc"---                                         Conv_c    -> "Conv_c"-                                           --- \***********************************************************************--- \*** hulpfuncties                                                    ***--- \***********************************************************************--   haskellIdentifier :: String -> String-   haskellIdentifier cs = unCap (hsId cs)-    where-      hsId ('_': cs')             = '_': hsId cs'-      hsId (c:cs') | isAlphaNum c = c: hsId cs'-                   | otherwise    = hsId cs'-      hsId ""                     = ""--   showL :: [String] -> String-   showL xs = "["++intercalate "," xs++"]"
− src/lib/DatabaseDesign/Ampersand/Fspec/ShowMeatGrinder.hs 
@@ -1,322 +0,0 @@-{-# OPTIONS_GHC -Wall #-}
-{-# LANGUAGE TypeSynonymInstances #-}
-{-# LANGUAGE FlexibleInstances #-} 
-module DatabaseDesign.Ampersand.Fspec.ShowMeatGrinder 
-  (meatGrinder)
-where
-
-import Data.List
-import Data.Ord
-import DatabaseDesign.Ampersand.Fspec.Fspec
-import DatabaseDesign.Ampersand.Fspec.Motivations
-import DatabaseDesign.Ampersand.Basics
-import DatabaseDesign.Ampersand.Misc
-import DatabaseDesign.Ampersand.Fspec.ShowADL
-import DatabaseDesign.Ampersand.Core.AbstractSyntaxTree
-import DatabaseDesign.Ampersand.ADL1.Pair
-import Data.Hashable
-import Data.Maybe
-
-fatal :: Int -> String -> a
-fatal = fatalMsg "Fspec.ShowMeatGrinder"
-
-meatGrinder :: Options -> Fspc -> (FilePath, String)
-meatGrinder flags fSpec = ("TemporaryPopulationsFileOfRap" ,content)
- where 
-  content = unlines
-     ([ "{- Do not edit manually. This code has been generated!!!"
-      , "    Generated with "++ampersandVersionStr
-      , "    Generated at "++show (genTime flags)
-      , "-}"
-      , ""
-      , "CONTEXT RapPopulations"]
-      ++ (concat.intersperse  []) (map (lines.showADL) (metaPops flags fSpec fSpec)) 
-      ++
-      [ ""
-      , "ENDCONTEXT"
-      ])
-data Pop = Pop { popName ::String
-               , popSource :: String
-               , popTarget :: String
-               , popPairs :: [(String,String)]
-               } 
-         | Comment { comment :: String  -- Not-so-nice way to get comments in a list of populations. Since it is local to this module, it is not so bad, I guess...
-                   } 
-instance ShowADL Pop where
- showADL pop = 
-  case pop of
-      Pop{} -> "POPULATION "++ popName pop++
-                  " ["++popSource pop++" * "++popTarget pop++"] CONTAINS"
-              ++
-              if null (popPairs pop)
-              then "[]" 
-              else "\n"++indent++"[ "++intercalate ("\n"++indent++"; ") showContent++indent++"]"
-      Comment{} -> "-- "++comment pop        
-    where indent = "   "
-          showContent = map showPaire (popPairs pop)
-          showPaire (s,t) = "( "++show s++" , "++show t++" )"
-
-
-techId :: Identified a => a -> String
-techId = show.hash.name
-class AdlId a where
- uri :: a -> String
-
-instance AdlId Fspc where 
- uri a= "Ctx"++techId a
-instance AdlId Pattern where 
- uri a= "Pat"++techId a
-instance AdlId A_Concept where 
- uri a= "Cpt"++techId a
-instance AdlId ConceptDef where 
- uri a= "CDf"++techId a
-instance AdlId Rule where 
- uri a= "Rul"++techId a
-instance AdlId A_Gen where 
- uri a= "Gen"++(show.hash) g
-        where g = case a of
-                    Isa{} -> ((name.gengen) a++(name.genspc) a)
-                    IsE{} -> ((concat.map name.genrhs) a++(name.genspc) a)
-instance AdlId Declaration where 
- uri a= "Dcl"++techId a
-instance AdlId Purpose where 
- uri a= "Prp"++(show.hash)((show.origin) a)
-instance AdlId Sign where 
- uri (Sign s t) = "Sgn"++(show.hash) (uri s++uri t)
-instance AdlId Paire where
- uri p = "Paire"++(show.hash) (srcPaire p++"_"++trgPaire p)
- 
-data RelPopuType = InitPop | CurrPop deriving Show
-mkUriRelPopu :: Declaration -> RelPopuType  -> String
-mkUriRelPopu d t = show t++"Of"++uri d
-
-instance AdlId Atom where
- uri a="Atm"++atmVal a++"Of"++(uri.atmRoot) a  
-
-
-mkAtom :: A_Concept -> String -> Atom
-mkAtom cpt value = Atom { atmRoot = cpt -- Was: root cpt.  <SJ 20131117> Han, "root cpt" cannot be correct in this spot. I am quite sure that "cpt" is correct. Please confer.
-                        , atmVal  = value
-                        }
-
-class MetaPopulations a where
- metaPops :: Options -> Fspc -> a -> [Pop]
-
-instance MetaPopulations Fspc where
- metaPops flags _ fSpec = 
-   filter (not.nullContent)
-    (
-    [ Comment " "
-    , Comment "The following relations are all known to be declared. This list"
-    , Comment "should be helpful during the developement of the meatgrinder."
-    , Comment "NOTE:"
-    , Comment "  The order of the relations is determined in a special way, based on Concepts."
-    ]
-  ++[Comment ("  "++show i++") "++"Pop "++(show.name) dcl++" "++(show.name.source) dcl++" "++(show.name.target) dcl) | (i,dcl) <- (declOrder.allDecls)       fSpec]
-  ++[ Pop "ctxnm"   "Context" "Conid"
-           [(uri fSpec,name fSpec)]
-    ]
-  ++[ Comment " ", Comment $ "*** Patterns: (count="++(show.length.vpatterns) fSpec++") ***"]
-  ++   concat [metaPops flags fSpec pat | pat <- (sortBy (comparing name).vpatterns  )    fSpec]
-  ++[ Comment " ", Comment $ "*** Rules: (count="++(show.length.allRules) fSpec++")***"]
-  ++   concat [metaPops flags fSpec rul | rul <- (sortBy (comparing name).allRules)    fSpec]
-
-
-  ++[ Comment " ", Comment $ "*** Concepts: (count="++(show.length.allConcepts) fSpec++")***"]
-  ++   concat [metaPops flags fSpec cpt | cpt <- (sortBy (comparing name).allConcepts)    fSpec]
-  ++[ Comment " ", Comment $ "*** Generalisations: (count="++(show.length.vgens) fSpec++") ***"]
-  ++   concat [metaPops flags fSpec gen | gen <- vgens          fSpec]
-  ++[ Comment " ", Comment $ "*** Declarations: (count="++(show.length.allDecls) fSpec++") ***"]
-  ++   concat [metaPops flags fSpec dcl | (_,dcl) <- (declOrder.allDecls)       fSpec]
-  ++[ Comment " ", Comment $ "*** Atoms: ***"]
-  ++   concat [metaPops flags fSpec atm | atm <- allAtoms]
-  )
-   where
-    allAtoms :: [Atom]
-    allAtoms = nub (concatMap atoms (initialPops fSpec))
-      where 
-        atoms :: Population -> [Atom]
-        atoms udp = case udp of
-          PRelPopu{} ->  map (mkAtom ((source.popdcl) udp).srcPaire) (popps udp) 
-                      ++ map (mkAtom ((target.popdcl) udp).trgPaire) (popps udp) 
-          PCptPopu{} ->  map (mkAtom (        popcpt  udp)         ) (popas udp)
-    nullContent :: Pop -> Bool
-    nullContent (Pop _ _ _ []) = True
-    nullContent _ = False
-    -- | the order of relations is done by an order of the concepts, which is a hardcoded list 
-    declOrder ::[Declaration] -> [(Int,Declaration)]
-    declOrder decls = zip [1..] (concatMap (sortBy f) (declGroups conceptOrder decls))
-      where 
-        conceptOrder = ["Pattern"
-                       ,"Rule"
-                       ,"Declaration"
-                       ,"RelPopu"
-                       ,"A_Concept"
-                       ,"Concept"
-                       ]
-        f a b =
-          case comparing (name.source) a b of
-            EQ -> case comparing (name.target) a b of
-                    EQ -> comparing (name) a b 
-                    x  -> x
-            x -> x
-        declGroups :: [String] -> [Declaration] -> [[Declaration]]
-        declGroups [] ds = [ds]
-        declGroups (nm:nms) ds = [x] ++ declGroups nms y
-           where
-             (x,y) = partition crit ds
-             crit dcl = or [(name.source) dcl == nm, (name.target) dcl == nm]
-instance MetaPopulations Pattern where
- metaPops _ fSpec pat = 
-   [ Comment " "
-   , Comment $ "*** Pattern `"++name pat++"` ***"
-   , Pop "ctxpats" "Context" "Pattern"
-          [(uri fSpec,uri pat)]
-   , Pop "ptxps"   "Pattern" "Blob"
-          [(uri pat,uri x) | x <- ptxps pat]
-   , Pop "ptnm"    "Pattern" "Conid"
-          [(uri pat, ptnm pat)]
--- following fiedls would be double (ptctx = ~ctxpats)
---   , Pop "ptctx" "Pattern" "Context"
---          [(uri pat,uri fSpec)]
-   , Pop "ptdcs"   "Pattern" "Declaration"
-          [(uri pat,uri x) | x <- ptdcs pat]
-   , Pop "ptgns"   "Pattern" "Gen"
-          [(uri pat,uri x) | x <- ptgns pat]
---HJO, 20130728: TODO: De Image (Picture) van het pattern moet worden gegenereerd op een of andere manier:
---   , Pop "ptpic"   "Pattern" "Image"
---          [(uri pat,uri x) | x <- ptpic pat]
-   , Pop "ptrls"   "Pattern" "Rule"
-          [(uri pat,uri x) | x <- ptrls pat]
-   ]
-instance MetaPopulations Rule where
- metaPops _ fSpec rul =
-   [ Comment " "
-   , Comment $ "*** Rule `"++name rul++"` ***"
-   , Pop "rrnm"  "Rule" "ADLid"
-          [(uri rul,rrnm rul)]
-   , Pop "rrmean"  "Rule" "Blob"
-          [(uri rul,show(rrmean rul))]
-   , Pop "rrpurpose"  "Rule" "Blob"
-          [(uri rul,showADL x) | x <- explanations rul]
-   , Pop "rrexp"  "Rule" "ExpressionID"
-          [(uri rul,showADL (rrexp rul))]
---HJO, 20130728: TODO: De Image (Picture) van de rule moet worden gegenereerd op een of andere manier:
---   , Pop "rrpic"   "Rule" "Image"
---          [(uri rul,uri x) | x <- rrpic pat]
-   , Pop "rrviols"  "Rule" "Violation"
-          [(uri rul,show v) | (r,v) <- allViolations fSpec, r == rul]
-
-   ]
-instance MetaPopulations Declaration where
- metaPops _ fSpec dcl = 
-   case dcl of 
-     Sgn{} ->
-      [ Comment " "
-      , Comment $ "*** Declaration `"++name dcl++" ["++(name.source.decsgn) dcl++" * "++(name.target.decsgn) dcl++"]"++"` ***"
-      , Pop "decmean"    "Declaration" "Blob"
-             [(uri dcl, show(decMean dcl))]
-      , Pop "decpurpose" "Declaration" "Blob"
-             [(uri dcl, showADL x) | x <- explanations dcl]
---      , Pop "decexample"    "Declaration" "PragmaSentence"
---             [(uri dcl, unwords ["PRAGMA",show (decprL dcl),show (decprM dcl),show (decprR dcl)])]
-      , Pop "decprps" "Declaration" "PropertyRule"
-             [(uri dcl, uri rul) | rul <- filter ofDecl (allRules fSpec)]
-      , Pop "declaredthrough" "PropertyRule" "Property" 
-             [(uri rul,show prp) | rul <- filter ofDecl (allRules fSpec), Just (prp,d) <- [rrdcl rul], d == dcl]
-      , Pop "decpopu" "Declaration" "PairID"
-             [(uri dcl,mkUriRelPopu dcl CurrPop)] 
---      , Pop "inipopu" "Declaration" "PairID"
---             [(uri dcl,mkUriRelPopu dcl InitPop)] 
-      , Pop "decsgn" "Declaration" "Sign"
-             [(uri dcl,uri (decsgn dcl))]
-      , Pop "decprL" "Declaration" "String"
-             [(uri dcl,decprL dcl)]
-      , Pop "decprM" "Declaration" "String"
-             [(uri dcl,decprM dcl)]
-      , Pop "decprR" "Declaration" "String"
-             [(uri dcl,decprR dcl)]
-      , Pop "decnm" "Declaration" "Varid"
-             [(uri dcl, name dcl)]
- --TODO HIER GEBLEVEN. (HJO, 20130802)
-
---      , Pop "cptos" "PlainConcept" "AtomID"
---      , Pop "exprvalue" "ExpressionID" "Expression"
---      , Pop "rels" "ExpressionID" "Declaration"
---relnm : Relation × Varid The name of a relation used as a relation token.
---relsgn : Relation × Sign The sign of a relation.
---reldcl : Relation × Declaration A relation token refers to a relation.
---rrnm : Rule × ADLid The name of a rule.
---rrexp : Rule × ExpressionID The rule expressed in relation algebra.
---rrmean : Rule × Blob The meanings of a rule.
---rrpurpose : Rule × Blob The purposes of a rule.
-      ] 
-             
-     Isn{} -> fatal 157 "Isn is not implemented yet"
-     Vs{}  -> fatal 158 "Vs is not implemented yet"
-    where
-      ofDecl :: Rule -> Bool
-      ofDecl rul = case rrdcl rul of
-                     Nothing -> False
-                     Just (_,d) -> d == dcl   
-instance MetaPopulations Atom where
- metaPops _ _ _ = []
---   [ Pop "root"  "AtomID" "Concept"
---          [(uri atm,uri(atmRoot atm))]
---   , Pop "atomvalue"  "AtomID" "AtomValue"
---          [(uri atm,atmVal atm)]
---   ]
-instance MetaPopulations Paire where
- metaPops _ _ p =
-  [ Pop "left" "PairID" "AtomID"
-         [(uri p, srcPaire p)]
-  , Pop "right" "PairID" "AtomID"
-         [(uri p, trgPaire p)]
-  ]
-instance MetaPopulations A_Gen where
- metaPops _ _ gen =
-  [ Pop "genspc"  "Gen" "PlainConcept"
-            [(uri gen,uri(genspc gen))]
-  ]++
-  case gen of
-   Isa{} ->
-     [ Pop "gengen"  "Gen" "PlainConcept"
-            [(uri gen,uri(gengen gen))]
-     ] 
-   IsE{} ->
-     [ Pop "genrhs"  "Gen" "PlainConcept"
-          [(uri gen,uri c) | c<-genrhs gen]
-     ]
-instance MetaPopulations A_Concept where
- metaPops _ fSpec cpt = 
-   case cpt of
-     PlainConcept{} ->
-      [ Comment " "
-      , Comment $ "*** Concept `"++name cpt++"` ***"
-      , Pop "ctxcs"   "Context" "PlainConcept"
-           [(uri fSpec,uri cpt)]
-      , Pop "cptnm"      "Concept" "Conid"   
-             [(uri cpt, name cpt)]
--- removed: equals ctxcs~
---     , Pop "context"    "PlainConcept" "Context"
---             [(uri cpt,uri fSpec)]
--- removed:
---    , Pop "cpttp"      "PlainConcept" "Blob"
---           [(uri cpt,cpttp cpt) ]
--- removed:
---    , Pop "cptdf"      "PlainConcept" "Blob"
---           [(uri cpt,showADL x) | x <- cptdf cpt]
-      , Pop "cptpurpose" "PlainConcept" "Blob"
-             [(uri cpt,showADL x) | lang <- [English,Dutch], x <- fromMaybe [] (purposeOf fSpec lang cpt) ]
-      ]
-     ONE -> [
-            ]
-instance MetaPopulations Sign where
- metaPops _ _ sgn = 
-      [ Pop "src"    "Sign" "Concept"
-             [(uri sgn, uri (source sgn))]
-      , Pop "trg"   "Sign" "Concept"
-             [(uri sgn, uri (target sgn))]
-      ]
-
-   
− src/lib/DatabaseDesign/Ampersand/Fspec/ShowXMLtiny.hs 
@@ -1,331 +0,0 @@-{-# OPTIONS_GHC -Wall #-}
-{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}
-module DatabaseDesign.Ampersand.Fspec.ShowXMLtiny (showXML)
-where
-
--- TODO: Als het Ampersand bestand strings bevat met speciale characters als '&' en '"', dan wordt nu nog foute XML-code gegenereerd...
-
-   import DatabaseDesign.Ampersand.ADL1
---   import DatabaseDesign.Ampersand.Core.AbstractSyntaxTree
-   import DatabaseDesign.Ampersand.Classes
-   import DatabaseDesign.Ampersand.Fspec.ShowADL 
-   import DatabaseDesign.Ampersand.Basics
-   import DatabaseDesign.Ampersand.Fspec.Fspec
-   import Data.Time.LocalTime
-   import DatabaseDesign.Ampersand.Fspec.Plug 
-   import DatabaseDesign.Ampersand.Misc.TinyXML 
-   import Data.List
-   
-   fatal :: Int -> String -> a
-   fatal = fatalMsg "Fspec.ShowXMLtiny"
-
-   showXML :: Fspc -> LocalTime -> String
-   showXML fSpec now 
-            = validXML 
-               ("<?xml version=\"1.0\" encoding=\"utf-8\"?>" ++
-                "<tns:ADL xmlns:tns=\"http://ampersand.sourceforge.net/ADL\" "++
-                "xmlns:xsi=\"http://www.w3.org/2001/XMLSchema-instance\" "++
-                "xsi:schemaLocation=\"http://ampersand.sourceforge.net/AdlDocs "++
-                "ADL.xsd \">"++
-                "<!-- Generated with "++ ampersandVersionStr ++", at "++ show now ++" -->" ++
-                "<!-- Warning: The format of this generated xml document is subject to changes, and it"++
-                " isn't very stable. Please notify the developers of Ampersand if you have specific needs. -->")
-              ++
-              showXTree ( mkXmlTree fSpec) ++
-              "</tns:ADL>"   
-
-   nameToAttr :: Identified x => x -> XAtt 
-   nameToAttr x = mkAttr "name" (name x)
-
-   ----------------------------------------------------------------------
-  
-   class XML a where 
-    mkTag :: a -> XTag
-    mkXmlTree :: a -> XTree
-   
-   still2bdone :: String -> XTree
-   still2bdone worktxt = Node (Tag "NotImplementedYet" [mkAttr "work2do_in_ShowXML.hs"  worktxt])     
-
-
-   instance XML Fspc where
-     mkTag f = Tag "Fspec" [nameToAttr f] 
-     mkXmlTree f@Fspc{}
-        = Elem (mkTag f) ( 
-             []
---          ++ [ Elem (simpleTag "Plugs-In-Ampersand-Script")     (map mkXmlTree (vplugs f))]
---          ++ [ Elem (simpleTag "Plugs-also-derived-ones") (map mkXmlTree (plugs f))]
-          ++ [ Elem (simpleTag "Patterns")     (map mkXmlTree (patterns f))] 
-          ++ [ Elem (simpleTag "InterfaceS")   (map mkXmlTree (interfaceS f))] 
-          ++ [ Elem (simpleTag "InterfaceG")   (map mkXmlTree (interfaceG f))] 
-      --    ++ [ Elem (simpleTag "Activities")   (map mkXmlTree (interfaces f))] 
-          ++ [ Elem (simpleTag "Rules")        (map mkXmlTree (vrules f))] 
-          ++ [ Elem (simpleTag "GRules")       (map mkXmlTree (grules f))] 
-          ++ [ Elem (simpleTag "Declarations") (map mkXmlTree (vrels f))] 
-          ++ [ Elem (simpleTag "Violations")   (map violation2XmlTree (allViolations f))]
-          ++ [ still2bdone "Ontology" ] -- ++ [ Elem (simpleTag "Ontology") [mkXmlTree hhh] 
-          ++ [ Elem (simpleTag "Explanations") (map mkXmlTree (fSexpls f))]
-                 )
-             where violation2XmlTree :: (Rule,[Paire]) -> XTree
-                   violation2XmlTree (r,ps) = 
-                     Elem (Tag "Violation" [] )
-                      (
-                       Elem (simpleTag "ViolatedRule") [mkXmlTree r]
-                       :[Elem (simpleTag "Culprits")(map mkXmlTree ps)]
-                      )
-                 
-   instance XML Activity where
-     mkTag _ = Tag "Activity" [] 
-     mkXmlTree act
-        = Elem (mkTag act) (  
-             [ Elem (simpleTag "Rule")               [mkXmlTree (actRule act)]]
-          ++ [ Elem (simpleTag "Editable Relations") (map mkXmlTree (actTrig   act)) |not (null (actTrig   act))] 
-          ++ [ Elem (simpleTag "Affected Relations") (map mkXmlTree (actAffect act)) |not (null (actAffect act))] 
-          ++ [ Elem (simpleTag "Affected Quads")     []] -- TODO
-          ++ [ Elem (simpleTag "ECArules")           (map mkXmlTree (actEcas   act)) |not (null (actEcas   act))] 
-          ++ [ Elem (simpleTag "Explanations")       (map mkXmlTree (actPurp   act)) |not (null (actPurp   act))] 
-           )
-
-   instance XML FPA where
-     mkTag _ = Tag "FPA" [] 
-     mkXmlTree fpa'
-        = Elem (mkTag fpa') []  -- TODO make content for this XML field
-
-
-   instance XML Pattern where
-     mkTag pat = Tag "Pattern" [ nameToAttr pat]
-     mkXmlTree pat
-        = Elem (mkTag pat) (  
-             [ Elem (simpleTag "Rules")        (map mkXmlTree (ptrls pat)) |not (null (ptrls pat))] 
-          ++ [ Elem (simpleTag "Gens")         (map mkXmlTree (ptgns pat)) |not (null (ptgns pat))] 
-          ++ [ Elem (simpleTag "Declarations") (map mkXmlTree (ptdcs pat)) |not (null (ptdcs pat))] 
-          ++ [ Elem (simpleTag "Keys")         (map mkXmlTree (ptids pat)) |not (null (ptids pat))] 
-          ++ [ Elem (simpleTag "Explanations") (map mkXmlTree (ptxps pat)) |not (null (ptxps pat))] 
-           )
-
-   instance XML Rule where
-     mkTag r = Tag "Rule" [mkAttr "ruleId" (name r)]
-     mkXmlTree r
-      = Elem (mkTag r)
-             [Elem (simpleTag "Expression")   [PlainText (showADL (rrexp r))]]
-   
-   instance XML IdentityDef where
-     mkTag k = Tag "IdentityDef" [nameToAttr k]
-     mkXmlTree k = Elem (mkTag k)
-                        ( Elem (simpleTag "Identity on") [mkXmlTree (idCpt k)] :
-                          attributesTree [e | IdentityExp e <- identityAts k] -- TODO: currently ignores ViewText and ViewHtml segments
-                        )
-
-
-   instance XML Interface where
-     mkTag x = Tag "Interface" [ nameToAttr x]
-     mkXmlTree x
-           = Elem (mkTag x) []
-                      --TODO: moet nog verder uitgewerkt.
-
-   
-   instance XML ObjectDef where
-     mkTag x = Tag "ObjectDef" [ nameToAttr x]
-     mkXmlTree x@Obj{} 
-           = Elem (mkTag x)
-                      ( descriptionTree (objctx x)
-                     ++ attributesTree (attributes x)
-                     ++ [Elem (simpleTag "Directives")
-                              [PlainText (show (objstrs x))] |not (null (objstrs x))]
-                      )    --TODO: De directieven moeten waarschijnlijk nog verder uitgewerkt.
-
-
-   instance XML Expression where
-     mkTag _  = fatal 184 "mkTag should not be used for expressions."
-     mkXmlTree expr 
-         = case expr of
-               (EEqu (l,r)) -> Elem (simpleTag "EQUI") (map mkXmlTree [l,r])
-               (EImp (l,r)) -> Elem (simpleTag "IMPL") (map mkXmlTree [l,r])
-               (EIsc (l,r)) -> Elem (simpleTag "CONJ") (map mkXmlTree [l,r])
-               (EUni (l,r)) -> Elem (simpleTag "DISJ") (map mkXmlTree [l,r])
-               (EDif (l,r)) -> Elem (simpleTag "DIFF") (map mkXmlTree [l,r])
-               (ELrs (l,r)) -> Elem (simpleTag "LRES") (map mkXmlTree [l,r])
-               (ERrs (l,r)) -> Elem (simpleTag "RRES") (map mkXmlTree [l,r])
-               (EDia (l,r)) -> Elem (simpleTag "DIAM") (map mkXmlTree [l,r])
-               (ECps (l,r)) -> Elem (simpleTag "RMUL") (map mkXmlTree [l,r])
-               (ERad (l,r)) -> Elem (simpleTag "RADD") (map mkXmlTree [l,r])
-               (EPrd (l,r)) -> Elem (simpleTag "RPRD") (map mkXmlTree [l,r])
-               EKl0 e       -> Elem (simpleTag "CLS0") [mkXmlTree e]
-               EKl1 e       -> Elem (simpleTag "CLS1") [mkXmlTree e]
-               EFlp e       -> Elem (simpleTag "CONV") [mkXmlTree e]
-               ECpl e       -> Elem (simpleTag "CMPL") [mkXmlTree e]
-               EBrk e       -> mkXmlTree e
-               EDcD dcl     -> Elem (simpleTag "EDcD") [mkXmlTree dcl]
-               EDcI c       -> Elem (simpleTag "EDcI") [mkXmlTree c]
-               EEps i sgn   -> Elem (simpleTag "EEps") [mkXmlTree i,mkXmlTree sgn]
-               EDcV sgn     -> Elem (simpleTag "EDcV") [mkXmlTree sgn]
-               EMp1 atm c   -> Elem (simpleTag ("ATOM="++atm)) [mkXmlTree c]
-
-   instance XML PPurpose where
-     mkTag expl =
-       Tag "PRef2" atts
-        
---        = case expl of
---                PRef2ConceptDef{}  -> Tag "ExplConceptDef"  atts
---                PRef2Declaration{} -> Tag "ExplDeclaration" atts
---                PRef2Rule{}        -> Tag "ExplRule"        atts
---                PRef2IdentityDef{} -> Tag "ExplIdentityDef" atts
---                PRef2Pattern{}     -> Tag "ExplPattern"     atts
---                PRef2Process{}     -> Tag "ExplProcess"     atts
---                PRef2Interface{}   -> Tag "ExplInterface"   atts
---                PRef2Context{}     -> Tag "ExplContext"     atts
---                PRef2Fspc{}        -> Tag "ExplContext"     atts
-           where
-            atts ::  [XAtt]
-            atts = [mkAttr "Explains" (name expl)
-                   ,mkAttr "Markup" (show(pexMarkup expl))
-                   ,mkAttr "Ref" (intercalate ";" (pexRefIDs expl))]
-     mkXmlTree expl 
-         = Elem (mkTag expl) [PlainText (show (pexMarkup expl))]
-
-   instance XML Purpose where
-     mkTag _ = Tag "Purp" [mkAttr "TODO" "Generate XML code for Purpose"] 
-                           --  [mkAttr "Purpose" (show expl)
-                           --  ,mkAttr "Markup" (show (explMarkup expl))
-                           --  ,mkAttr "Ref" (intersperse ";" (explRefIds expl))]
-
---        = case expl of
---                ExplConceptDef  cdef  lang ref _ -> Tag "ExplConceptDef"  (atts cdef lang ref)
---                ExplDeclaration d     lang ref _ -> Tag "ExplDeclaration" (atts (name d++name(source d)++name(target d)) lang ref)
---                ExplRule        rname lang ref _ -> Tag "ExplRule"        (atts rname lang ref)
---                ExplIdentityDef kname lang ref _ -> Tag "ExplIdentityDef" (atts kname lang ref)
---                ExplViewDef     kname lang ref _ -> Tag "ExplViewDef"     (atts kname lang ref)
---                ExplPattern     pname lang ref _ -> Tag "ExplPattern"     (atts pname lang ref)
---                ExplProcess     pname lang ref _ -> Tag "ExplProcess"     (atts pname lang ref)
---                ExplInterface   cname lang ref _ -> Tag "ExplInterface"   (atts cname lang ref)
---                ExplContext     cname lang ref _ -> Tag "ExplContext"     (atts cname lang ref)
---           where
---            atts :: String -> Lang -> String -> [XAtt]
---            atts str lang ref = [mkAttr "Explains" str
---                                ,mkAttr "Lang" (show lang)
---                                ,mkAttr "Ref" ref]
-     mkXmlTree expl 
-         = Elem (mkTag expl) [PlainText ((validXML.show.explMarkup) expl)]
-
-
-   instance XML A_Gen where
-     mkTag g@Isa{} = Tag "Isa" (mkAttr "Specific" (show (genspc g))
-                                :[mkAttr "Generic" (show (gengen g))]
-                               )
-     mkTag g@IsE{} = Tag "IsE" (mkAttr "Specific" (show (genspc g))
-                                :[mkAttr "Generics" (show c) | c<-genrhs g]
-                               )
-     mkXmlTree g = Node (mkTag g) 
-
-   instance XML Sign where
-     mkTag sgn = Tag "Sign" (mkAttr "Source" (show (source sgn))
-                            :[mkAttr "Target" (show (target sgn))]
-                            )
-     mkXmlTree sgn = Node (mkTag sgn) 
-
-   instance XML Declaration where
-     mkTag d = Tag "Association" ([nameToAttr d]
-                                ++[ mkAttr "type" t]
-                                ++ extraAtts )
-            where t = case d of
-                        Sgn{} -> "Sgn"
-                        Isn{} -> "Isn"
-                        Vs{} -> "Vs"
-                  extraAtts = case d of
-                                Sgn{} -> [mkAttr "IsSignal" (show (deciss d))]
-                                _     -> []
-            
-     mkXmlTree d = Elem (mkTag d)
-        (case d of  
-          Sgn{} 
-                ->  [Node (Tag "Source" [mkAttr "concept" (name(source d))])]
-                  ++[Node (Tag "Target" [mkAttr "concept" (name(target d))])]
-                  ++[Elem (simpleTag "MultFrom") [PlainText (multiplicity (multiplicities d))]]
-                  ++[Elem (simpleTag "MultTo") [PlainText (multiplicity (map flp (multiplicities d)))]]
-                  ++[Elem (simpleTag "Pragma") 
-                             [PlainText (show (prL++"%f"++prM++"%t"++prR))] 
-                                | not (null (prL++prM++prR))]
-                  ++[Elem (simpleTag "Meaning") [PlainText "Still 2 be done"]
-                    --         [PlainText (explainContent2String LaTeX True (decMean d))]
-                    ]
---                  ++[Elem (simpleTag "Population") 
---                             (map mkXmlTree (decpopu d)) 
---                                | not (null (decpopu d))]                 
-          Isn{}
-                ->  [Elem (simpleTag "Type") [mkXmlTree (source d)]]
-          Vs{}
-                ->  Elem (simpleTag "Generic") [mkXmlTree (source d)]
-                    :[Elem (simpleTag "Specific")[mkXmlTree (target d)]]
-           ) 
-       where
-         multiplicity ms | null ([Sur,Inj]>-ms) = "1"
-                         | null (    [Inj]>-ms) = "0..1"
-                         | null ([Sur]    >-ms) = "1..n"
-                         | otherwise            = "0..n"
-         prL = decprL d
-         prM = decprM d
-         prR = decprR d
-
-   instance XML Paire where
-     mkTag p = Tag "link" atts
-                where
-                   atts = mkAttr "from" (srcPaire p)
-                          :[mkAttr "to"   (trgPaire p)]
-     mkXmlTree p = Elem (mkTag p) []
-                        
-   instance XML ConceptDef where
-     mkTag f = Tag "ConceptDef" ( mkAttr "name" (cdcpt f)
-                                  : [mkAttr "Trace" (cdref f) |not (null (cdref f))])
-     mkXmlTree f = Elem (mkTag f) (explainTree (cddef f))
-   
-
-   instance XML A_Concept where
-     mkTag f = Tag "A_Concept" [nameToAttr f]
-     mkXmlTree f
-        = Node (mkTag f)  
-
-
-   instance XML (ECArule) where
-     mkTag _ = Tag "ECArule" []
-     mkXmlTree _ = still2bdone "ECArule"
-   
-   instance XML (Declaration->ECArule) where
-     mkTag _ = Tag "ECArule" []
-     mkXmlTree _ = still2bdone "Declaration->ECArule"
-   
-   instance XML PlugSQL where --TODO151210 -> tags for BinSQL and ScalarSQL
-     mkTag p = Tag "PlugSql" [ nameToAttr p]
-     mkXmlTree p 
-      = Elem (mkTag p) 
-             [ Elem (simpleTag "Fields") (map mkXmlTree (fields p))]
-   instance XML SqlField where
-      mkTag x = Tag "Field" (   [mkAttr "name" (fldname x)]
-                              ++[mkAttr "type" (showSQL (fldtype x))]
-                              ++[mkAttr "null" (show (fldnull x))]
-                              ++[mkAttr "uniq" (show (flduniq x))]
-                              ++[mkAttr "auto" (show (fldauto x))]
-                              )
-      mkXmlTree sf = Elem (mkTag sf)
-                        [Elem (simpleTag "Expression") [mkXmlTree (fldexpr sf)]]
-                        
-   attributesTree :: [ObjectDef] -> [XTree]
-   attributesTree atts = [Elem (simpleTag "Attributes") 
-                               (map mkXmlTree atts)    |not(null atts)]
-
-   descriptionTree :: Expression -> [XTree]
-   descriptionTree f = [Elem (simpleTag "Description")
-                           [mkXmlTree f] ]
-
-   explainTree :: String -> [XTree]
-   explainTree str = [Elem (simpleTag "Explanation")
-                           [PlainText (validXML str)] | not (null str)]
-                           
-                           
-   -- | XML has a special set of characters that cannot be used in normal XML strings. 
-   validXML :: String -> String
-   validXML []       = []
-   validXML ('&':s)  = "&amp;"++validXML s
-   validXML ('<':s)  = "&lt;"++validXML s
-   validXML ('>':s)  = "&gt;"++validXML s
-   validXML ('"':s)  = "&quot;"++validXML s
-   validXML ('\'':s) = "&#39;"++validXML s
-   validXML (c:s)    = c:validXML s
− src/lib/DatabaseDesign/Ampersand/Fspec/Switchboard.hs 
@@ -1,258 +0,0 @@-{-# OPTIONS_GHC -Wall #-}
-module DatabaseDesign.Ampersand.Fspec.Switchboard
-    (SwitchBdDiagram(..),switchboardAct,sbDiagram,processModel) where
- 
-   import Data.GraphViz
-   import Data.GraphViz.Attributes.Complete
-   import Data.List
-   import DatabaseDesign.Ampersand.Basics        (fatalMsg,Identified(..), flp)
-   import DatabaseDesign.Ampersand.ADL1
-   import DatabaseDesign.Ampersand.Classes
-   import DatabaseDesign.Ampersand.Fspec.Fspec
-   import DatabaseDesign.Ampersand.Fspec.ShowADL (ShowADL(..), LanguageDependent(..))
-   import Data.String
-   
---   import DatabaseDesign.Ampersand.Fspec.ShowECA (showECA) -- for testing purposes
-   
-   fatal :: Int -> String -> a
-   fatal = fatalMsg "Fspec.Switchboard"
-
-   data SwitchBdDiagram
-    = SBdgrm { sbName :: String
-             , sbdotGraph :: DotGraph String
-             }
-   instance Identified SwitchBdDiagram where
-      name = sbName
-
-   processModel :: FProcess -> DotGraph String
-   processModel fp
-    = DotGraph { strictGraph = False
-               , directedGraph = True
-               , graphID = Just (Str (fromString "Process Model"))
-               , graphStatements 
-                  = DotStmts { attrStmts = [GraphAttrs [{-Splines SplineEdges,-} RankDir FromLeft]]
-                             , subGraphs = []
-                             , nodeStmts = activityNodes
-                             , edgeStmts = edges
-                             }
-               }
-      where
-         activityNodes = [ DotNode { nodeID         = "act_"++name a
-                                   , nodeAttributes = [Style [SItem Filled []], FillColor [WC(X11Color Orange) Nothing], Label (StrLabel (fromString (name a)))]
-                                   }
-                         | a<-fpActivities fp]
-         edges         = nub
-                         [ DotEdge { fromNode = "act_"++name from
-                                   , toNode   = "act_"++name to
-                                   , edgeAttributes = [Len 2, Label (StrLabel (fromString (show e++" "++name d))), Dir Forward]
-                                   }
-                         | (from,to,e,d) <- allEdges
-                         ]
-         allEdges  = nub[(from,to,e,d) | (e,d,from)<-eventsOut, (e',d',to)<-eventsIn, e==e', d==d']
-{-
-data Activity = Act { actRule ::   Rule
-                    , actTrig ::   [Relation]
-                    , actAffect :: [Relation]
-                    , actQuads ::  [Quad]
-                    , actEcas ::   [ECArule]
-                    , actPurp ::   [Purpose]
-                    }
-data ECArule= ECA { ecaTriggr :: Event     -- The event on which this rule is activated
-                  , ecaDelta :: Relation  -- The delta to be inserted or deleted from this rule. It actually serves very much like a formal parameter.
-                  , ecaAction :: PAclause  -- The action to be taken when triggered.
-                  , ecaNum :: Int       -- A unique number that identifies the ECArule within its scope.
-                  }
-data Event = On { eSrt :: InsDel
-                  , eRel :: Relation
-                  } deriving (Show,Eq)
--}
-         eventsIn  = [(e,d,act) | act<-fpActivities fp, eca<-actEcas act, let On e d = ecaTriggr eca]
-         eventsOut = [(e,d,act) | act<-fpActivities fp, eca<-actEcas act, (e,d)<-(nub.evs.ecaAction) eca]
-                     where evs :: PAclause -> [(InsDel,Declaration)]
-                           evs clause
-                             = case clause of
-                                CHC{} -> (concat.map evs) (paCls clause)
-                                GCH{} -> concat [ evs p | (_,_,p)<-paGCls clause]
-                                ALL{} -> (concat.map evs) (paCls clause)
-                                Do{}  -> [(paSrt clause, paTo clause)]
-                                New{} -> evs (paCl clause "")
-                                Rmv{} -> evs (paCl clause "")
-                                Nop{} -> []
-                                Blk{} -> []
-                                Let{} -> fatal 305 "events for let undetermined"
-                                Ref{} -> fatal 306 "events for Ref undetermined"
-
-   colorRule :: Rule -> X11Color
-   colorRule r  | isSignal r = Orange
-                | otherwise  = Green
-
-   sbDiagram :: Fspc -> SwitchBdDiagram
-   sbDiagram fSpec 
-    = SBdgrm
-        { sbName = name fSpec
-        , sbdotGraph
-           = DotGraph { strictGraph = False
-                      , directedGraph = True
-                      , graphID = Just (Str (fromString "Switchboard"))
-                      , graphStatements 
-                         = DotStmts { attrStmts = [GraphAttrs [Splines SplineEdges, RankDir FromLeft]]
-                                    , subGraphs = []
-                                    , nodeStmts = inEvNodes++conjNodes++ecaNodes++outEvNods
-                                    , edgeStmts = edgesEvCj++edgesCjEc++edgesEcEv
-                                    }
-                      }
-        }
-      where
-        fsb = fSwitchboard fSpec
-        --DESCR -> The relations from which changes can come
-        inEvNodes = [ DotNode { nodeID         = nameINode eventsIn ev
-                              , nodeAttributes = [Label (StrLabel (fromString (show (eSrt ev)++" "++showADL (eDcl ev))))]
-                              }
-                    | ev<-eventsIn
-                    ]
-        --DESCR -> All conjuncts
-        conjNodes = [ DotNode { nodeID         = nameCNode (fsbConjs fsb) (rul,c)
-                              , nodeAttributes = [Style [SItem Filled []], FillColor [WC(X11Color (colorRule rul)) Nothing], (Label . StrLabel . fromString . name) rul]
-                              }
-                    | (rul,c)<-fsbConjs fsb]
-
-        --DESCR -> All ECA rules
-        ecaNodes  = [ DotNode { nodeID         = nameENode (fsbECAs fsb) eca
-                              , nodeAttributes = if isBlk (ecaAction eca)
-                                                 then [Style [SItem Filled []], FillColor [WC(X11Color Red)Nothing], (Label . StrLabel . fromString) ("ERR #"++show (ecaNum eca))]
-                                                 else [(Label . StrLabel . fromString. showADL) eca]
-                              }
-                    | eca<-fsbECAs fsb, not (isBlk (ecaAction eca))]
-
-        --DESCR -> The relations to which changes are made
-        outEvNods = [ DotNode { nodeID         = nameONode eventsOut ev
-                              , nodeAttributes = [Label (StrLabel (fromString (show (eSrt ev)++" "++showADL (eDcl ev))))]
-                              }
-                    | ev<-eventsOut
-                    ]
-        --DESCR -> Each edge represents an insert between a relation on the left and a term on the right to which the relation contributes to an insert.
-        edgesEvCj = [ DotEdge { fromNode = nameINode eventsIn ev
-                              , toNode   = nameCNode (fsbConjs fsb) (rul,c)
-                              , edgeAttributes = [Dir Forward]
-                              }
-                    | (rul,c)<-fsbConjs fsb, ev<-eventsIn, eDcl ev `elem` relsUsedIn c]
-        edgesCjEc = [ DotEdge { fromNode = nameCNode (fsbConjs fsb) (rul,c)
-                              , toNode   = nameENode (fsbECAs fsb) eca
-                              , edgeAttributes = [Dir Forward]
-                              }
-                    | (rul,c)<-fsbConjs fsb, eca<-fsbECAs fsb, not (isBlk (ecaAction eca)), rul `elem` concat [r | (_,r)<-paMotiv (ecaAction eca)] ]
-        edgesEcEv = nub
-                    [ DotEdge { fromNode = nameENode (fsbECAs fsb) eca
-                              , toNode   = nameONode eventsOut (On tOp rel)
-                              , edgeAttributes = [Dir Forward]
-                              }
-                    | eca<-fsbECAs fsb, not (isBlk (ecaAction eca))
-                    , On tOp rel<-eventsFrom (ecaAction eca)
-                    ]
-        nameINode = nmLkp fSpec "in_"
-        nameCNode = nmLkp fSpec "cj_"
-        nameENode = nmLkp fSpec "eca_"
-        nameONode = nmLkp fSpec "out_"
-        eventsIn  = nub [ecaTriggr eca | eca<-fsbECAs fsb, not (isBlk (ecaAction eca)) ]
-        eventsOut = nub [evt | eca<-fsbECAs fsb, let act=ecaAction eca, not (isBlk act), evt<-eventsFrom act]
-
-   switchboardAct :: Fspc -> Activity -> SwitchBdDiagram
-   switchboardAct fSpec act
-    = SBdgrm
-        { sbName = name act
-        , sbdotGraph
-           = DotGraph { strictGraph = False
-                      , directedGraph = True
-                      , graphID = Just (Str (fromString "Switchboard"))
-                      , graphStatements 
-                         = DotStmts { attrStmts = [GraphAttrs [Splines SplineEdges, RankDir FromLeft]]
-                                    , subGraphs = []
-                                    , nodeStmts = inMorNodes++conjunctNodes++outMorNodes
-                                    , edgeStmts = edgesIn++edgesOut
-                                    }
-                      }
-        }
-      where
-        fromRels     = nub (actTrig act)
-        toRels :: [Declaration]
-        toRels       = nub (actAffect act)
-        conjuncts    = nub [(cl_rule ccrs,c)
-                           | Quad _ ccrs<-actQuads act, c<- map rc_conjunct (cl_conjNF ccrs)]
-        --DESCR -> The relations from which changes can come
-        inMorNodes    = [ DotNode { nodeID         = nameINode fromRels r
-                                  , nodeAttributes = [Label (StrLabel (fromString (showADL r)))]
-                                  }
-                        | r<-fromRels
-                                                  --TODOHAN        , (not.null) [e |e<-edgesIn, (nodeID  (fromNode e))==nameINode fromRels r]
-                        ]
-
-        --DESCR -> The relations to which changes are made
-        outMorNodes   = [ DotNode { nodeID         = nameONode toRels r
-                                  , nodeAttributes = [Label (StrLabel (fromString (showADL r)))]
-                                  }
-                        | r<-toRels
-                  --TODOHAN     , (not.null) [e |e<-edgesOut, (nodeID . toNode) e==nameONode toRels r ]
-                        ]
-
-        --DESCR -> All conjuncts
-        conjunctNodes = [ DotNode { nodeID         = nameCNode conjuncts (rul,c)
-                                  , nodeAttributes = [Style [SItem Filled []], FillColor [WC(X11Color (colorRule rul))Nothing], Label (StrLabel (fromString (name rul)))]
-                                  }
-                        | (rul,c)<-conjuncts]
-
-        --DESCR -> Each edge represents an insert between a relation on the left and a term on the right to which the relation contributes to an insert.
-        edgesIn       = [ DotEdge { fromNode       = nameINode fromRels r
-                                  , toNode         = nameCNode conjuncts (rul,c)
-                                  , edgeAttributes = [Label (StrLabel (fromString 
-                                                                      (if or (positiveIn c r) then "-" else
-                                                                       if or [not b |b<-positiveIn c r] then "+" else
-                                                                       "+-")))
-                                                     ,Dir Forward]
-                                  }
-                        | (rul,c)<-conjuncts, r<-relsUsedIn c, r `elem` fromRels]
-        edgesOut      = [ DotEdge { fromNode       = nameCNode conjuncts (rul,c)
-                                  , toNode         = nameONode toRels r
-                                  , edgeAttributes = [Label (StrLabel (fromString
-                                                                      (if or (positiveIn c r) then "+" else
-                                                                       if or [not b |b<-positiveIn c r] then "-" else
-                                                                       "+-")))
-                                                     ,Dir Forward]
-                                  }
-                        | (rul,c)<-conjuncts, r<-relsUsedIn c]
-        nameINode :: [Declaration] -> Declaration -> String
-        nameINode = nmLkp fSpec "in_"
-        nameCNode = nmLkp fSpec "cj_"
-        nameONode :: [Declaration] -> Declaration -> String
-        nameONode = nmLkp fSpec "out_"
-
-
-   nmLkp :: (LanguageDependent a, Eq a, ShowADL a) => Fspc -> String -> [a] -> a -> String
-   nmLkp _ prefix xs x
-    = head ([prefix++show (i::Int) | (i,e)<-zip [1..] xs, e==x]++
-            fatal 216 ("illegal lookup in nmLkp "++show prefix++": " ++showADL x++
-                       "\nin: ["++intercalate "\n    , " (map showADL xs)++"\n    ]")
-           )
-   positiveIn :: Expression -> Declaration -> [Bool]
-   positiveIn expr decl = f expr   -- all are True, so an insert in rel means an insert in expr
-    where
-     f (EEqu _)     = fatal 237 "Illegal call of positiveIn."
-     f (EImp (l,r)) = f (notCpl l .\/. r)
-     f (EIsc (l,r)) = f l ++ f r
-     f (EUni (l,r)) = f l ++ f r
-     f (EDif (l,r)) = f l ++ f (notCpl r)
-     f (ELrs (l,r)) = f l ++ f (notCpl r)
-     f (ERrs (l,r)) = f (notCpl l) ++ f r
-     f (EDia (l,r)) = f (flp l .\. r ./\. l ./. flp r)
-     f (ECps (l,r)) = f l ++ f r
-     f (ERad (l,r)) = f l ++ f r
-     f (EPrd (l,r)) = f l ++ f r
-     f (EKl0 e)     = f e
-     f (EKl1 e)     = f e
-     f (EFlp e)     = f e
-     f (ECpl e)     = [ not b | b<- f e]
-     f (EBrk e)     = f e
-     f (EDcD d)     = [ True | d==decl ]
-     f (EDcI c)     = [ True | detyp decl==c ]
-     f EEps{}       = []
-     f EDcV{}       = []
-     f EMp1{}       = []

− src/lib/DatabaseDesign/Ampersand/Fspec/ToFspec/ADL2Fspec.hs 
@@ -1,618 +0,0 @@-{-# OPTIONS_GHC -Wall #-}
-module DatabaseDesign.Ampersand.Fspec.ToFspec.ADL2Fspec
-    (makeFspec,allClauses, quads, preEmpt, editable)
-  where
-   import DatabaseDesign.Ampersand.Core.AbstractSyntaxTree
-   import DatabaseDesign.Ampersand.Core.Poset
-   import Prelude hiding (Ord(..),head)
-   import DatabaseDesign.Ampersand.ADL1.Rule
-   import DatabaseDesign.Ampersand.Basics
-   import DatabaseDesign.Ampersand.Classes
-   import DatabaseDesign.Ampersand.ADL1
-   import DatabaseDesign.Ampersand.Fspec.Fspec
-   import DatabaseDesign.Ampersand.Misc
-   import DatabaseDesign.Ampersand.Fspec.ToFspec.NormalForms  --  (delta,conjNF,disjNF,normPA)
-   import DatabaseDesign.Ampersand.Fspec.ToFspec.ADL2Plug
-   import DatabaseDesign.Ampersand.Fspec.ToFspec.Calc
---   import DatabaseDesign.Ampersand.Fspec.ShowHS -- only for diagnostic purposes during debugging
-   import DatabaseDesign.Ampersand.Fspec.ShowADL
-   import Text.Pandoc
-   import Data.Maybe
-   import Data.List (nub,nubBy,intersect,partition,group,delete)
-   import DatabaseDesign.Ampersand.ADL1.Expression
-   import Data.Char        (toLower)
---   import Debug.Trace -- only for diagnostic purposes during debugging
-   head :: [a] -> a
-   head [] = fatal 30 "head must not be used on an empty list!"
-   head (a:_) = a
-
-   fatal :: Int -> String -> a
-   fatal = fatalMsg "Fspec.ToFspec.ADL2Fspec"
-
-   makeFspec :: Options -> A_Context -> Fspc
-   makeFspec flags context = fSpec
-    where
-        fSpec =
-            Fspc { fsName       = name context
-                 , fspos        = ctxpos context
-                 , themes       = themesInScope
-                 , pattsInScope = pattsInThemesInScope
-                 , procsInScope = procsInThemesInScope
-                 , rulesInScope = rulesInThemesInScope
-                 , declsInScope = declsInThemesInScope
-                 , concsInScope = concsInThemesInScope
-                 , cDefsInScope = cDefsInThemesInScope
-                 , gensInScope  = gensInThemesInScope
-                 , fsLang       = fromMaybe (ctxlang context) (language flags)  -- The language for printing this specification is taken from the command line options (language flags). If none is specified, the specification is printed in the language in which the context was defined (ctxlang context).
-                 , vprocesses   = allProcs
-                 , vplugInfos   = definedplugs
-                 , plugInfos    = allplugs
-                 , interfaceS   = ctxifcs context -- interfaces specified in the Ampersand script
-                 , interfaceG   = [ifc | ifc<-interfaceGen, let ctxrel = objctx (ifcObj ifc)
-                                       , isIdent ctxrel && source ctxrel==ONE
-                                         || ctxrel `notElem` map (objctx.ifcObj) (interfaceS fSpec)
-                                       , allInterfaces flags]  -- generated interfaces
-                 , fSwitchboard = switchboard flags fSpec
-                 , fActivities  = [ makeActivity fSpec rul | rul <-processRules context]
-                 , fRoleRels    = mayEdit   context  -- fRoleRels says which roles may change the population of which relation.
-                 , fRoleRuls    = maintains context  -- fRoleRuls says which roles maintain which rules.
-                 , fRoles       = roles context
-                 , vrules       = vRules
-                 , grules       = gRules
-                 , invars       = invariants context
-                 , allRules     = allrules
-                 , vconjs       = let equalOnConjunct a b = rc_conjunct a == rc_conjunct b
-                                  in nubBy equalOnConjunct (concatMap (cl_conjNF.qClauses)allQuads)
-                 , vquads       = allQuads
-                 , vEcas        = let (ecas,_)=(unzip.assembleECAs) fSpec in {-preEmpt-} ecas -- TODO: preEmpt gives problems. Readdress the preEmption problem and redo, but properly.
-                 , vrels        = calculatedDecls
-                 , allUsedDecls = relsUsedIn context
-                 , allDecls     = relsDefdIn context
-                 , allConcepts  = concs context `uni` [ONE]
-                 , kernels      = constructKernels
-                 , fsisa        = let f gen = case gen of 
-                                               Isa{} -> [(genspc gen, gengen gen)]
-                                               IsE{} -> [(genspc gen, g ) | g<-genrhs gen]
-                                  in concatMap f (gens context)
-                 , vpatterns    = patterns context
-                 , vgens        = gens context
-                 , vIndices     = identities context
-                 , vviews       = viewDefs context
-                 , conceptDefs  = ctxcds context
-                 , fSexpls      = ctxps context
-                 , metas        = ctxmetas context
-                 , initialPops  = initialpops
-                 , allViolations = [(r,vs) |r<-allrules, not (isSignal r), let vs = ruleviolations (gens context) initialpops r,  not (null vs)]
-                 }
-        themesInScope = if null (ctxthms context)   -- The names of patterns/processes to be printed in the functional specification. (for making partial documentation)
-                        then map name (patterns context) ++ map name allProcs
-                        else ctxthms context
-        pattsInThemesInScope = filter (\p -> name p `elem` themesInScope) (patterns context) 
-        procsInThemesInScope = filter (\p -> name p `elem` themesInScope) (ctxprocs context)
-        cDefsInThemesInScope = filter (\cd -> cdfrom cd `elem` themesInScope) (ctxcds context)
-        rulesInThemesInScope = ctxrs context `uni` concatMap prcRules procsInThemesInScope `uni` concatMap ptrls pattsInThemesInScope
-        declsInThemesInScope = ctxds context `uni` concatMap prcDcls  procsInThemesInScope `uni` concatMap ptdcs pattsInThemesInScope
-        concsInThemesInScope = concs (ctxrs context)  `uni`  concs procsInThemesInScope  `uni`  concs pattsInThemesInScope
-        gensInThemesInScope  = ctxgs context ++ concatMap prcGens procsInThemesInScope ++ concatMap ptgns pattsInThemesInScope
-
-        allQuads = quads flags (\_->True) allrules
-        initialpops = [ PRelPopu{ popdcl = popdcl (head eqclass)
-                                , popps  = (nub.concat) [ popps pop | pop<-eqclass ] 
-                                } 
-                      | eqclass<-eqCl popdcl [ pop | pop@PRelPopu{}<-populations ] ] ++
-                      [ PCptPopu{ popcpt = popcpt (head eqclass)
-                                , popas  = (nub.concat) [ popas pop | pop<-eqclass ] 
-                                } 
-                      | eqclass<-eqCl popcpt [ pop | pop@PCptPopu{}<-populations ] ]
-          where populations = ctxpopus context++concatMap prcUps (processes context)++concatMap ptups (patterns context)
-
---      isInvariantQuad q = null [r | (r,rul)<-maintains context, rul==cl_rule (qClauses q)]
-        allrules = vRules ++ gRules
-        vRules = udefrules context   -- all user defined rules
-        gRules = multrules context++identityRules context
-        allProcs = [ FProc {fpProc = p
-                           ,fpActivities =selectActs p
-                           } | p<-ctxprocs context ]
-                   where selectActs p   = [act | act<-fActivities fSpec
-                                               , (not.null) (selRoles p act)]
-                         selRoles p act = [r | (r,rul)<-maintains context, rul==actRule act, r `elem` roles p]
-        -- | allDecs contains all user defined plus all generated relations plus all defined and computed totals.
-        calcProps :: Declaration -> Declaration
-        calcProps d = d{decprps_calc = Just calculated}
-            where calculated = decprps d `uni` [Tot | d `elem` totals]
-                                         `uni` [Sur | d `elem` surjectives]
-        calculatedDecls = map calcProps (relsDefdIn context)
-        constructKernels = foldl f (group (delete ONE (concs context))) (gens context)
-            where f disjuncLists g = concat haves : nohaves
-                    where
-                      (haves,nohaves) = partition (not.null.intersect (concs g)) disjuncLists
-     -- 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
-         = nub [rel | q<-quads flags visible (invariants context), isIdent (qDcl q)
-                    , x<-cl_conjNF (qClauses q), Dnf antcs conss<-rc_dnfClauses x
-                    , let antc = conjNF (foldr (./\.) (EDcV (sign (head (antcs++conss)))) antcs)
-                    , isRfx antc -- We now know that I is a subset of the antecedent of this dnf clause.
-                    , cons<-map exprCps2list conss
-               -- let I |- r;s;t be an invariant rule, then r and s and t~ and s~ are all total.
-                    , rel<-init cons++[flp r | r<-tail cons]
-                    ]
-          where
-            visible _ = True -- for computing totality, we take all quads into account.
-
-        --------------
-        --making plugs
-        --------------
-        vsqlplugs = [ (makeUserDefinedSqlPlug context p) | p<-ctxsql context] --REMARK -> no optimization like try2specific, because these plugs are user defined
-        definedplugs = map InternalPlug vsqlplugs
-                    ++ map ExternalPlug (ctxphp context)
-        allplugs = definedplugs ++      -- all plugs defined by the user
-                   genPlugs             -- all generated plugs
-        genPlugs = [InternalPlug (rename p (qlfname (name p)))
-                   | p <- uniqueNames (map name definedplugs) -- the names of definedplugs will not be changed, assuming they are all unique
-                                      (makeGeneratedSqlPlugs flags context totsurs entityRels)
-                   ]
-        -- relations to be saved in generated plugs: if decplug=True, the declaration has the BYPLUG and therefore may not be saved in a database
-        -- WHAT -> is a BYPLUG?
-        entityRels = [ d | d<-calculatedDecls, not (decplug d)] -- The persistent relations.
-
-        qlfname x = if null (namespace flags) then x else "ns"++namespace flags++x
-
-        --TODO151210 -> Plug A is overbodig, want A zit al in plug r
---CONTEXT Temp
---PATTERN Temp
---r::A*B[TOT].
---t::E*ECps[UNI].
---ENDPATTERN
---ENDCONTEXT
-{-
-    **************************************
-    * Plug E                               *
-    * I  [INJ,SUR,UNI,TOT,SYM,ASY,TRN,RFX] *
-    * t  [UNI]                             *
-    **************************************
-    * Plug ECps                            *
-    * I  [INJ,SUR,UNI,TOT,SYM,ASY,TRN,RFX] *
-    **************************************
-    * Plug B                               *
-    * I  [INJ,SUR,UNI,TOT,SYM,ASY,TRN,RFX] *
-    **************************************
-    * Plug A                               *
-    * I  [INJ,SUR,UNI,TOT,SYM,ASY,TRN,RFX] *
-    **************************************
-    * Plug r                               *
-    * I  [INJ,SUR,UNI,TOT,SYM,ASY,TRN,RFX] *
-    * r  [TOT]                             *
-    **************************************
--}
-        -------------------
-        --END: making plugs
-        -------------------
-        -------------------
-        --making interfaces
-        -------------------
-        -- interfaces (type ObjectDef) can be generated from a basic ontology. That is: they can be derived from a set
-        -- of relations together with multiplicity constraints. That is what interfaceG does.
-        -- This is meant to help a developer to build his own list of interfaces, by providing a set of interfaces that works.
-        -- The developer may relabel attributes by names of his own choice.
-        -- This is easier than to invent a set of interfaces from scratch.
-
-        -- Rule: a interface must be large enough to allow the required transactions to take place within that interface.
-        -- Attributes of an ObjectDef have unique names within that ObjectDef.
-
---- generation of interfaces:
---  Ampersand generates interfaces for the purpose of quick prototyping.
---  A script without any mention of interfaces is supplemented
---  by a number of interface definitions that gives a user full access to all data.
---  Step 1: select and arrange all relations to obtain a set cRels of total relations
---          to ensure insertability of entities (signal declarations are excluded)
-        cRels = [     EDcD d  | d@Sgn{}<-relsDefdIn context, not(deciss d), isTot d, not$decplug d]++
-                [flp (EDcD d) | d@Sgn{}<-relsDefdIn context, not(deciss d), not (isTot d) && isSur d, not$decplug d]
---  Step 2: select and arrange all relations to obtain a set dRels of injective relations
---          to ensure deletability of entities (signal declarations are excluded)
-        dRels = [     EDcD d  | d@Sgn{}<-relsDefdIn context, not(deciss d), isInj d, not$decplug d]++
-                [flp (EDcD d) | d@Sgn{}<-relsDefdIn context, not(deciss d), not (isInj d) && isUni d, not$decplug d]
---  Step 3: compute longest sequences of total expressions and longest sequences of injective expressions.
-        maxTotPaths = clos cRels   -- maxTotPaths = cRels+, i.e. the transitive closure of cRels
-        maxInjPaths = clos dRels   -- maxInjPaths = dRels+, i.e. the transitive closure of dRels
-        --    Warshall's transitive closure algorithm, adapted for this purpose:
-        clos :: [Expression] -> [[Expression]]
-        clos xs
-         = foldl f [ [ x ] | x<-xs] (nub (map source xs) `isc` nub (map target xs))
-           where
-             f :: [[Expression]] -> A_Concept -> [[Expression]]
-             f q x = q ++ [l ++ r | l <- q, x == target (last l),
-                                    r <- q, x == source (head r), null (l `isc` r)]
-
---  Step 4: i) generate interfaces starting with INTERFACE concept: I[Concept]
---          ii) generate interfaces starting with INTERFACE concepts: V[ONE*Concept] 
---          note: based on a theme one can pick a certain set of generated interfaces (there is not one correct set)
---                default theme => generate interfaces from the clos total expressions and clos injective expressions (see step1-3).
---                student theme => generate interface for each concept with relations where concept is source or target (note: step1-3 are skipped)
-        interfaceGen = step4a ++ step4b
-        step4a
-         | theme flags == StudentTheme 
-         = [Ifc { ifcParams = directdeclsExprs
-                , ifcArgs   = []
-                , ifcObj    = Obj { objnm   = name c ++ " (instantie)"
-                                  , objpos  = Origin "generated object for interface for each concept in TblSQL or ScalarSQL"
-                                  , objctx  = EDcI c
-                                  , objmsub = Just . Box c $
-                                              Obj { objnm   = "I["++name c++"]"
-                                                   , objpos  = Origin "generated object: step 4a - default theme"
-                                                   , objctx  = EDcI c
-                                                   , objmsub = Nothing
-                                                   , objstrs = [] }
-                                              :[Obj { objnm   = case dcl of
-                                                                  EDcD d -> name d ++ "::"++name (source d)++"*"++name (target d)
-                                                                  _      -> fatal 246 "Invalid expression for a parameter."
-                                                    , objpos  = Origin "generated object: step 4a - default theme"
-                                                    , objctx  = if source dcl==c then dcl else flp dcl
-                                                    , objmsub = Nothing
-                                                    , objstrs = [] }
-                                               | dcl <- directdeclsExprs]
-                                  , objstrs = [] }
-                , ifcPos    = Origin "generated interface for each concept in TblSQL or ScalarSQL"
-                , ifcPrp    = "Interface " ++name c++" has been generated by Ampersand."
-                , ifcRoles = []
-                }
-           | c<-concs fSpec, let directdeclsExprs = [EDcD d | d<-relsDefdIn fSpec, c `elem` concs d]]
-         --end student theme
-         --otherwise: default theme
-         | otherwise --note: the uni of maxInj and maxTot may take significant time (e.g. -p while generating index.htm)
-                     --note: associations without any multiplicity are not in any Interface
-                     --note: scalars with only associations without any multiplicity are not in any Interface
-         = let recur es
-                = [ Obj { objnm   = showADL t
-                        , objpos  = Origin "generated recur object: step 4a - default theme"
-                        , objctx  = t
-                        , objmsub = Just . Box (target t) $ recur [ pth | (_:pth)<-cl, not (null pth) ]
-                        , objstrs = [] }
-                  | cl<-eqCl head es, (t:_)<-take 1 cl] -- 
-               -- es is a list of expression lists, each with at least one expression in it. They all have the same source concept (i.e. source.head)
-               -- Each expression list represents a path from the origin of a box to the attribute.
-               -- 16 Aug 2011: (recur trace es) is applied once where es originates from (maxTotPaths `uni` maxInjPaths) both based on clos
-               -- Interfaces for I[Concept] are generated only for concepts that have been analysed to be an entity.
-               -- These concepts are collected in gPlugConcepts
-               gPlugConcepts = [ c | InternalPlug plug@TblSQL{}<-genPlugs , (c,_)<-take 1 (cLkpTbl plug) ]
-               -- Each interface gets all attributes that are required to create and delete the object.
-               -- All total attributes must be included, because the interface must allow an object to be deleted.
-           in
-           [Ifc { ifcParams = [ p | p <- concatMap primitives (expressionsIn objattributes), not (isIdent p)]
-                , ifcArgs   = []
-                , ifcObj    = Obj { objnm   = name c
-                                  , objpos  = Origin "generated object: step 4a - default theme"
-                                  , objctx  = EDcI c
-                                  , objmsub = Just . Box c $ objattributes
-                                  , objstrs = [] }
-                , ifcPos    = Origin "generated interface: step 4a - default theme"
-                , ifcPrp    = "Interface " ++name c++" has been generated by Ampersand."
-                , ifcRoles  = []
-                }
-           | cl <- eqCl (source.head) [ pth | pth<-maxTotPaths `uni` maxInjPaths, (source.head) pth `elem` gPlugConcepts ]
-           , let objattributes = recur cl
-           , not (null objattributes) --de meeste plugs hebben in ieder geval I als attribuut
-           , --exclude concept A without cRels or dRels (i.e. A in Scalar without total associations to other plugs) 
-             not (length objattributes==1 && isIdent(objctx(head objattributes)))  
-           , let e0=head cl, if null e0 then fatal 284 "null e0" else True
-           , let c=source (head e0)
-           ]
-        --end otherwise: default theme
-        --end stap4a
-        step4b --generate lists of concept instances for those concepts that have a generated INTERFACE in step4a 
-         = [Ifc { ifcParams = ifcParams ifcc
-                , ifcArgs   = ifcArgs   ifcc
-                , ifcObj    = Obj { objnm   = nm
-                                  , objpos  = Origin "generated object: step 4b"
-                                  , objctx  = EDcI ONE
-                                  , objmsub = Just . Box ONE $ [att]
-                                  , objstrs = [] }
-                , ifcPos    = ifcPos  ifcc
-                , ifcPrp    = ifcPrp  ifcc
-                , ifcRoles  = []
-                }
-           | ifcc<-step4a
-           , let c   = source(objctx (ifcObj ifcc))
-                 nm'::Int->String
-                 nm' 0  = plural (fsLang fSpec) (name c)
-                 nm' i  = plural (fsLang fSpec) (name c) ++ show i
-                 nms = [nm' i |i<-[0..], nm' i `notElem` map name (ctxifcs context)]
-                 nm
-                   | theme flags == StudentTheme = name c
-                   | null nms = fatal 355 "impossible"
-                   | otherwise = head nms
-                 att = Obj (name c) (Origin "generated attribute object: step 4b") (EDcV (Sign ONE c)) Nothing []
-           ]
-        ----------------------
-        --END: making interfaces
-        ----------------------
-
-
-   editable :: Expression -> Bool   --TODO deze functie staat ook in Calc.hs...
-   editable (EDcD Sgn{}) = True
-   editable _            = False
-
-{- makeActivity turns a process rule into an activity definition.
-Each activity can be mapped to a single interface.
-A call to such an interface takes the population of the current context to another population,
-while maintaining all invariants.
--}
-   makeActivity :: Fspc -> Rule -> Activity
-   makeActivity fSpec rul
-    = let s = Act{ actRule   = rul
-                 , actTrig   = decls
-                 , actAffect = nub [ d' | (d,_,d')<-clos affectPairs, d `elem` decls]
-                 , actQuads  = invQs
-                 , actEcas   = [eca | eca<-vEcas fSpec, eDcl (ecaTriggr eca) `elem` decls]
-                 , actPurp   = [Expl { explPos = OriginUnknown
-                                     , explObj = ExplRule (name rul)
-                                     , explMarkup = A_Markup { amLang   = Dutch
-                                                             , amFormat = ReST
-                                                             , amPandoc = [Plain [Str "Waartoe activiteit ", Quoted SingleQuote [Str (name rul)], Str" bestaat is niet gedocumenteerd." ]]
-                                                             }
-                                     , explUserdefd = False
-                                     , explRefIds = ["Regel "++name rul]
-                                     }
-                               ,Expl { explPos = OriginUnknown
-                                     , explObj = ExplRule (name rul)
-                                     , explMarkup = A_Markup { amLang   = English
-                                                             , amFormat = ReST
-                                                             , amPandoc = [Plain [Str "For what purpose activity ", Quoted SingleQuote [Str (name rul)], Str" exists remains undocumented." ]]
-                                                             }
-                                     , explUserdefd = False
-                                     , explRefIds = ["Regel "++name rul]
-                                     }
-                               ]
-                 } in s
-    where
--- relations that may be affected by an edit action within the transaction
-        decls        = relsUsedIn rul
--- the quads that induce automated action on an editable relation.
--- (A quad contains the conjunct(s) to be maintained.)
--- Those are the quads that originate from invariants.
-        invQs       = [q | q@(Quad _ ccrs)<-vquads fSpec, (not.isSignal.cl_rule.qClauses) q
-                         , (not.null) ((relsUsedIn.cl_rule) ccrs `isc` decls)] -- SJ 20111201 TODO: make this selection more precise (by adding inputs and outputs to a quad).
--- a relation affects another if there is a quad (i.e. an automated action) that links them
-        affectPairs = [(qDcl q,[q], d) | q<-invQs, d<-(relsUsedIn.cl_rule.qClauses) q]
--- the relations affected by automated action
---      triples     = [ (r,qs,r') | (r,qs,r')<-clos affectPairs, r `elem` rels]
-----------------------------------------------------
---  Warshall's transitive closure algorithm in Haskell, adapted to carry along the intermediate steps:
-----------------------------------------------------
-        clos :: (Eq a,Eq b) => [(a,[b],a)] -> [(a,[b],a)]     -- e.g. a list of pairs, with intermediates in between
-        clos xs
-          = foldl f xs (nub (map fst3 xs) `isc` nub (map thd3 xs))
-            where
-             f q x = q `un`
-                        [(a, qs `uni` qs', b') | (a, qs, b) <- q, b == x,
-                         (a', qs', b') <- q, a' == x]
-             ts `un` [] = ts
-             ts `un` ((a',qs',b'):ts')
-              = ([(a,qs `uni` qs',b) | (a,qs,b)<-ts, a==a' && b==b']++
-                 [(a,qs,b)           | (a,qs,b)<-ts, a/=a' || b/=b']++
-                 [(a',qs',b')        | (a',b') `notElem` [(a,b) |(a,_,b)<-ts]]) `un` ts'
-        
-
-   -- Quads embody the "switchboard" of rules. A quad represents a "proto-rule" with the following meaning:
-   -- whenever relation r is affected (i.e. tuples in r are inserted or deleted),
-   -- the rule may have to be restored using functionality from one of the clauses.
-   -- The rule is carried along for traceability.
-   quads :: Options -> (Declaration->Bool) -> [Rule] -> [Quad]
-   quads flags visible rs
-    = [ Quad { qDcl     = d
-             , qClauses = allClauses flags rule
-             }
-      | rule<-rs, d<-relsUsedIn rule, visible d
-      ]
-
--- The function allClauses yields an expression which has constructor EUni in every case.
-   allClauses :: Options -> Rule -> Clauses
-   allClauses flags rule = Clauses [RC { rc_int = i
-                                       , rc_rulename = name rule
-                                       , rc_conjunct = dnf2expr dnfClause
-                                       , rc_dnfClauses = allShifts flags dnfClause
-                                       } | (dnfClause,i)<-zip (conjuncts rule) [0..] ] rule
-
-   allShifts :: Options -> DnfClause -> [DnfClause]
-   allShifts _ conjunct = (map head.eqCl (disjNF.dnf2expr)) [ e'| e'<-shiftL conjunct++shiftR conjunct]  -- we want to nub all dnf-clauses, but nub itself does not do the trick...
--- allShifts conjunct = error $ show conjunct++concat [ "\n"++show e'| e'<-shiftL conjunct++shiftR conjunct] -- for debugging
-    where
-    {-
-     diagnostic
-      = intercalate "\n  "
-          [ "shiftL: [ "++intercalate "\n          , " [showHS flags "\n            " e | e<-shiftL conjunct    ]++"\n          ]"
-          , "shiftR: [ "++intercalate "\n          , " [showHS flags "\n            " e | e<-shiftR conjunct    ]++"\n          ]"
-          ] -}
-     shiftL :: DnfClause -> [DnfClause]
-     shiftL dc@(Dnf antcs conss)
-      | null antcs || null conss = [dc] --  shiftL doesn't work here. This is just to make sure that both antss and conss are really not empty
-      | otherwise                = [ Dnf ass (case css of
-                                               [] -> let antcExpr = foldr1 (./\.) ass in
-                                                     if isEndo antcExpr then [EDcI (source antcExpr)] else fatal 425 "antcExpr should be endorelation"
-                                               _  -> css
-                                             )
-                                   | (ass,css)<-nub (move antcs conss)
-                                   ]
-      where
-      -- example:  r;s /\ p;r |- x;y   and suppose x and y are both univalent.
-      --  antcs =  [ r;s, p;r ]
-      --  conss =  [ x;y ]
-       move :: [Expression] -> [Expression] -> [([Expression],[Expression])]
-       move ass [] = [(ass,[])]
-       move ass css
-        = (ass,css):
-          if and [ (not.isEDcI) cs | cs<-css]     -- all cs are nonempty because: (not.and.map isEDcI) cs ==> not (null cs)
-          then [ts | let headEs = map headECps css
-                   , length (eqClass (==) headEs) == 1                    -- example: True, because map head css == [ "x" ]
-                   , let h=head headEs                                    -- example: h= "x"
-                   , isUni h                                              -- example: assume True
-                   , ts<-move [if source h==source as then flp h.:.as else fatal 455 "type mismatch"
-                              |as<-ass] (map tailECps css)]++ -- example: ts<-move [ [flp "x","r","s"], [flp "x","p","r"] ]  [ ["y","z"] ]
-               [ts | let lastEs = map lastECps css
-                   , length (eqClass (==) lastEs) == 1
-                   , let l=head lastEs
-                   , isInj l
-                   , ts<-move [if target as==target l then as.:.flp l else fatal 461 "type mismatch"
-                              |as<-ass] (map initECps css)]   -- example: ts<-move [ ["r","s",flp "z"], ["p","r",flp "z"] ]  [ ["x","y"] ]
-          else []
-      -- Here is (informally) what the example does:
-      -- move [ r;s , p;r ] [ x;y ]
-      -- ( [ r;s , p;r ] , [ x;y ] ): [ ts | ts<-move [flp x.:.as | as<-[ r;s , p;r ] [ y ] ] ]
-      -- ( [ r;s , p;r ] , [ x;y ] ): ( [ x~;r;s , x~;p;r ] , [ y ] ): [ ts | ts<-move [flp y.:.as | as<-[ y~;x~;r;s , y~;x~;p;r ] [] ] ]
-      -- ( [ r;s , p;r ] , [ x;y ] ): ( [ x~;r;s , x~;p;r ] , [ y ] ): [ [ y~;x~;r;s , y~;x~;p;r ] , [] ] ]
-      -- [ ( [ r;s , p;r ] , [ x;y ] ), ( [ x~;r;s , x~;p;r ] , [ y ] ), ( [ y~;x~;r;s , y~;x~;p;r ] , [] ) ]
-
-     shiftR :: DnfClause -> [DnfClause]
-     shiftR dc@(Dnf antcs conss)
-      | null antcs || null conss = [dc] --  shiftR doesn't work here. This is just to make sure that both antss and conss are really not empty
-      | otherwise                = [ Dnf (case ass of
-                                           [] -> let consExpr = foldr1 (.\/.) css in
-                                                 if source consExpr==target consExpr then [EDcI (source consExpr)] else fatal 463 "consExpr should be endorelation"
-                                           _  -> ass
-                                         ) css
-                                   | (ass,css)<-nub (move antcs conss)
-                                   ]
-      where
-      -- example  "r;s /\ r;r |- x;y"   and suppose r is both surjective.
-      --  ass =  [ r;s , r;r ]
-      --  css =  [ x;y ]
-       move :: [Expression] -> [Expression] -> [([Expression],[Expression])]
-       move ass css = 
-        case ass of
-         [] -> [] -- was [([EDcI (target (last css))],css)]
-         _  -> 
-          (ass,css):
-          if and [ (not.isEDcI) as | as<-ass]
-          then [ts | let headEs = map headECps ass
-                   , length (eqClass (==) headEs) == 1                      -- example: True, because map headECps ass == [ "r", "r" ]
-                   , let h=head headEs                                      -- example: h= "r"
-                   , isSur h                                                -- example: assume True
-                   , ts<-move (map tailECps ass) [if source h==source cs then flp h.:.cs else fatal 496 "type mismatch"
-                                                 |cs<-css]]++   -- example: ts<-move  [["s"], ["r"]] [ [flp "r","x","y","z"] ]
-               [ts | let lastEs = map lastECps ass
-                   , length (eqClass (==) lastEs) == 1                      -- example: False, because map lastECps ass == [ ["s"], ["r"] ]
-                   , let l=head lastEs
-                   , isTot l
-                   , ts<-move (map initECps ass) [if target cs==target l then cs.:.flp l else fatal 502 "type mismatch"
-                                                 |cs<-css]]     -- is dit goed? cs.:.flp l wordt links zwaar, terwijl de normalisator rechts zwaar maakt.
-          else []
-      -- Here is (informally) what the example does:
-      -- move [ r;s , r;r ] [ x;y ]
-      -- ( [ r;s , r;r ] , [ x;y ] ): move [ s , r ] [ r~;x;y ]
-      -- ( [ r;s , r;r ] , [ x;y ] ): ( [ s , r ]  , [ r~;x;y ] ) : []
-      -- [ [ r;s , r;r ] , [ x;y ] ), ( [ s , r ]  , [ r~;x;y ] ) ]
-      --  diagnostic
-      --    = "\n  antcs: [ "++intercalate "\n         , " [showADL a | a<-antcs ]++"\n       ]"++
-      --      "\n  conss: [ "++intercalate "\n         , " [showADL c | c<-conss ]++"\n       ]"++
-      --      "\n  move:  [ "++intercalate "\n         , " ["("++sh " /\\ " as++"\n           ,"++sh " \\/ " cs++")" | (as,cs)<-move antcs conss ]++"\n       ]"
-      --  sh :: String -> [Expression] -> String
-      --  sh str es = intercalate str [ showADL e | e<-es] 
-
-     headECps :: Expression -> Expression
-     headECps expr = f expr
-      where f (ECps (l@ECps{},_)) = f l
-            f (ECps (l,_)) = l
-            f _ = expr
-
-     tailECps :: Expression -> Expression
-     tailECps expr = f expr
-      where f (ECps (ECps (l,r),q)) = f (ECps (l, ECps (r,q)))
-            f (ECps (_,r)) = r
-            f _ = EDcI (target expr)
-            
-     initECps :: Expression -> Expression
-     initECps expr = f expr
-      where f (ECps (l, ECps (r,q))) = initECps (ECps (ECps (l,r),q))
-            f (ECps (l,_)) = l
-            f _ = EDcI (source expr)
-
-     lastECps :: Expression -> Expression
-     lastECps expr = f expr
-      where f (ECps (_,r@ECps{})) = f r
-            f (ECps (_,r)) = r
-            f _ = expr
-
-     isEDcI :: Expression -> Bool
-     isEDcI EDcI{} = True
-     isEDcI _ = False
-
-
-
--- If one rule r blocks upon an event, e.g. e@(ON Ins rel), while another ECA rule r'
--- maintains something else with that same event e, we can save r' the trouble.
--- After all, event e will block anyway.
--- preEmpt tries to simplify ECArules by predicting whether a rule will block.
-   preEmpt :: [ECArule] -> [ECArule]
-   preEmpt ers = pr [length ers] (10::Int)
-    where
-     pr :: [Int] -> Int -> [ECArule]
-     pr ls n
-       | n == 0              = fatal 633 $ "too many cascading levels in preEmpt "++show ls
-       | (not.null) cascaded = pr (length cascaded:ls)
-                               -- ([er{ecaAction=normPA (ecaAction er)} | er<-cascaded] ++uncasced)
-                                  (n-1)
-       | otherwise           = [er{ecaAction=normPA (ecaAction er)} | er<-uncasced]
-      where
--- preEmpt divides all ECA rules in uncascaded rules and cascaded rules.
--- cascaded rules are those rules that have a Do component with event e, where e is known to block (for some other reason)
-       new  = [er{ecaAction=normPA (ecaAction er)} | er<-ers]
-       cascaded = [er{ecaAction=action'} | er<-new, let (c,action') = cascade (eDcl (ecaTriggr er)) (ecaAction er), c]
-       uncasced = [er |                    er<-new, let (c,_)       = cascade (eDcl (ecaTriggr er)) (ecaAction er), not c]
--- cascade inserts a block on the place where a Do component exists that matches the blocking event.
---     cascade :: Relation -> PAclause -> (Bool, PAclause)
-     cascade dcl (Do srt to _ _) | (not.null) blkErs = (True, ecaAction (head blkErs))
-      where blkErs = [er | er<-ers
-                         , Blk _<-[ecaAction er]
-                         , let t = ecaTriggr er
-                         , eSrt t == srt
-                         , eDcl t == to
-                         , not (dcl ==to)
-                         ]
-     cascade  _  c@Do{}           = (False, c)
-     cascade rel (New c clause m) = ((fst.cascade rel.clause) "dummystr", New c (snd.cascade rel.clause) m)
-     cascade rel (Rmv c clause m) = ((fst.cascade rel.clause) "dummystr", Rmv c (snd.cascade rel.clause) m)
---   cascade rel (Sel c e cl m)   = ((fst.cascade rel.cl) "dummystr",     Sel c e (snd.cascade rel.cl)   m)
-     cascade rel (CHC ds m)       = (any (fst.cascade rel) ds, CHC (map (snd.cascade rel) ds) m)
-     cascade rel (ALL ds m)       = (any (fst.cascade rel) ds, ALL (map (snd.cascade rel) ds) m)
-     cascade  _  (Nop m)          = (False, Nop m)
-     cascade  _  (Blk m)          = (False, Blk m)
-     cascade  _  (Let _ _ _)  = fatal 611 "Deze constructor is niet gedefinieerd" -- HJO, 20131205:Toegevoegd om warning te verwijderen
-     cascade  _  (Ref _)      = fatal 612 "Deze constructor is niet gedefinieerd" -- HJO, 20131205:Toegevoegd om warning te verwijderen
-     cascade  _  (GCH{})      = fatal 655 "Deze constructor is niet gedefinieerd" -- SJO, 20140428:Toegevoegd om warning te verwijderen
-        
-
-   switchboard :: Options -> Fspc -> Fswitchboard
-   switchboard flags fSpec
-    = Fswtch
-       { fsbEvIn  = eventsIn
-       , fsbEvOut = eventsOut
-       , fsbConjs = conjs
-       , fsbECAs  = ecas
-       }
-      where
-        qs :: [Quad]
-        qs        = quads flags visible (invariants fSpec)
-        (ecas, _) = unzip (assembleECAs fSpec)
-        conjs     = nub [ (cl_rule ccrs,rc_conjunct x) | Quad _ ccrs<-qs, x<-cl_conjNF ccrs]
-        eventsIn  = nub [ecaTriggr eca | eca<-ecas ]
-        eventsOut = nub [evt | eca<-ecas, evt<-eventsFrom (ecaAction eca)]
-        visible _ = True
-
-   
-   
-   class Identified a => Rename a where
-    rename :: a->String->a
-    -- | the function uniqueNames ensures case-insensitive unique names like sql plug names
-    uniqueNames :: [String]->[a]->[a]
-    uniqueNames taken xs
-     = [p | cl<-eqCl (map toLower.name) xs  -- each equivalence class cl contains (identified a) with the same map toLower (name p)
-          , p <-if name (head cl) `elem` taken || length cl>1
-                then [rename p (name p++show i) | (p,i)<-zip cl [(1::Int)..]]
-                else cl
-       ]
-
-   instance Rename PlugSQL where
-    rename p x = p{sqlname=x}
-   
− src/lib/DatabaseDesign/Ampersand/Fspec/ToFspec/ADL2Plug.hs 
@@ -1,449 +0,0 @@-{-# OPTIONS_GHC -Wall #-}  
-module DatabaseDesign.Ampersand.Fspec.ToFspec.ADL2Plug 
-  (makeGeneratedSqlPlugs
-  ,makeUserDefinedSqlPlug 
-  )
-where
-import DatabaseDesign.Ampersand.Core.AbstractSyntaxTree hiding (sortWith)
-import DatabaseDesign.Ampersand.Core.Poset as Poset hiding (sortWith)
-import Prelude hiding (Ord(..))
-import DatabaseDesign.Ampersand.Basics
-import DatabaseDesign.Ampersand.Classes
-import DatabaseDesign.Ampersand.ADL1
-import DatabaseDesign.Ampersand.Fspec.Fspec
-import DatabaseDesign.Ampersand.Misc
-import DatabaseDesign.Ampersand.Fspec.ShowHS --for debugging
-import Data.Maybe
-import Data.Char
-import Data.List (nub,intercalate,intersect,partition,group,delete)
-import GHC.Exts (sortWith)
---import Debug.Trace
-
-fatal :: Int -> String -> a
-fatal = fatalMsg "Fspec.ToFspec.ADL2Plug"
-
-
-makeGeneratedSqlPlugs :: Options
-              -> A_Context
-              -> [Expression]  
-              -> [Declaration]    -- ^ relations to be saved in generated database plugs. 
-              -> [PlugSQL]
-makeGeneratedSqlPlugs flags context totsurs entityDcls = gTables
-  where
-        vsqlplugs = [ (makeUserDefinedSqlPlug context p) | p<-ctxsql context] --REMARK -> no optimization like try2specific, because these plugs are user defined
-        gTables = gPlugs ++ gLinkTables
-        gPlugs :: [PlugSQL]
-        gPlugs   = --trace "---\nStart makeEntityTables " $
-                   --trace ("with "++show (length entityDcls)++" relations and "++show(length vsqlplugs)++" userdefined plugs.\n")
-                         (makeEntityTables flags context entityDcls (gens context) (ctxgenconcs context) (relsUsedIn vsqlplugs))
-        -- all plugs for relations not touched by definedplugs and gPlugs
-        gLinkTables :: [PlugSQL]
-        gLinkTables = [ makeLinkTable context dcl totsurs
-                      | dcl<-entityDcls
-                      , Inj `notElem` multiplicities dcl
-                      , Uni `notElem` multiplicities dcl]
-
-
------------------------------------------
---makeLinkTable
------------------------------------------
--- makeLinkTable creates associations (BinSQL) between plugs that represent wide tables.
--- Typical for BinSQL is that it has exactly two columns that are not unique and may not contain NULL values
---
--- this concerns relations that are not univalent nor injective, i.e. flduniq=False for both columns
--- Univalent relations and injective relations cannot be associations, because they are used as attributes in wide tables.
--- REMARK -> imagine a context with only one univalent relation r::A*B.
---           Then r can be found in a wide table plug (TblSQL) with a list of two columns [I[A],r], 
---           and not in a BinSQL with a pair of columns (I/\r;r~, r)
---
--- a relation r (or r~) is stored in the trgFld of this plug
-
-
--- | Make a binary sqlplug for a relation that is neither inj nor uni
-makeLinkTable :: A_Context -> Declaration -> [Expression] -> PlugSQL
-makeLinkTable context dcl totsurs = 
-  case dcl of
-    Sgn{} 
-     | isInj dcl || isUni dcl 
-        -> fatal 55 $ "unexpected call of makeLinkTable("++show dcl++"), because it is injective or univalent."
-     | otherwise 
-        -> BinSQL
-             { sqlname = name dcl
-             , columns = ( -- The source field:
-                           Fld { fldname = concat["Src" | isEndo dcl]++name (source trgExpr)                       
-                               , fldexpr = srcExpr
-                               , fldtype = sqlTypeOf context (target srcExpr)
-                               , flduse  = if suitableAsKey (sqlTypeOf context (target srcExpr))
-                                           then ForeignKey (target srcExpr)
-                                           else PlainAttr
-                               , fldnull = isTot trgExpr
-                               , flduniq = isUni trgExpr
-                               } 
-                         , -- The target field:
-                           Fld { fldname = concat["Tgt" | isEndo dcl]++name (target trgExpr)                       
-                               , fldexpr = trgExpr
-                               , fldtype = sqlTypeOf context (target trgExpr)
-                               , flduse  = if suitableAsKey (sqlTypeOf context (target trgExpr))
-                                           then ForeignKey (target trgExpr)
-                                           else PlainAttr
-                               , fldnull = isSur trgExpr
-                               , flduniq = isInj trgExpr
-                               }
-                          ) 
-             , cLkpTbl = [] --in case of TOT or SUR you might use a binary plug to lookup a concept (don't forget to nub)
-             , mLkp    = trgExpr
-          --   , sqlfpa  = NO
-             }
-    _  -> fatal 90 "Do not call makeLinkTable on relations other than Sgn{}"
-   where
-    r_is_Tot = isTot dcl || dcl `elem` [ d |       EDcD d  <- totsurs]
-    r_is_Sur = isSur dcl || dcl `elem` [ d | EFlp (EDcD d) <- totsurs]
-    --the expr for the source of r
-    srcExpr
-     | r_is_Tot = EDcI (source dcl)
-     | r_is_Sur = EDcI (target dcl)
-     | otherwise = let er=EDcD dcl in EDcI (source dcl) ./\. (er .:. flp er)
-    --the expr for the target of r
-    trgExpr 
-     | not r_is_Tot && r_is_Sur = flp (EDcD dcl)
-     | otherwise                = EDcD dcl
-
-suitableAsKey :: SqlType -> Bool
-suitableAsKey st = 
-  case st of 
-    SQLChar{}    -> True
-    SQLBlob      -> False
-    SQLPass      -> False
-    SQLSingle    -> True
-    SQLDouble    -> True
-    SQLText      -> False
-    SQLuInt{}    -> True
-    SQLsInt{}    -> True
-    SQLId{}      -> True
-    SQLVarchar{} -> True
-    SQLBool{}    -> True
-
-
------------------------------------------
---rel2fld
------------------------------------------
--- Each relation yields one field f1 in the plug...
--- r is the relation from some kernel field k1 to f1
--- (fldexpr k1) is the relation from the plug's imaginary ID to k1
--- (fldexpr k1);r is the relation from ID to f1
--- the rule (fldexpr k1)~;(fldexpr k1);r = r holds because (fldexpr k1) is uni and sur, which means that (fldexpr k1)~;(fldexpr k1) = I
--- REMARK -> r may be tot or sur, but not inj. (fldexpr k1) may be tot.
---
--- fldnull and fldunique are based on the multiplicity of the relation (kernelpath);r from ID to (target r)
--- it is given that ID is unique and not null
--- fldnull=not(isTot (kernelpath);r)
--- flduniq=isInj (kernelpath);r
--- 
--- (kernel++plugAtts) defines the name space, making sure that all fields within a plug have unique names.
-
--- | Create field for TblSQL or ScalarSQL plugs 
-rel2fld :: A_Context
-        -> [Expression] -- ^ all relations (in the form either EDcD r, EDcI or EFlp (EDcD r)) that may be represented as attributes of this entity.
-        -> [Expression] -- ^ all relations (in the form either EDcD r or EFlp (EDcD r)) that are defined as attributes by the user.
-        -> Expression   -- ^ either EDcD r, EDcI c or EFlp (EDcD r), representing the relation from some kernel field k1 to f1
-        -> SqlField
-rel2fld context
-        kernel
-        plugAtts
-        e
- = Fld { fldname = fldName 
-       , fldexpr = e
-       , fldtype = sqlTypeOf context (target e)
-       , flduse  =  
-          let f expr =
-                 case expr of
-                    EDcI c   -> if suitableAsKey (sqlTypeOf context c)
-                                then TableKey ((not.maybenull) e) c
-                                else PlainAttr
-                    EDcD _   -> PlainAttr
-                    EFlp e'  -> f e'
-                    _        -> fatal 144 ("No flduse defined for "++show expr)
-          in f e
-       , fldnull = maybenull e
-       , flduniq = isInj e      -- all kernel fldexprs are inj
-                                -- Therefore, a composition of kernel expr (I;kernelpath;e) will also be inj.
-                                -- It is enough to check isInj e
-       }
-   where 
-   fldName = case [nm | (r',nm)<-table, e==r'] of 
-               []   -> fatal 117 $ "null names in table for e: " ++ show (e,table)
-               n:_  -> n
-     where 
-       table :: [(Expression, String)]
-       table   = [ entry
-                 | cl<-eqCl (map toLower.niceidname) (kernel++plugAtts)
-                 , entry<-if length cl==1 then [(rel,niceidname rel) |rel<-cl] else tbl cl]
-       tbl rs  = [ entry
-                 | cl<-eqCl (map toLower.name.source) rs
-                 , entry<-if length cl==1
-                          then [(rel,niceidname rel++name (source rel)) |rel<-cl]
-                          else [(rel,niceidname rel++show i)|(rel,i)<-zip cl [(0::Int)..]]]
-       niceidname (EFlp x) = niceidname x
-       niceidname (EDcD d) = name d
-       niceidname (EDcI c) = name c
-       niceidname rel      = fatal 162 ( "Unexpected relation found:\n"++
-                                        intercalate "\n  "
-                                        [ "***rel:"
-                                        , show rel
-                                        , "***kernel:"
-                                        , show kernel
-                                        , "***plugAtts:"
-                                        , show plugAtts
-                                        ]
-                                    )
-   --in a wide table, m can be total, but the field for its target may contain NULL values,
-   --because (why? ...)
-   --A kernel field may contain NULL values if
-   --  + its field expr is not total OR
-   --  + its field expr is not the identity relation AND the (kernel) field for its source may contain NULL values
-   --(if the fldexpr of a kernel field is the identity, 
-   -- then the fldexpr defines the relation between this kernel field and this kernel field (fldnull=not(isTot I) and flduniq=isInj I)
-   -- otherwise it is the relation between this kernel field and some other kernel field)
-   maybenull expr
-    | length(map target kernel) > length(nub(map target kernel))
-       = fatal 146 $"more than one kernel field for the same concept:\n    expr = " ++(show expr)++
-           intercalate "\n  *** " ( "" : (map (name.target) kernel)) 
-    | otherwise = case expr of
-                   EDcD dcl
-                        | (not.isTot) dcl -> True
-                        | otherwise -> (not.null) [()|k<-kernelpaths, target k==source dcl && isTot k || target k==target dcl && isSur k ]
-                   EFlp (EDcD dcl)
-                        | (not.isSur) dcl -> True
-                        | otherwise -> (not.null) [()|k<-kernelpaths, target k==source dcl && isSur k || target k==target dcl && isTot k]
-                   EDcI _ -> False
-                   _ -> fatal 152 ("Illegal Plug Expression: "++show expr ++"\n"++
-                                   " ***kernel:*** \n   "++
-                                   intercalate "\n   " (map show kernel)++"\n"++
-                                   " ***Attributes:*** \n   "++
-                                   intercalate "\n   " (map show plugAtts)++"\n"++
-                                   " ***e:*** \n   "++
-                                   ( show e)
-                                  )
-                                   
-                                   
-   kernelpaths = clos kernel
-    where
-     -- Warshall's transitive closure algorithm, adapted for this purpose:
-     clos :: [Expression] -> [Expression]
-     clos xs
-      = [ foldr1 (.:.) expr | expr<-exprList ]
-        where
-         exprList :: [[Expression]]
-      -- SJ 20131117. The following code (exprList and f) assumes no ISA's in the A-structure. Therefore, this works due to the introduction of EEps.
-         exprList = foldl f [[x] | x<-nub xs]
-                          (nub [c | c<-nub (map source xs), c'<-nub (map target xs), c==c'])
-         f :: [[Expression]] -> A_Concept -> [[Expression]]
-         f q x = q ++ [ls ++ rs | ls <- q, x == target (last ls)
-                                , rs <- q, x == source (head rs), null (ls `isc` rs)]
-                  
--- ^ Explanation:  rel is a relation from some kernel field k to f
--- ^ (fldexpr k) is the relation from the plug's ID to k
--- ^ (fldexpr k);rel is the relation from ID to f
-
------------------------------------------
---makeEntityTables  (formerly called: makeTblPlugs)
------------------------------------------
-{- makeEntityTables computes a set of plugs to obtain tables in a transactional database with minimal redundancy.
-   We call them "wide tables".
-   makeEntityTables computes entities with their attributes.
-   It is based on the principle that each concept is represented in at most one plug,
-   and each relation in at most one plug.
-   First, we determine the kernels for all plugs.
-   A kernel contains the concept table(s) for all concepts that are administered in the same entity.
-   For that, we collect all relations that are univalent, injective, and surjective (the kernel relations).
-      By the way, that includes all isa-relations, since they are univalent, injective, and surjective by definition.
-      Since isa-relations are not declared explicitly, they are generated separately.
-   If two concepts a and b are in the same entity, there is a concept g such that a isa g and b isa g.
-   Of all concepts in an entity, one most generic concept is designated as root, and is positioned in the first column of the table.
-   Secondly, we take all univalent relations that are not in the kernel, but depart from this kernel.
-   These relations serve as attributes. Code:  [a| a<-attRels, source a `elem` concs kernel]
-   Then, all these relations are made into fields. Code: plugFields = [rel2fld plugMors a| a<-plugMors]
-   We also define two lookup tables, one for the concepts that are stored in the kernel, and one for the attributes of these concepts.
-   For the fun of it, we sort the plugs on length, the longest first. Code:   sortWith ((0-).length.fields)
-   By the way, parameter allRels contains all relations that are declared in context, enriched with extra multiplicities.
-   This parameter allRels was added to makePlugs to avoid recomputation of the extra multiplicities.
-   The parameter exclusions was added in order to exclude certain concepts and relations from the process.
--}
--- | Generate non-binary sqlplugs for relations that are at least inj or uni, but not already in some user defined sqlplug
-makeEntityTables :: Options 
-                -> A_Context
-                -> [Declaration] -- ^ all relations in scope
-                -> [A_Gen]
-                -> [[A_Concept]] -- ^ concepts `belonging' together.
-                                 --   for each class<-conceptss: c,c'<-class:   c `join` c' exists (although there is not necessarily a concept d=c `join` c'    ...)
-                -> [Declaration] -- ^ relations that should be excluded, because they wil not be implemented using generated sql plugs. 
-                -> [PlugSQL]
-makeEntityTables flags context allDcls isas conceptss exclusions
- = sortWith ((0-).length.plugFields)
-    (map kernel2Plug kernelsWithAttributes)
-   where
-    diagnostics
-      = "\nallDcls:" ++     concat ["\n  "++showHSName r           | r<-allDcls]++
-        "\nallDcls:" ++     concat ["\n  "++showHS flags "\n  " r  | r<-allDcls]++
-        "\nconceptss:" ++   concat ["\n  "++showHS flags "    " cs | cs<-conceptss]++
-        "\nexclusions:" ++  concat ["\n  "++showHSName r           | r<-exclusions]++
-        "\nattRels:" ++     concat ["\n  "++showHS flags "    " e  | e<-attRels]++
-        "\n"
-    -- | kernels are computed, starting with the set of concepts, on the basis of generalization tuples.
-    kernPartition :: [A_Gen] -> [[A_Concept]] -- ^ This function contains the recipe to derive a set of kernels from a set of isa-pairs.
-    kernPartition specialzs
-     = foldl f (group (delete ONE (concs context))) specialzs
-       where f disjuncLists g = concat haves : nohaves
-               where
-                 (haves,nohaves) = partition (not.null.intersect (concs g)) disjuncLists
-    preKernels = kernPartition (gens context) -- Step 1: compute the kernels from the isa-pairs from the context
-    extraIsas  -- Step 2: Maybe extra isa-pairs are needed to ensure that each kernel has precisely one largest concept
-       = concat
-         [ case [c | c<-kernel, null (largerConcepts isas c)] of -- determine how many concepts in one kernel are largest
-             [_] -> []
-             rs  -> [ Isa{gengen=rootConcept, genspc=c} | c<-rs ]
-         | (rootConcept,kernel) <- zip [rc | i<-[0::Int ..]
-                                           , let rc=PlainConcept ("rootConcept"++show i)
-                                           , rc `notElem` concs context ]
-                                       preKernels
-         ]
-    kernls     -- Step 3: compute the kernels
-     = [ largerCs++[ c | c<-kernel, c `notElem` largerCs ]              -- put the largest element up front
-       | kernel <- kernPartition (extraIsas++gens context)                -- recompute the kernels with the extra isa-pairs.
-       , let largerCs = [c | c<-kernel, null (largerConcepts isas c)]   -- get the set of largest concepts (each kernel has precisely one)
-       ]
-    kernelsWithAttributes = dist attRels kernls []
-      where 
-        dist :: (Association attrib, Show attrib) => [attrib] -> [[A_Concept]] -> [([A_Concept], [attrib])] -> [([A_Concept], [attrib])]
-        dist []   []     result = result
-        dist atts []     _      = fatal 246 ("No kernel found for atts: "++show atts++"\n"++diagnostics)
-        dist atts (kernel:ks) result = dist otherAtts ks ([(kernel,attsOfK)] ++ result)
-           where (attsOfK,otherAtts) = partition belongsInK atts
-                 belongsInK att = source att `elem` kernel
-    -- | converts a kernel into a plug
-    kernel2Plug :: ([A_Concept],[Expression]) -> PlugSQL
-    kernel2Plug (kernel, attsAndIsaRels)
-     =  TblSQL 
-             { sqlname = name (head kernel) -- ++ " !!Let op: De ISA relaties zie ik hier nergens terug!! (TODO. HJO 20131201"
-             , fields  = map fld plugMors      -- Each field comes from a relation.
-             , cLkpTbl = conceptLookuptable
-             , mLkpTbl = attributeLookuptable ++ isaLookuptable
-             } 
-        where
-          (isaAtts,atts) = partition isISA attsAndIsaRels
-            where isISA (EDcI _) = True
-                  isISA _        = False
-          mainkernel = map EDcI kernel
-          plugMors :: [Expression]
-          plugMors = mainkernel++atts 
-          conceptLookuptable :: [(A_Concept,SqlField)]
-          conceptLookuptable    = [(target r,fld r) | r <-mainkernel]
-          attributeLookuptable :: [(Expression,SqlField,SqlField)]
-          attributeLookuptable  = -- kernel attributes are always surjective from left to right. So do not flip the lookup table!
-                                  [(e,lookupC (source e),fld e) | e <-plugMors] 
-          lookupC cpt           = head [f |(c',f)<-conceptLookuptable, cpt==c']
-          fld a                 = rel2fld context mainkernel atts a
-          isaLookuptable = [(e,lookupC (source e),lookupC (target e)) | e <- isaAtts ]    
-    -- attRels contains all relations that will be attribute of a kernel.
-    -- The type is the largest possible type, which is the declared type, because that contains all atoms (also the atoms of subtypes) needed in the operation.
-    attRels :: [Expression]
-    attRels = mapMaybe attExprOf (allDcls>- exclusions)
-     where
-       attExprOf :: Declaration -> Maybe Expression
-       attExprOf d =
-        case d of  --make explicit what happens with each possible decl...
-          Isn{} -> Nothing -- These relations are already in the kernel
-          Vs{}  -> Nothing -- Vs are not implemented at all
-          Sgn{} ->
-               case (isInj d, isUni d, isTot d, isSur d) of
-                    (False  , False  , _      , _      ) --Will become a link-table
-                        -> Nothing 
-                    (True   , False  , _      , _      )
-                        -> Just $ flp (EDcD d)
-                    (True   , True   , True   , False  ) --Equivalent to CLASSIFY s ISA t, however, it is named, so it must be stored in a plug!
-                        -> Just $ flp (EDcD d)
-                    _   -> Just $      EDcD d
-
------------------------------------------
---makeUserDefinedSqlPlug
------------------------------------------
---makeUserDefinedSqlPlug is used to make user defined plugs. One advantage is that the field names and types can be controlled by the user. 
---
---TODO151210 -> (see also Instance Object PlugSQL)
---              cLkpTbl TblSQL{} can have more than one concept i.e. one for each kernel field
---              a kernel may have more than one concept that is uni,tot,inj,sur with some imaginary ID of the plug (i.e. fldnull=False)
---              When is an ObjectDef a ScalarPlug or BinPlug?
---              When do you want to define your own Scalar or BinPlug
---rel2fld  (identities context) kernel plugAtts r
-
--- | Make a sqlplug from an ObjectDef (user-defined sql plug)
-makeUserDefinedSqlPlug :: A_Context -> ObjectDef -> PlugSQL
-makeUserDefinedSqlPlug context obj
- | null(attributes obj) && isIdent(objctx obj)
-    = ScalarSQL { sqlname   = name obj
-                , sqlColumn = rel2fld context [EDcI c] [] (EDcI c)
-                , cLkp      = c
-                } 
- | null(attributes obj) --TODO151210 -> assuming objctx obj is Rel{} if it is not I{}
-   = fatal 2372 "TODO151210 -> implement defining binary plugs in ASCII"
- | isIdent(objctx obj) --TODO151210 -> a kernel may have more than one concept that is uni,tot,inj,sur with some imaginary ID of the plug
-   = {- The following may be useful for debugging:
-     error 
-      ("\nc: "++show c++
-       "\nrels:"++concat ["\n  "++show r | r<-rels]++
-       "\nkernel:"++concat ["\n  "++show r | r<-kernel]++
-       "\nattRels:"++concat ["\n  "++show e | e<-attRels]++
-       "\nplugfields:"++concat ["\n  "++show plugField | plugField<-plugfields]
-      ) -}
-     TblSQL { sqlname = name obj
-            , fields  = plugfields
-            , cLkpTbl = conceptLookuptable     
-            , mLkpTbl = attributeLookuptable
-            }   
- | otherwise = fatal 279 "Implementation expects one concept for plug object (SQLPLUG tblX: I[Concept])."
-  where       
-   c   -- one concept from the kernel is designated to "lead" this plug, this is user-defined.
-     = source(objctx obj) 
-   rels --fields are user-defined as one deep objats with objctx=r. note: type incorrect or non-relation objats are ignored
-     = [(objctx att,sqltp att) | att<-attributes obj, source (objctx att)==c]   
-   kernel --I[c] and every non-endo r or r~ which is at least uni,inj,sur are kernel fields 
-          --REMARK -> endo r or r~ which are at least uni,inj,sur are inefficient in a way
-          --          if also TOT than r=I => duplicates, 
-          --          otherwise if r would be implemented as GEN (target r) ISA C then (target r) could become a kernel field
-     = [(EDcI c,sqltp obj)] 
-       ++ [(r,tp) |(r,tp)<-rels,not (isEndo r),isUni r, isInj r, isSur r]
-       ++ [(r,tp) |(r,tp)<-rels,not (isEndo r),isUni r, isInj r, isTot r, not (isSur r)]
-   attRels --all user-defined non-kernel fields are attributes of (rel2fld context (objctx c))
-     = (rels >- kernel) >- [(flp r,tp) |(r,tp)<-kernel] --note: r<-rels where r=objctx obj are ignored (objctx obj=I)
-   plugMors              = kernel++attRels
-   plugfields            = [fld r tp | (r,tp)<-plugMors] 
-   fld r tp              = (rel2fld context (map fst kernel) (map fst attRels) r){fldtype=tp}  --redefine sqltype
-   conceptLookuptable    = [(target e,fld e tp) |(e,tp)<-kernel]
-   attributeLookuptable  = [(er,lookupC (source er),fld er tp) | (er,tp)<-plugMors]
-   lookupC cpt           = head [f |(c',f)<-conceptLookuptable, cpt==c']
-   sqltp :: ObjectDef -> SqlType
-   sqltp att = head $ [sqlTypeOf' sqltp' | strs<-objstrs att,('S':'Q':'L':'T':'Y':'P':'E':'=':sqltp')<-strs]
-                      ++[SQLVarchar 255]
-
-sqlTypeOf :: A_Context -> A_Concept -> SqlType
-sqlTypeOf _ ONE = SQLBool -- TODO (SJ):  Martijn, why should ONE have a representation? Or should this rather be a fatal?
-sqlTypeOf context c
-    = case nub [ cdtyp cdef | cdef<-ctxcds context, name c==name cdef ] of
-       [str] -> sqlTypeOf' str
-       []    -> sqlTypeOf' ""
-       _     -> fatal 396 ("Multiple SQL types defined for concept "++name c)
-       
-sqlTypeOf' :: String -> SqlType
-sqlTypeOf' str = case str of
-       ('V':'a':'r':'c':'h':'a':'r':_) -> SQLVarchar 255 --TODO number
-       "Pass" -> SQLPass
-       ('C':'h':'a':'r':_) -> SQLChar 255 --TODO number
-       "Blob" -> SQLBlob
-       "Single" -> SQLSingle
-       "Double" -> SQLDouble
-       ('u':'I':'n':'t':_) -> SQLuInt 4 --TODO number
-       ('s':'I':'n':'t':_) -> SQLsInt 4 --TODO number
-       "Id" -> SQLId 
-       ('B':'o':'o':'l':_) -> SQLBool
-       "" -> SQLVarchar 255
-       _ -> fatal 335 ("Unknown type: "++str)

− src/lib/DatabaseDesign/Ampersand/Fspec/ToFspec/Calc.hs 
@@ -1,749 +0,0 @@-{-# OPTIONS_GHC -Wall #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE OverloadedStrings #-}
-module DatabaseDesign.Ampersand.Fspec.ToFspec.Calc
-            ( deriveProofs 
-            , lambda
-            , checkMono
-            , showProof, showPrf, assembleECAs, conjuncts, genPAclause
-          --  , testInterface
-            )
-where
-
-   import DatabaseDesign.Ampersand.Basics         (fatalMsg,Collection (isc),Identified(..),eqCl,Flippable(..))
-   import Data.List hiding (head)
-   import GHC.Exts (sortWith)
---   import Data.ByteString.Char8
---   import Data.ByteString.Lazy.Char8
-   import DatabaseDesign.Ampersand.Core.AbstractSyntaxTree hiding (sortWith)
-   import DatabaseDesign.Ampersand.ADL1
-   import DatabaseDesign.Ampersand.ADL1.Expression
-   import DatabaseDesign.Ampersand.Classes
-   import DatabaseDesign.Ampersand.Fspec.Fspec
-   import DatabaseDesign.Ampersand.Fspec.ShowADL (ShowADL(..), showREL)
-   import DatabaseDesign.Ampersand.Fspec.ShowECA (showECA)
-   import DatabaseDesign.Ampersand.Fspec.ToFspec.NormalForms  (delta,conjNF,disjNF,cfProof,dfProof,nfProof,simplify,normPA,proofPA)
-   import DatabaseDesign.Ampersand.Misc            (Lang(..),Options(..),PandocFormat(ReST),string2Blocks)
-   import Text.Pandoc.Builder
-   import Prelude hiding (head)
--- import Debug.Trace
-   
-   fatal :: Int -> String -> a
-   fatal = fatalMsg "Fspec.ToFspec.Calc"
-
-   head :: [a] -> a
-   head [] = fatal 30 "head must not be used on an empty list!"
-   head (a:_) = a
-
-   conjuncts :: Rule -> [DnfClause]
-   conjuncts = map disjuncts.exprIsc2list.conjNF.rrexp
-   disjuncts :: Expression -> DnfClause
-   disjuncts conj = (split (Dnf [] []).exprUni2list) conj
-    where split :: DnfClause -> [Expression] -> DnfClause
-          split (Dnf antc cons) (ECpl e: rest) = split (Dnf (e:antc) cons) rest
-          split (Dnf antc cons) (     e: rest) = split (Dnf antc (e:cons)) rest
-          split dc             []             = dc
-
-
--- testInterface :: Fspc -> Interface -> String
--- Deze functie is bedoeld om te bedenken hoe interfaces moeten worden afgeleid uit een vers vertaalde ObjectDef.
--- Nadat deze goed werkt kunnen de bewijsgenerator en de codegenerator worden gemaakt.
---   testInterface :: Options -> Fspc -> Interface -> String
---   testInterface flags fSpec ifc
---    = "\nInterface "++ name ifc++"("++intercalate ", " [showADL r++":"++name (target r) | r<-rels]++")\n"++
---      " - The parameters correspond to editable fields in a user interface.\n   "++
---      showADL ifc++"\n"++
---      " - Invariants:\n   "++intercalate "\n   " [showADL rule    | rule<-invs]++"\n"++
---      " - Derivation of clauses for ECA-rules:"   ++
---      concat [showClause fSpec (allClauses flags rule) | rule<-invs]++"\n"++
---{-
---      " - ECA rules:"++concat  [ "\n\n     "++showECA "\n     "  (eca{ecaAction=normPA (ecaAction eca)})
---                                 ++"\n------ Derivation ----->"++showProof (codeBlock . ("\n     "++) . showECA "\n     ") (proofPA (ecaAction eca))++"\n<------End Derivation --"
---                               | eca<-ecaRs]++"\n\n"++
----}
---      " - Visible relations:\n   "++intercalate "\n   " (spread 80 ", " [showADL r  | r<-vis])++"\n"
---    where
-----        showQ i (rel, shs,conj,r)
-----         = "\nQuad "++show i++":\nrelation: "++showADL rel++":\nshifts: "++concat ["\n"++showADLe s |s<-shs]++"\nconjunct: "++showADL conj++"\nrule: "++showADL r++""
-----TODO: Deze code komt ook voor in ADL2Fspec.hs. Dat lijkt dubbelop, en derhalve niet goed.
---        rels = nub (recur (ifcObj ifc))
---         where recur obj = [editMph (objctx o) | o<-attributes obj, editable (objctx o)]++[r | o<-attributes obj, r<-recur o]
---        vis        = nub (rels++map (I . target) rels)
---   --     visible r  = r `elem` vis
---        invs       = [rule | rule<-invariants fSpec, (not.null) (map makeDeclaration (relsUsedIn rule) `isc` vis)]
---   --     qs         = vquads fSpec
---   --     ecaRs      = assembleECAs fSpec
-----        editable (ERel Rel{} _)  = True    --WHY?? Stef, welke functie is de juiste?? TODO deze functie staat ook in ADL2Fspec.hs, maar is daar ANDERS(!)...
-----        editable _               = False
-----        editMph (ERel r@Rel{} _) = r       --WHY?? Stef, welke functie is de juiste?? TODO deze functie staat ook in ADL2Fspec.hs, maar is daar ANDERS(!)...
-----        editMph e                = fatal 64 $ "cannot determine an editable declaration in a composite expression: "++show e
---        -- De functie spread verspreidt strings over kolommen met een breedte van n.
---        -- Deze functie garandeert dat alle strings worden afgedrukt in de aangegeven volgorde.
---        -- Hij probeert daarbij zo weinig mogelijk regels te gebruiken,
---        -- en alleen de grens van n te overschrijden als een string zelf langer is dan n.
---        spread :: Int -> String -> [String] -> [String]
---        spread n str = f ""
---         where f stored []       = [stored | not (null stored)]
---               f [] (cs:css)     = f cs css
---               f stored (cs:css) | length stored > n = stored: f cs css
---                                 | length new   <= n = f new css 
---                                 | otherwise         = stored: f cs css
---                                   where new = stored++str++cs
-
-   deriveProofs :: Options -> Fspc -> Blocks
-   deriveProofs flags fSpec
-    = para ("Rules and their conjuncts for "<>(str.name) fSpec)<>
-      bulletList [ para ("rule r:   "<>str (showADL r)<>linebreak<>
-                         "rrexp r:  "<>str (showADL (rrexp r))<>linebreak<>
-                         "conjNF:   "<>str (showADL (conjNF (rrexp r)))<>linebreak<>
-                         interText linebreak [ "     conj: "<>str (showADL conj) | conj<-conjuncts r ]
-                        )
-                 | r<-grules fSpec++vrules fSpec]<>
-      para ("Transformation of user specified rules into ECA rules for "<>(str.name) fSpec)<>
-      para (linebreak<>"--------------"<>linebreak<>"First step: determine the "<>(str.show.length) qs<>" quads:")<>
-      bulletList [ para ( "-- quad ------------"<>linebreak<>"When relation "<>str (showADL rel)<>" is changed,"
-                          <>linebreak<>str (showADL r)
-                          <>(if length (cl_conjNF ccrs)<=1 then space else " ("<>(str.show.length.cl_conjNF) ccrs<>" conjuncts)")
-                          <>" must be restored."<>linebreak<>"This quad has conjunct: "<>(str.showADL.rc_conjunct) x
-                          <>" and "<>(str.show.length.rc_dnfClauses) x<>" dnf clauses."
-                        ) <>
-                   bulletList [ para (linebreak<>"Dnf clause "<>str (showADL dc)) | dc<-rc_dnfClauses x]
-                 | Quad rel ccrs<-qs, let r=cl_rule ccrs , x<-cl_conjNF ccrs ] <>
-      para (linebreak<>linebreak<>"Second step: assemble dnf clauses.") <>
-      bulletList [ para ( "Dnf clause "<>str (showADL dc)
-                          <>linebreak<>"is derived from rule "<>str (showADL r)
-                          <>linebreak
-                          <>case ms of
-                               []    -> "No relations affect this clause."
-                               [rel] -> "It can be called when relation " <>str (showADL rel)<>" is affected."
-                               _     -> "It can be called when relations "<>str (commaEng "or" [showADL rel | rel<-ms])<>" are affected."
-                        )
-                 | (ms,dc,r)<-
-                       [ (nub [ dcl |(dcl,_,_)<-cl],dc,r)
-                       | cl<-eqCl (\(_,_,dc)->dc) [(dcl,dc,r) |Quad dcl ccrs<-qs, let r=cl_rule ccrs, x<-cl_conjNF ccrs, dc<-rc_dnfClauses x]
-                       , let (_,dc,r) = head cl
-                       ]
-                 ]<>
-      para (linebreak<>"Third step: determine "<>(str.show.length.udefrules) fSpec<>" ECA rules"<>
-            if verboseP flags
-             then " (Turn --verbose off if you want to see ECA rules only)"
-             else " (Turn on --verbose if you want to see more detail)"
-           )<>
-      ( if verboseP flags then para ( "--------------"<>linebreak)<>bulletList derivations else fromList [] )<>
-      bulletList [ para ( "-- ECA Rule "<>(str.show.ecaNum) ecarule<>" ---------")<>
-                   codeBlock ("\n  "++showECA "\n  " ecarule{ecaAction=normPA (ecaAction ecarule)})<>
-                   bulletList [ para (linebreak<>"delta expression"<>linebreak<>space<>str (showADL d)
-                                      <>linebreak<>"derivation:"
-                                     )<>
-                                (showProof (para.str.showADL).nfProof showADL) d<>  -- nfProof produces its result in disjunctive normal form
-                                para ("disjunctly normalized delta expression"<>linebreak<>(str.showADL.disjNF) d)
-                              | verboseP flags, e@Do{}<-[ecaAction ecarule], let d = paDelta e ]
-                 | ecarule <- ecaRs]
-      {-
-      ++
-      [ linebreak<>"--------------", linebreak, linebreak<>"Fourth step: cascade blocking rules"
-      , linebreak
-      ]++
-      interText []
-        [ [linebreak<>"-- Raw ECA rule "<>(str.show.ecaNum) er<>"------------"<>linebreak<>str (showECA "\n  " er)]
-        | er<- ecaRs]
-      ++
-      [ linebreak<>"--------------", linebreak, linebreak<>"Fifth step: preEmpt the rules (= optimize)"
-      , linebreak
-      ]++
-{- TODO: readdress preEmpt. It is wrong
-      interText []
-        [ [linebreak<>"-- Preempted ECA rule "<>(str.show.ecaNum) er<>"------------"<>linebreak<>str (showECA "\n  " er)]
-        | er<- preEmpt ecaRs]
-      ++ -}
-{-
-      [ linebreak<>"--------------", linebreak]
-      ++ -- TODO: make an ontological analysis, which explains the delete behaviour.
-      [ Str "Ontological analysis: ", linebreak<>"  "]
-      ++
-      interText [linebreak, linebreak<>"  "] 
-          [ [Str (name ifc)<>"("]
-            ++ interText ", "
-                 [str (name a)<>"["<>(str.name.target.ctx) a<>"]"
-                 |a<-attributes (ifcObj ifc)]
-            ++ [Str "):", linebreak<>"  "]
-          | ifc<-interfaceS fSpec]
-      ++
-      [ linebreak<>"--------------", linebreak
-      <>"Analyzing interfaces:", linebreak<>"     "]
-      ++
-      interText [linebreak<>"     "] 
-         [[Str (testInterface flags fSpec ifc)]
-         | ifc<-take 1 (interfaceG fSpec)]
-      ++
-      [ linebreak<>"--------------", linebreak]
-      -}
--}
-      where 
-  --     visible _  = True -- We take all quads into account.
-       qs         = vquads fSpec  -- the quads that are derived for this fSpec specify dnf clauses, meant to maintain rule r, to be called when relation rel is affected (rel is in r).
-          --   assembleECAs :: Fspc -> [ECArule]
-       commaEng :: String -> [String] -> String
-       commaEng  _  []       = ""
-       commaEng  _  [x]      = x
-       commaEng chs [x,y]    = x++" "++chs++" "++y
-       commaEng chs (x:y:ys) = x++", "++commaEng chs (y:ys)
-    -- interText :: (Data.String.IsString a, Data.Monoid.Monoid a) => a -> [a] -> a
-       interText _ [] = ""
-       interText inbetween (xs:xss) = xs<>inbetween<>interText inbetween xss
-       derivations :: [Blocks]
-       ecaRs :: [ECArule]
-       (ecaRs, derivations) = unzip (assembleECAs fSpec)
-{-
-           [ str ("Available code fragments on rule "<>name rule<>":", linebreak ]<>
-           interText [linebreak] [showADL rule<> " yields\n"<>interText "\n\n"
-                                   [ ["event = ", str (show ev), space, str (showADL rel), linebreak ] <>
-                                     [str (showADL r<>"["<>showADL rel<>":="<>showADL (actSem ev (EDcD rel) (delta (sign rel)))<>"] = r'"), linebreak ] <>
-                                     ["r'    = "] <> conjProof r' <> [linebreak ] <>
-                                     ["viols = r'-"] <> disjProof (ECpl r') <> [ linebreak ] <>
-                                     "violations, considering that the valuation of "<>showADL rel<>" has just been changed to "<>showADL (actSem ev (EDcD rel) (delta (sign rel)))<>
-                                     "            "<>conjProof (ECpl r) <>"\n"<>
-                                     "reaction? evaluate r |- r' ("<>(str.showADL.conjNF) (notCpl r .\/. r')<>")"<>
-                                        conjProof (notCpl r .\/. r')<>"\n"<>
-                                     "delta: r-/\\r' = "<>conjProof (EIsc[notCpl r,r'])<>
-                                     "\nNow compute a reaction\n(isTrue.conjNF) (notCpl r .\/. r') = "<>show ((isTrue.conjNF) (notCpl r .\/. r'))<>"\n"<>
-                                     (if null (lambda ev (ERel rel ) r)
-                                      then "lambda "<>showADL rel<>" ("<>showADL r<>") = empty\n"
-                                      else -- for debug purposes:
-                                           -- "lambda "<>show ev<>" "<>showADL rel<>" ("<>showADL r<>") = \n"<>(interText "\n\n".map showPr.lambda ev (ERel rel)) r<>"\n"<>
-                                           -- "derivMono ("<>showADL r<>") "<>show ev<>" "<>showADL rel<>"\n = "<>({-interText "\n". map -}showPr.derivMono r ev) rel<>"\n"<>
-                                           -- "\nNow compute checkMono r ev rel = \n"<>show (checkMono r ev rel)<>"\n"<>
-                                           if (isTrue.conjNF) (notCpl r .\/. r')
-                                           then "A reaction is not required, because  r |- r'. Proof:"<>conjProof (notCpl r .\/. r')<>"\n"
-                                           else if checkMono r ev rel
-                                           then "A reaction is not required, because  r |- r'. Proof:"{-<>(str.showPr.derivMono r ev) rel-}<>"NIET TYPECORRECT: (showPr.derivMono r ev) rel"<>"\n"  --WHY? Stef, gaarne herstellen...Deze fout vond ik nadat ik het type van showProof had opgegeven.
-                                           else let ERel _ _ = delta (sign rel) in
-                                                "An appropriate reaction on this event is required."
-                                           --     showECA "\n  " (ECA (On ev rel) delt (genPAclause visible Ins r viols conj [rule]) 0)
-                                     )
-                                   | rel<-relsUsedIn r   -- nub [x |x<-relsUsedIn r, not (isIdent x)] -- TODO: include proofs that allow: isIdent rel'
-                                   , ev<-[Ins,Del]
-                                   , r'<-[subst (rel, actSem ev (EDcD rel) (delta (sign rel))) r]
-                        --        , viols<-[conjNF (ECpl r')]
-                                   , True ]  -- (isTrue.conjNF) (notCpl r .\/. r')
-                                  | r<-[dc | cs<-[allClauses flags rule], (_,dnfClauses)<-cl_conjNF cs, dc<-dnfClauses]
-                                  ]
-           where e = rrexp rule
-                 prf = cfProof showADL e
-                 (exx',_,_) = last prf
-            --     conjProof = showProof (para.str.showADL) . cfProof showADL
-                 disjProof = showProof (para.str.showADL) . dfProof showADL
---                 showPr    = showProof (para.str.showADL)  -- hoort bij de uitgecommentaarde code hierboven...
-       --TODO: See ticket #105
--}
-
--- Stel we voeren een actie a uit, die een(1) van de volgende twee is:
---        {r} INS rel INTO expr {r'}       ofwel
---        {r} DEL rel FROM expr {r'}
--- Dan toetst checkMono of r|-r' waar is op grond van de afleiding uit derivMono.
--- Als dat waar is, betekent dat dat invariant r waar blijft wanneer actie a wordt uitgevoerd.
-   checkMono :: Expression
-             -> InsDel
-             -> Declaration
-             -> Bool
-   checkMono expr ev dcl
-     = case ruleType conclusion of
-        Truth -> fatal 247 "derivMono came up with a Truth!"
-        _     -> simplify expr == simplify (antecedent conclusion) &&
-                 simplify (subst (dcl, actSem ev (EDcD dcl) (delta (sign dcl))) expr) ==
-                 simplify (consequent conclusion)
-     where (conclusion,_,_) = last (derivMono expr ev dcl)
-
-
-   type Proof expr = [(expr,[String],String)]
-   reversePrf :: Proof e -> Proof e
-   reversePrf [] = []
-   reversePrf [s] = [s]
-   reversePrf ((r,cs,e'):prf@((r',_ ,_):_)) = init rp++[(r',cs,rev e'),(r,[],"")]
-     where rp = reversePrf prf
-           rev "==>" = "<=="
-           rev "<==" = "==>"
-           rev "-->" = "<--"
-           rev "<--" = "-->"
-           rev x = x
-
-   showProof :: (expr->Blocks) -> Proof expr -> Blocks
-   showProof shw [(expr,_,_)]        = shw expr
-   showProof shw ((expr,ss,equ):prf) = shw expr<>
-                                       para (if null ss  then str equ else
-                                             if null equ then str (unwords ss) else
-                                             str equ<>str (" { "++intercalate " and " ss++" }"))<>
-                                       showProof shw prf
-                                       --where e'= if null prf then "" else let (expr,_,_):_ = prf in showHS options "" expr 
-   showProof _  []                   = fromList []
-
-   showPrf :: (expr->String) -> Proof expr -> [String]
-   showPrf shw [(expr,_,_)]        = [ "    "++shw expr]
-   showPrf shw ((expr,ss,equ):prf) = [ "    "++shw expr] ++
-                                     (if null ss  then [ equ ] else
-                                      if null equ then [ unwords ss ] else
-                                      [ equ++" { "++intercalate " and " ss++" }" ])++
-                                     showPrf shw prf
-   showPrf _  []                   = []
-
--- derivMono provides a derivation to prove that (precondition) r is a subset of (postcondition) r'.
--- This is useful in proving that an action {expr} a {expr'} maintains its invariant, i.e. that  expr|-expr'  holds (proven by monotony properties)
--- Derivmono gives a derivation only.
-   derivMono :: Expression -> InsDel -> Declaration -> [(Rule, [String], String)]
-   derivMono expr -- preconditie van actie a
-             tOp  -- de actie (Ins of Del)
-             dcl' -- re relatie, zodat de actie bestaat uit INSERT rel' INTO expr of DELETE rel' FROM expr
-    = f (head (lambda tOp (EDcD dcl') expr++[[]])) (start tOp)
-    where
-     f :: [(Expression, [String], whatever)] 
-        -> (Expression, Expression) 
-        -> [(Rule, [String], String)]
-     f [] (_,_) = []
-     f [(e',_,_)] (neg',pos')
-      = [(rule (subst (dcl',neg') e') (subst (dcl',pos') e'),[],"")]
-     f ((e',["invert"],_): prf@((_,_,_):_)) (neg',pos')
-      = (rule (subst (dcl',neg') e') (subst (dcl',pos') e'),["r |- s  <=>  s- |- r-"],"<=>"):
-         f prf (pos',neg')
-     f ((e1,_,_): prf@((e2,_,_):_)) (neg',pos')
-      = (rule (subst (dcl',neg') e1) (subst (dcl',pos') e1),["Monotony of "++showOp e2],"==>"):
-         f prf (neg',pos')
-         
-     start Ins  = (EDcD dcl',EDcD dcl' .\/. delta (sign dcl'))
-     start Del  = (EDcD dcl' ./\. notCpl (delta (sign dcl')),EDcD dcl')
-
-     rule :: Expression -> Expression -> Rule
-     rule neg' pos' | isTrue neg' = Ru { rrnm  = ""
-                                       , rrfps = Origin "rule generated for isTrue neg' by Calc"
-                                       , rrexp = pos'
-                                       , rrmean = AMeaning
-                                                  [A_Markup Dutch   ReST (string2Blocks ReST "Waarom wordt deze regel hier aangemaakt? (In Calc.hs, regel 402)")
-                                                  ,A_Markup English ReST (string2Blocks ReST "Why is this rule created? (In Calc.hs, line 403)")]  --TODO Stef, gaarne de explanations aanvullen/verwijderen. Dank! Han.
-                                       , rrmsg = []
-                                       , rrviol = Nothing
-                                       , rrtyp = sign neg' {- (neg `meet` pos) -}
-                                       , rrdcl = Nothing
-                                       , r_env = ""
-                                       , r_usr = Multiplicity
-                                       , isSignal = fatal 336 $ "erroneous reference to isSignal in rule ("++showADL neg'++") |- ("++showADL pos'++")"
-                                       , srrel = fatal 337 $ "erroneous reference to srrel in rule ("++showADL neg'++") |- ("++showADL pos'++")"
-                                       }
-                    | otherwise   = Ru { rrnm  = ""
-                                       , rrfps = Origin "rule generated for not(isTrue neg') by Calc"
-                                       , rrexp = neg' .|-. pos'
-                                       , rrmean = AMeaning
-                                                  [A_Markup Dutch   ReST (string2Blocks ReST "Waarom wordt deze regel hier aangemaakt? (In Calc.hs, regel 332)")
-                                                  ,A_Markup English ReST (string2Blocks ReST "Why is this rule created? (In Calc.hs, line 333)")]  --TODO Stef, gaarne de explanations aanvullen/verwijderen. Dank! Han.
-                                       , rrmsg = []
-                                       , rrviol = Nothing
-                                       , rrtyp = sign neg' {- (neg `meet` pos) -}
-                                       , rrdcl = Nothing
-                                       , r_env = ""
-                                       , r_usr = Multiplicity
-                                       , isSignal = fatal 352 $ "illegal reference to isSignal in rule ("++showADL neg'++") |- ("++showADL pos'++")"
-                                       , srrel = fatal 353 $ "illegal reference to srrel in rule ("++showADL neg'++") |- ("++showADL pos'++")"
-                                       }
-     showOp expr' = case expr' of
-                     EEqu{} -> "="
-                     EImp{} -> "|-"
-                     EIsc{} -> "/\\"
-                     EUni{} -> "\\/"
-                     EDif{} -> "-"
-                     ELrs{} -> "/"
-                     ERrs{} -> "\\"
-                     EDia{} -> "<>"
-                     ECps{} -> ";"
-                     ERad{} -> "!"
-                     EPrd{} -> "*"
-                     EKl0{} -> "*"
-                     EKl1{} -> "+"
-                     EFlp{} -> "~"
-                     ECpl{} -> "-"
-                     _      -> ""
-
-{- The purpose of function lambda is to generate a derivation.
-Rewrite rules:
--r;-s -> -(r!s)
--}
-   lambda :: InsDel -> Expression 
-                    -> Expression 
-                    -> [Proof Expression]
-   lambda tOp' e' expr' = [reversePrf[(e'',txt,op)
-                          | (e'',_,txt,op)<-prf]
-                          | prf<-lam tOp' e' expr' ]
-    where
-     lam :: InsDel -> Expression -> Expression ->
-            [[(Expression,Expression -> Expression,[String],String)]]
-     lam tOp e3 expr =
-          case expr of
-             EIsc{}  | e3==expr             -> [[(e3,id,[],"")]]
-                     | length (const' expr)>0 -> [(expr,\_->expr,      [derivtext tOp "mono" (inter' expr) expr],"<--") :prf
-                                                 | prf<-lam tOp e3 (inter' expr)
-                                                 ]
-                     | and [isNeg f |f<-exprIsc2list expr]
-                                            -> let deMrg = deMorganEIsc expr in
-                                               [(expr, deMorganEIsc, [derivtext tOp "equal" deMrg expr],"==") :prf | prf<-lam tOp e3 deMrg]
-                     | or[null p |p<-fPrfs] -> []
-                     | otherwise            -> [(expr,\_->expr,    [derivtext tOp "mono" (first lc) expr],"<--") : lc]
-             EUni{}  | e3==expr             -> [[(e3,id,[],"")]]
-                     | length (const' expr)>0 -> [(expr,\_->expr, [derivtext tOp "mono" (inter' expr) expr],"<--") :prf
-                                                      | prf<-lam tOp e3 (inter' expr)
-                                                      ]
-                     | and [isNeg f |f<-exprUni2list expr]
-                                            -> let deMrg = deMorganEUni expr in
-                                               [(expr, deMorganEUni, [derivtext tOp "equal" deMrg expr],"==") :prf | prf<-lam tOp e3 deMrg]
-                     | or[null p |p<-fPrfs] -> []
-                     | otherwise            -> [(expr,\_->expr,    [derivtext tOp "mono" (first lc) expr],"<--") : lc]
-             ECps{}  | e3==expr             -> [[(e3,id,[],"")]]
-                     | and [isNeg f |f<-exprCps2list expr]
-                                            -> let deMrg = deMorganECps expr in
-                                               [(expr, deMorganECps, [derivtext tOp "equal" deMrg expr],"==")
-                                               :prf
-                                               | prf<-lam tOp e3 deMrg
-                                               ] -- isNeg is nog niet helemaal correct.
-                     | or[null p|p<-fPrfs]  -> []
-                     | otherwise            -> [(expr,\_->expr,    [derivtext tOp "mono" (first lc) expr],"<--"): lc]        
-             ERad{}  | e3==expr             -> [[(e3,id,[],"")]]
-                     | and [isNeg f |f<-exprRad2list expr]
-                                            -> let deMrg = deMorganERad expr in
-                                               [(expr, deMorganERad, [derivtext tOp "equal" deMrg expr],"==") :prf | prf<-lam tOp e3 deMrg] -- isNeg is nog niet helemaal correct.
-                     | or[null p |p<-fPrfs] -> []
-                     | otherwise            -> [(expr,\_->expr,    [derivtext tOp "mono" (first lc) expr],"<--"): lc]
-             EKl0 x                         -> [(expr,\e->EKl0 e,[derivtext tOp "mono" x expr],"<--") :prf   | prf<-lam tOp e3 x]
-             EKl1 x                         -> [(expr,\e->EKl1 e,[derivtext tOp "mono" x expr],"<--") :prf   | prf<-lam tOp e3 x]
-             ECpl x                         -> [(expr,\e->ECpl e,["invert"],"<--") :prf | prf<-lam (inv tOp) e3 x]
-             EBrk x                         -> lam tOp e3 x
-             _                              -> [[(e3,id,[],"")]]
-           where
-               sgn   = sign expr
-               fPrfs = case expr of
-                        EUni{} -> [lam tOp e3 f |f<-exprUni2list expr, isVar f e3]
-                        EIsc{} -> [lam tOp e3 f |f<-exprIsc2list expr, isVar f e3]
-                        ECps{} -> [lam tOp e3 f |f<-exprCps2list expr, isVar f e3]
-                        ERad{} -> [lam tOp e3 f |f<-exprRad2list expr, isVar f e3]
-                        _      -> fatal 428 ("fPrfs  is not defined.Consult your dealer!")
-               lc = longstcomn vars++concat (drop (length rc-1) (sortWith length rc))
-               rc = remainders vars vars
-               vars = map head fPrfs
-               const' e@EUni{} = [f |f<-exprUni2list e, isConst f e3]
-               const' e@EIsc{} = [f |f<-exprIsc2list e, isConst f e3]
-               const' expr'' = fatal 440 $ "'const'("++ show expr''++")' is not defined.Consult your dealer!"
-               inter' e@EUni{} = foldr (.\/.) (notCpl (EDcV sgn)) [f |f<-exprUni2list e, isVar f e3]
-               inter' e@EIsc{} = if and [sgn==sign f | f<-exprIsc2list e, isVar f e3]
-                                 then foldr (./\.) (EDcV sgn) [f | f<-exprIsc2list e, isVar f e3]
-                                 else fatal 532 ("signature error in inter'  "++show [(showADL f,showSign (sign f)) | f<-exprIsc2list e, isVar f e3])
-               inter' expr'' = fatal 443 $ "'inter'("++ show expr''++")' is not defined.Consult your dealer!"
- --      lam tOp e f       = []
-
-  -- longstcomn determines the longest prefix common to all xs in xss.
-     longstcomn :: (Eq a) => [[(a, b, c, d)]] -> [(a, b, c, d)]
-     longstcomn xss | or [null xs | xs<-xss]      = []
-                    | length (eqCl first xss)==1 = head [head prf | prf<-xss]: longstcomn [tail prf | prf<-xss]
-                    | otherwise                  = []
-    -- remainders determines the remainders.
-     remainders :: (Eq a) => [[(a, b, c, d)]] -> [[(a, b, c, d)]] -> [[(a, b, c, d)]]
-     remainders _ xss | or [null xs | xs<-xss]      = xss
-                      | length (eqCl first xss)==1 = remainders xss [tail prf | prf<-xss]
-                      | otherwise                  = xss
-     isConst :: (ConceptStructure a, ConceptStructure b) => a->b->Bool
-     isConst e f = null (relsUsedIn e `isc` relsUsedIn f)
-     isVar :: (ConceptStructure a, ConceptStructure b) => a->b->Bool
-     isVar e f   = not (isConst e f)
-     derivtext :: InsDel -> String -> Expression -> Expression -> String
-     derivtext tOp "invert" e'' expr = sh tOp++showADL e''++" means "++sh (inv tOp)++showADL expr++"."
-     derivtext tOp "mono"    e'' expr = "("++showADL e''++"->"++showADL expr++") is monotonous, so "++sh tOp++showADL e''++" means "++sh tOp++showADL expr++"."
-     derivtext _ txt _ _ = txt
-     sh :: InsDel -> String
-     sh Ins  = "insert into "
-     sh Del  = "delete from "
-     inv :: InsDel -> InsDel
-     inv Ins = Del
-     inv Del = Ins
-     first :: [(a,b,c,d)] -> a
-     first ((e'',_,_,_):_) = e''
-     first _ = fatal 472 "wrong pattern in first"
-     
-   ruleType :: Rule -> RuleType
-   ruleType r = case rrexp r of
-                 EEqu{} -> Equivalence
-                 EImp{} -> Implication
-                 _      -> Truth
-
-
-   -- | Action semantics for inserting a delta into a relation dcl.
-   actSem :: InsDel -> Expression -> Expression -> Expression
-   actSem Ins dcl delt | sign dcl/=sign delt = fatal 598 "Type error in actSem Ins"
-                       | dcl==delt           = dcl
-                       | otherwise           = disjNF (dcl .\/. delt)
-   actSem Del dcl delt | sign dcl/=sign delt = fatal 598 "Type error in actSem Del"
-                       | dcl==delt           = notCpl (EDcV (sign dcl))
-                       | otherwise           = conjNF (dcl ./\. notCpl delt)
-
-   -- | assembleECAs  assembles larger chunks of code, because it combines acts that are triggered by the same event.
-   assembleECAs :: Fspc -> [(ECArule,Blocks)]
-   assembleECAs fSpec
-    = [eca i | (eca,i) <- zip ecas [(1::Int)..]]
-      where
-       ecas :: [Int->(ECArule,Blocks)]
-       ecas
-         = [ (\ruleNr->( ECA ecaEvt delt normEcaAct ruleNr
-                       , para ("Let us analyse what happens "<>str (show (On ev rel))<>".")<>
-                         bulletList [ txt | (_,_,_,txt)<-acts]<>
-                         ( if length ecaProof>1
-                           then para ("The resulting action is:\n     ")<>
-                                showProof (codeBlock . ("\n     "++) . showECA "\n     ") ecaProof
-                           else fromList []
-                         )<>
-                         para ("These results lead to the following ECA-rule:\n     ")<>
-                         (codeBlock . ("\n     "++) . showECA "\n     ".ecaRule) ruleNr
-                       )
-             )
-           | rel <- allDecls fSpec ++ [ Isn c | c<-allConcepts fSpec, c/=ONE] -- This is the relation in which a delta is being inserted or deleted.
-           , let relEq = [ q | q<-vquads fSpec, qDcl q==rel] -- Gather the quads with the same declaration (qDcl). A quad has a declaration (qDcl) and clauses (qClauses)
-           , let quadClauses = (nub.map qClauses) relEq      -- these are the clauses
-           , let EDcD delt = delta (sign rel)                -- delt is a placeholder for the pairs that have been inserted or deleted in rel.
-           , ev<-[Ins,Del]
-           , let acts = [ -- go through all the events that affect that clause:
-                          (normPA act, conj, rule,
-                          para ("Let us analyse clause "<>str (showADL expr)<>" from rule "<>(singleQuoted.str.name) rule<>".")<>
-                          para ("event = "<>str (show ev)<>space<>str (showREL rel)<>" means doing the following substitution")<>
-                          para (str (showADL clause<>"["<>showREL rel<>":="<>showADL (actSem ev (EDcD rel) (delta (sign rel)))<>"] = clause'"))<>
-                          para ("clause' = "<>str (showADL ex')<>
-                                if clause'==ex'
-                                then ", which is already in conjunctive normal form."<>linebreak
-                                else ", which has conjunctive normal form: "<>linebreak<>str (showADL clause')
-                               )<>
-                          para ("Let us compute the violations to see whether invariance is maintained."<>linebreak<>
-                                "This means to negate the result (notClau = notCpl clause'): ")<>
-                          (showProof (para.str.showADL). cfProof showADL) notClau<>
-                          para ("So, notClau has CNF: "<>str (showADL viols )<>linebreak<>
-                                ( if viols==viols'
-                                  then "This expression is in disjunctive normal form as well."
-                                  else str ("In DNF, notClau is:  "<>showADL viols'<>".")))<>
-                          ( if isTrue clause'
-                            then para ("This result proves the absence of violations, so a reaction of doing nothing is appropriate."<>linebreak
-                                       <>"Just for fun, let us try to derive whether clause |- clause' is true... ")<>
-                                 (showProof (para.str.showADL). cfProof showADL) (expr .|-. clause')
-                            else para ("This result does not prove the absence of violations, so we cannot conclude that invariance is maintained."<>linebreak<>
-                                       "We must compute a reaction to compensate for violations..."<>linebreak<>
-                                       "That would be to reinsert violations that originate from "<>
-                                       ( if ev==Ins
-                                         then str (showADL (conjNF negs))<>" into "<> str (showADL (disjNF poss))<>"."
-                                         else str (showADL (disjNF poss))<>" into "<> str (showADL (conjNF negs))<>"."
-                                       )<>linebreak<>"deltFr: ")<>
-                                 (showProof (para.str.showADL). dfProof showADL) deltFr<>
-                                 ( let pr=proofPA act in
-                                   if length pr>1
-                                   then para "Now let us remove redundancy from the ECA action:\n     "<>
-                                        showProof (codeBlock . ("\n     "++) . showECA "\n     ") (proofPA act)
-                                   else fromList []
-                                 )
-                          {-     <> "To finish the analysis of case "<>str (show ev)<>space<>str (showADL rel)
-                                    <>", let us compute the contents of "<>str (showADL toExpr)<>" after insertion of viols."<>linebreak
-                                    <>
-                                 ( if length (nub [sign viols, sign viols', sign toExpr])>1
-                                   then fatal 248 ("viols"<>showSign (sign viols) <>"   "<>showADL viols <>"\n"<>
-                                                   "viols'"<>showSign (sign viols')<>"  "<>showADL viols'<>"\n"<>
-                                                   "toExpr"<>showSign (sign toExpr)<>"  "<>showADL toExpr)
-                                   else if ev==Ins
-                                   then (showProof (para.str.showADL). cfProof showADL) (viols'.\/.toExpr)<>linebreak
-                                   else (showProof (para.str.showADL). dfProof showADL) (notCpl viols./\.toExpr)<>linebreak
-                                 ) -}
-                          ))
-                        | Clauses ts rule<-quadClauses, conj<-ts                  -- get conjuncts from the clauses
-                        , clause@(Dnf antcs conss) <- rc_dnfClauses conj          -- the DNF form of each clause
-                        , let expr    = dnf2expr clause                           -- Note that this differs from:  rc_conjunct conj
-                        , let vee     = EDcV (sign expr)
-                        , let ex'     = subst (rel, actSem ev (EDcD rel) (delta (sign rel))) expr -- the clause after the edit action
-                        , let clause' = conjNF ex'                                                -- its CNF
-                        , not (isTrue clause')
-                        , let notClau = notCpl clause'                                            -- the violations after the edit action
-                        , let viols   = conjNF notClau                                            -- the violations after the edit action
-                        , let viols'  = disjNF notClau                                            -- the violations after the edit action
-                        , let negs    = if (length.nub.map sign) (vee:antcs)>1
-                                        then fatal 265 ("type inconsistencies in antcs: "++show (map showADL (vee:antcs)))
-                                        else foldr (./\.) vee antcs
-                        , let poss    = if (length.nub.map sign) (vee:conss)>1
-                                        then fatal 265 ("type inconsistencies in conss: "++show (map showADL (vee:conss)))
-                                        else foldr (.\/.) (notCpl vee) conss
-                        , let frExpr  = case ev of
-                                         Ins -> disjNF (notCpl negs)
-                                         Del -> disjNF poss
-                        , let deltFr  = if sign poss/=sign negs
-                                        then fatal 274 ("type inconsistencies in deltFr: "++showADL clause)
-                                        else if ev==Ins
-                                        then (subst (rel, actSem ev (EDcD rel) (delta (sign rel)))) negs ./\. notCpl poss
-                                        else (notCpl . subst (rel, actSem ev (EDcD rel) (delta (sign rel)))) poss ./\. negs
-                        , let deltFr' = disjNF deltFr
-                        , rel `elem` relsMentionedIn frExpr
-                        , let toExpr  = if ev==Ins
-                                        then disjNF poss
-                                        else disjNF (notCpl negs)
-                        , let visible _ = True
-                        , if length (nub (map sign [toExpr, deltFr', expr]))>1
-                          then fatal 285 "type problem"
-                          else True
-                        , let act = genPAclause visible Ins toExpr deltFr' [(expr,[rule])]
-                        ]
-           , let ecaAct = ALL (map fst4 acts
-           -- The following acts add the implicit rules, which allows the user to add and delete atoms from concepts in a safe way.
-                               ++ [act' | (ev',rel',act')<-rulesDecls++rulesGens rel, ev==ev', rel==rel' ]
-                              )
-                              [ (rc_conjunct conj,[rule]) | (_,conj,rule,_)<-acts] --motivation is of type [(Expression,[Rule])]
-           , let normEcaAct = normPA ecaAct
-           , let ecaProof = proofPA ecaAct
-           , let ecaEvt = On ev rel
-           , let ecaRule = ECA ecaEvt delt normEcaAct
-           ]
---   the following eca-rules are derived from the typing rules, rather than explicit rules specified by users.
---   This concerns the following rules:
---   Each declaration "RELATION r[A*B]" represents the rule "RULE r[A*B] |- V[A*B]"
---   Besides, for every A, B:   "RULE  I[A]*I[B] = V[A*B]"
---   For every "CLASSIFY A ISA B" we get  "RULE  I[A] |- I[B]"
---   For every "CLASSIFY A IS B /\ C" we get "RULE  I[A] |- I[B]" and "RULE  I[A] |- I[C]"
---   The results of both classify statements are available through vgens.
---   Finally, for every Atom c a there is a rule  "RULE  'a' |- I[c]"
---   The eca-rules that can be derived from these rules are produced by  ecasFromTypes
-   {- V[A*B] is implicit, so we don't generate ECA (On Ins rel) delt (Do Ins (Vs (Sign a b)) delt motive).
-                        Neither do we generate ECA (On Del (Vs (Sign a b))) delt (Do Del rel delt motive).
-      However, we do generate:                 ECA (On Ins rel) delt (Do Ins (Isn a) ((dlt.<>.flp dlt).-.EDcI a) motive)
-                                         and:  ECA (On Ins rel) delt (Do Ins (Isn b) ((flp dlt.<>.dlt).-.EDcI b) motive),
-      because the delta to be inserted might contain new atoms.
-      Similarly, upon deletion of an atom from a concept we must delete the appropriate links from relations that share this concept.
-      So, we generate                          ECA (On Del (Isn a)) delt (Do Del rel (delt.:.V[A*B]) motive)
-                                         and:  ECA (On Del (Isn b)) delt (Do Del rel (V[A*B].:.delt) motive)
-      ECA-rules that are derivable from relation declarations are generated by rulesDecls
-   -}
-       rulesDecls :: [(InsDel, Declaration, PAclause)]
-       rulesDecls
-         = concat
-           [ [ (Ins, rel, Do Ins (Isn a) ((dlt.:.flp dlt ./\. EDcI a).-.EDcI a) [])
-             , (Ins, rel, Do Ins (Isn b) ((flp dlt.:.dlt ./\. EDcI b).-.EDcI b) [])
-             , (Del, Isn a, Do Del rel (delta (Sign a a).:.vee) [])
-             , (Del, Isn b, Do Del rel (vee.:.delta (Sign b b)) [])
-             ]
-           | rel <- allDecls fSpec, let dlt = delta (sign rel)
-           , let a=source rel, let b=target rel
-           , let vee = (EDcV . sign) rel
-           ]
-   {- We generate:
-        for every "RULE  I[A] |- I[B]":        ECA (On Ins (Isn a)) delt (Do Ins (Isn b) (EDcD delt) motive)
-                                   and:        ECA (On Del (Isn b)) delt (Do Del (Isn a) (EDcD delt) motive)
-        for every "RULE   'a' |- I[c]":        ECA (On Del (Isn c)) ('a','a') (Blk motive)
-   -}
-       rulesGens :: Declaration -> [(InsDel, Declaration, PAclause)]
-       rulesGens rel
-         = concat
-           [ [ (Ins, Isn s, Do Ins (Isn g) dlt [])
-             , (Del, Isn g, Do Del (Isn s) dlt [])
-             ]
-           | let dlt = delta (sign rel), (s,g) <- fsisa fSpec
-           ]
-       fst4 (x,_,_,_) = x
-
-   -- | de functie genPAclause beschrijft de voornaamste mogelijkheden om een expressie delta' te verwerken in expr (met tOp'==Ins of tOp==Del)
-   -- TODO: Vind een wetenschappelijk artikel waar de hier beschreven transformatie uitputtend wordt behandeld.
-   -- TODO: Deze code is onvolledig en misschien zelfs fout....
-   genPAclause :: (Declaration->Bool)        -- ^True if a relation may be changed (i.e. is editable)
-                  -> InsDel                  -- ^the type of action: Insert or Delete
-                  -> Expression              -- ^the expression in which a delete or insert takes place
-                  -> Expression              -- ^the delta to be inserted or deleted
-                  -> [(Expression,[Rule])]   -- ^the motivation, consisting of the conjuncts (traced back to their rules) that are being restored by this code fragment.
-                  -> PAclause
-   genPAclause editAble tOp' expr1 delta1 motive = genPAcl delta1 tOp' expr1
-    where
-      testPA i l r ex
-       = if (source l,target r)/=(source ex,target ex)
-         then fatal i ("test with sign deltaX = ["++show (source l)++"*"++show (target r)++"],  and sign expr = "++show (sign ex)++":\ndeltaX = "++showADL (l.:.r)++"\nexpr = "++show ex)
-         else if source r/=target l
-         then fatal i ("test with source r = "++show (source r)++",  and target l = "++show (target l)++":\nl"++showSign (sign l)++" = "++showADL l++"\nr"++showSign (sign r)++" = "++showADL r++"\nexpr = "++show ex)
-         else id
-
-      genPAcl deltaX tOp expr =
-        case (tOp, expr) of
-          (_  , EEqu{})     -> Blk [(expr, nub [r |(_,rs)<-motive, r<-rs])]
-          (_  , EImp{})     -> Blk [(expr, nub [r |(_,rs)<-motive, r<-rs])]
-          (_ ,  EFlp x)     -> genPAcl (flp deltaX) tOp x
-          (_ ,  EBrk x)     -> genPAcl deltaX tOp x
-          (Ins, ECpl x)     -> genPAcl deltaX Del x
-          (Del, ECpl x)     -> genPAcl deltaX Ins x
-          (Ins, EUni{})     -> CHC [ genPAcl deltaX Ins f | f<-exprUni2list expr{-, not (f==expr1 && Ins/=tOp') -}] motive -- the filter prevents self compensating PA-clauses.
-          (Ins, EIsc{})     -> ALL [ genPAcl deltaX Ins f | f<-exprIsc2list expr ] motive
-          (Del, EUni{})     -> ALL [ genPAcl deltaX Del f | f<-exprUni2list expr {-, not (f==expr1 && Del/=tOp') -}] motive -- the filter prevents self compensating PA-clauses.
-          (Del, EIsc{})     -> CHC [ genPAcl deltaX Del f | f<-exprIsc2list expr ] motive
-          (Ins, EDif (l,r)) -> CHC [ genPAcl deltaX Ins l, genPAcl deltaX Del r ] motive
-          (Del, EDif (l,r)) -> CHC [ genPAcl deltaX Del l, genPAcl deltaX Ins r ] motive
-          (Ins, EDia (l,r)) -> CHC [ ALL [ genPAcl (testPA 986 (deltaX) (flp r)          l $ deltaX.:.flp r         ) Ins l
-                                         , genPAcl (testPA 987 (flp l) (deltaX)          r $ flp l.:.deltaX         ) Ins r] motive
-                                   , ALL [ genPAcl (testPA 988 (deltaX) (notCpl (flp r)) l $ deltaX.:.notCpl (flp r)) Del l
-                                         , genPAcl (testPA 989 (deltaX) (flp r)          l $ deltaX.:.flp r         ) Ins l] motive
-                                   , ALL [ genPAcl (testPA 990 (notCpl (flp l)) (deltaX) r $ notCpl (flp l).:.deltaX) Del r
-                                         , genPAcl (testPA 991 (flp l) (deltaX)          r $ flp l.:.deltaX         ) Ins r] motive
-                                   , ALL [ genPAcl (testPA 992 (deltaX) (notCpl (flp r)) l $ deltaX.:.notCpl (flp r)) Del l
-                                         , genPAcl (testPA 993 (notCpl (flp l)) (deltaX) r $ notCpl (flp l).:.deltaX) Del r] motive
-                                   ] motive
-          (Del, EDia (l,r)) -> GCH [ (Del, (testPA 995 (deltaX) (flp r)          l $ deltaX.:.flp r),          genPAcl (EMp1 "a" (source l).*.EMp1 "b" (target l)) tOp l)
-                                   , (Ins, (testPA 996 (deltaX) (flp (notCpl r)) l $ deltaX.:.flp (notCpl r)), genPAcl (EMp1 "a" (source l).*.EMp1 "b" (target l)) tOp l)
-                                   , (Del, (testPA 997 (flp l) (deltaX)          r $ flp l.:.deltaX),          genPAcl (EMp1 "a" (source r).*.EMp1 "b" (target r)) tOp r)
-                                   , (Ins, (testPA 998 (notCpl (flp l)) (deltaX) r $ notCpl (flp l).:.deltaX), genPAcl (EMp1 "a" (source r).*.EMp1 "b" (target r)) tOp r)
-                                   ] motive
-          (Ins, ERrs (l,r)) -> CHC [ genPAcl (testPA 1000 (notCpl r) (flp deltaX) l $ notCpl r.:.flp deltaX) Del l
-                                   , genPAcl (testPA 1001 (l) (deltaX)            r $ l.:.deltaX)            Ins r
-                                   ] motive
-          (Del, ERrs (l,r)) -> GCH [ (Ins, (testPA 1003 (notCpl r) (flp deltaX) l $ notCpl r.:.flp deltaX), genPAcl (EMp1 "a" (source l).*.EMp1 "b" (target l)) tOp l)
-                                   , (Del, (testPA 1004 (l) (deltaX)            r $ l.:.deltaX),            genPAcl (EMp1 "a" (source r).*.EMp1 "b" (target r)) tOp r)
-                                   ] motive
-          (Ins, ELrs (l,r)) -> CHC [ genPAcl (testPA 1006 (flp deltaX) (notCpl l) r $ flp deltaX.:.notCpl l) Del r
-                                   , genPAcl (testPA 1007 (deltaX) (r)            l $ deltaX.:.r           ) Ins l
-                                   ] motive
-          (Del, ELrs (l,r)) -> GCH [ (Ins, (testPA 1009 (flp deltaX) (notCpl l) r $ flp deltaX.:.notCpl l), genPAcl (EMp1 "a" (source r).*.EMp1 "b" (target r)) tOp r)
-                                   , (Del, (testPA 1010 (deltaX) (r)            l $ deltaX.:.r),            genPAcl (EMp1 "a" (source l).*.EMp1 "b" (target l)) tOp l)
-                                   ] motive
-          (Ins, ECps (l,r)) -> CHC [ GCH [ (Ins, (testPA 1012 (deltaX) (flp r) l $ deltaX.:.flp r), genPAcl (EMp1 "a" (source l).*.EMp1 "b" (target l)) tOp l)
-                                         , (Ins, (testPA 1013 (flp l) (deltaX) r $ flp l.:.deltaX), genPAcl (EMp1 "a" (source r).*.EMp1 "b" (target r)) tOp r)
-                                         ] motive
-                                   , New (source r) (\x->ALL [ genPAcl (deltaX.*.EMp1 x (target l)) Ins l
-                                                             , genPAcl (EMp1 x (source r).*.deltaX) Ins r] motive) motive
-                                   ] motive
-          (Del, ECps (l,r)) -> CHC [ genPAcl (testPA 1018 (deltaX) (flp r) l $ deltaX.:.flp r) Del l
-                                   , genPAcl (testPA 1019 (flp l) (deltaX) r $ flp l.:.deltaX) Del r
-                                   ] motive
-          (Ins, ERad (l,r)) -> CHC [ genPAcl (testPA 1021 (deltaX) (notCpl (flp r)) l $ deltaX.:.notCpl (flp r)) Ins l
-                                   , genPAcl (testPA 1022 (notCpl (flp l)) (deltaX) r $ notCpl (flp l).:.deltaX) Ins r
-                                   ] motive
-          (Del, ERad (l,r)) -> CHC [ GCH [ (Del, (testPA 1024 (deltaX) (flp r) l $ deltaX.:.flp r), genPAcl (EMp1 "a" (source l).*.EMp1 "b" (target l)) tOp l)
-                                         , (Del, (testPA 1025 (flp l) (deltaX) r $ flp l.:.deltaX), genPAcl (EMp1 "a" (source r).*.EMp1 "b" (target r)) tOp r)
-                                         ] motive
-                                   , New (source r) (\_->Nop motive) motive
-                                   ] motive
-          (Ins, EPrd (l,r)) -> ALL [ genPAcl (EDcV (Sign ONE (source deltaX)).:.deltaX) Ins (EDcV (Sign ONE (source r)).:.r)
-                                   , genPAcl (deltaX.:.EDcV (Sign (target deltaX) ONE)) Ins (l.:.EDcV (Sign (target l) ONE))
-                                   ] motive
-          (Del, EPrd (l,r)) -> ALL [ genPAcl (EDcV (Sign ONE (source deltaX)).:.deltaX) Del (EDcV (Sign ONE (source r)).:.r)
-                                   , genPAcl (deltaX.:.EDcV (Sign (target deltaX) ONE)) Del (l.:.EDcV (Sign (target l) ONE))
-                                   ] motive
-          (_  , EKl0 x )    -> genPAcl (deltaK0 deltaX tOp x) tOp x
-          (_  , EKl1 x )    -> genPAcl (deltaK1 deltaX tOp x) tOp x
-          (_  , EDcD d)     -> if editAble d then Do tOp d deltaX motive else Blk [(expr, nub [r |(_,rs)<-motive, r<-rs])]
-          (_  , EDcI c)     -> if editAble (Isn c) then Do tOp (Isn c) deltaX motive else Blk [(expr, nub [r |(_,rs)<-motive, r<-rs])]
-          (_  , EDcV{})     -> Blk [(expr, nub [r |(_,rs)<-motive, r<-rs])]
-          (_  , EMp1{})     -> Blk [(expr, nub [r |(_,rs)<-motive, r<-rs])]
-          (_  , EEps{})     -> Nop [(expr, nub [r |(_,rs)<-motive, r<-rs])]
-
-{-        (_ , _)           -> fatal 767 ( "(Stef?) Non-exhaustive patterns in the recursive call\n"
-                                       ++"doCod ("++showADL deltaX++") -- deltaX\n      "++show tOp++"  -- tOp\n      ("++showADL expr++") -- expr\n"++
-                                         "within function\ndoCode "++show tOp'++"  -- tOp'\n       ("++showADL expr1++") -- expr1\n       ("++showADL delta1++") -- delta1\n"++
-                                         concat
-                                         [ "while trying to maintain conjunct "++showADL conjunct++
-                                           "\nfrom rule "++intercalate "\n          " [show r | r<-rs]
-                                         | (conjunct,rs)<-motive ] ++
-                                         if null motive then "null motive" else ""
-                                         )
--}
-
-      deltaK0 :: t -> InsDel -> t1 -> t
-      deltaK0 delta' Ins _ = delta'  -- error! (tijdelijk... moet berekenen welke paren in x gezet moeten worden zodat delta |- x*)
-      deltaK0 delta' Del _ = delta'  -- error! (tijdelijk... moet berekenen welke paren uit x verwijderd moeten worden zodat delta/\x* leeg is)
-      deltaK1 :: t -> InsDel -> t1 -> t
-      deltaK1 delta' Ins _ = delta'  -- error! (tijdelijk... moet berekenen welke paren in x gezet moeten worden zodat delta |- x+)
-      deltaK1 delta' Del _ = delta'  -- error! (tijdelijk... moet berekenen welke paren uit x verwijderd moeten worden zodat delta/\x+ leeg is)
-

− src/lib/DatabaseDesign/Ampersand/Fspec/ToFspec/NormalForms.hs 
@@ -1,471 +0,0 @@-{-# OPTIONS_GHC -Wall #-}
-module DatabaseDesign.Ampersand.Fspec.ToFspec.NormalForms
-  (delta,conjNF,disjNF,normPA,nfProof,cfProof,dfProof,proofPA,simplify)
-where
-   import DatabaseDesign.Ampersand.Basics
-   import DatabaseDesign.Ampersand.ADL1.ECArule
-   import DatabaseDesign.Ampersand.Classes.Relational 
-   import DatabaseDesign.Ampersand.ADL1.Expression 
-   import DatabaseDesign.Ampersand.Core.AbstractSyntaxTree
-   import DatabaseDesign.Ampersand.Fspec.Fspec
-   import DatabaseDesign.Ampersand.Fspec.ShowADL  -- for debug purposes only
-   import Data.List (nub {- , intercalate -} )
---   import Debug.Trace
-   import Prelude hiding (head)
-   
-   fatal :: Int -> String -> a
-   fatal = fatalMsg "Fspec.ToFspec.NormalForms"
-
-   head :: [a] -> a
-   head [] = fatal 30 "head must not be used on an empty list!"
-   head (a:_) = a
-
-   -- | This delta is meant to be used as a placeholder for inserting or removing links from expressions.
-   delta :: Sign -> Expression
-   delta sgn
-    = EDcD   Sgn { decnm   = "Delta"
-                 , decsgn  = sgn
-                 , decprps = []
-                 , decprps_calc = Nothing
-                 , decprL  = ""
-                 , decprM  = ""
-                 , decprR  = ""
-                 , decMean = AMeaning [ --   A_Markup Dutch   ReST (string2Blocks ReST "Delta is bedoeld als variabele, die de plaats in een expressie vasthoudt waar paren worden ingevoegd of verwijderd.")
-                                        -- , A_Markup English ReST (string2Blocks ReST "Delta is meant as a variable, to be used as a placeholder for inserting or removing links from expressions.")
-                                      ]
-                 , decfpos = Origin ("generated relation (Delta "++show sgn++")")
-                 , deciss  = True
-                 , decusr  = False
-                 , decpat  = ""
-                 , decplug = True
-                 } 
-
-{- Normalization of process algebra clauses -}
-
-   normPA :: PAclause -> PAclause
-   normPA pac = pac' 
-       where (pac',_,_) = if null (proofPA pac) then fatal 21 "last: empty list" else last (proofPA pac)
-
-   type Proof a = [(a, [String], String)]
-
-   proofPA :: PAclause -> Proof PAclause
-   proofPA = {-reverse.take 3.reverse.-}pPA
-    where pPA pac' = case normstepPA pac' of
-                       ( _ , []  ,equ) -> [(pac',[]   ,equ)]    -- is dus (pac,[],"<=>")
-                       (res,steps,equ) -> (pac',steps,equ):pPA res
-
-{- The following rewriter is used to simplify the actions inside eca rules.
--- WHY? Stef, kan je uitleggen wat hier gebeurt? Enig commentaar is hier wel op zijn plaats.
--- Ook zou het helpen om bij de verschillende constructoren van PAclause een beschrijving te geven van het idee er achter. 
--- BECAUSE! Kan ik wel uitleggen, maar het is een heel verhaal. Dat moet tzt in een wetenschappelijk artikel gebeuren, zodat het er goed staat.
--- Het idee is dat een procesalgebra is weergegeven in Haskell combinatoren (gedefinieerd als PAclause(..), zie ADL.ECArule).
--- Die kun je vervolgens normaliseren met herschrijfregels op basis van gelijkheden die gelden in de bewuste procesalgebra.
--- Helaas zijn de herschrijfregels nu nog hard gecodeerd, zodat ik voor PAclause een afzonderlijke Haskell functie moet schrijven.
--- Hierna volgt de normalisator voor relatiealgebra-expressies, genaamd normStep. Die heeft dezelfde structuur,
--- maar gebruikt herschrijfregels vanuit gelijkheden die gelden in relatiealgebra.
--}
-   normstepPA :: PAclause -> (PAclause,[String],String)
-   normstepPA pac = (res,ss,"<=>")
-    where
-     (res,ss) = norm pac
-     norm :: PAclause -> (PAclause,[String])
-     norm (CHC [] ms)  = (Blk ms, ["Run out of options"])
-     norm (CHC [r] ms) = (r', ["Flatten ONE"])
-                       where r' = case r of
-                                    Blk{} -> r
-                                    _     -> r{paMotiv = ms} 
-     norm (CHC ds ms)  | (not.null) msgs = (CHC ops ms, msgs)
-                       | (not.null) [d | d<-ds, isCHC d] = (CHC (nub [ d' | d<-ds, d'<-if isCHC d then let CHC ops' _ = d in ops' else [d] ]) ms, ["flatten CHC"])  -- flatten
-                       | (not.null) [Nop | Nop{}<-ops] = (Nop{paMotiv=ms}, ["Choose to do nothing"])
-                       | (not.null) [Blk | Blk{}<-ops] = (CHC [op | op<-ops, not (isBlk op)] ms, ["Choose anything but block"])
-                       | (not.null) doubles = (CHC [ head cl | cl<-eqClass (==) ds ] ms, ["remove double occurrences"])
-                       | otherwise = (CHC ds ms, [])
-                       where nds  = map norm ds
-                             msgs = concatMap snd nds
-                             ops  = map fst nds
-                             doubles = [ d | cl<-eqClass (==) ds, length cl>1, d<-cl ]
-     norm (GCH [] ms)  = (Blk ms, ["Run out of options"])
-     norm (GCH ds ms)  | (not.null) [() | (_,links,_)<-normds, isFalse links] = (GCH [(tOp,links,p) | (tOp,links,p)<-normds, not (isFalse links)] ms, ["Remove provably empty guard(s)."])
-                       | (not.null) [()          | (_,  _    ,p)<-normds, isNop p]
-                           = (GCH [(tOp,links,p) | (tOp,links,p)<-normds, not (isNop p)] ms, ["Remove unneccessary SELECT."])
-                       | (not.null) doubles = (GCH [ (fst3 (head cl), foldr1 (.\/.) (map snd3 cl), thd3 (head cl)) | cl<-eqCl (\(tOp,_,p)->(tOp,p)) ds ] ms, ["remove double occurrences"])
-                       | otherwise = (GCH ds ms, [])
-                       where normds = [ (tOp, conjNF links, let (p',_)=norm p in p') | (tOp,links,p)<-ds]
-                             doubles = [ d | cl<-eqCl (\(tOp,_,p)->(tOp,p)) ds, length cl>1, d<-cl ]
-     norm (ALL [] ms)  = (Nop ms, ["ALL [] = No Operation"])
-     norm (ALL [d] ms) = (d', ["Flatten ONE"])
-                       where d' = case d of
-                                    Blk{} -> d
-                                    _     -> d{paMotiv = ms} 
-     norm (ALL ds ms)  | (not.null) msgs = (ALL ops ms, msgs)
-                       | (not.null) [d | d<-ds, isAll d] = (ALL (nub [ d' | d<-ds, d'<-if isAll d then let ALL ops' _ = d in ops' else [d] ]) ms, ["flatten ALL"])  -- flatten
-                       | (not.null) [Blk | Blk{}<-ops] = (Blk{paMotiv = [m | op@Blk{}<-ops,m<-paMotiv op]}, ["Block all"])
-                       | (not.null) [Nop | Nop{}<-ops] = (ALL [op | op<-ops, not (isNop op)] ms, ["Ignore Nop"])
-                       | (not.null) doubles = (CHC [ head cl | cl<-eqClass (==) ds ] ms, ["remove double occurrences"])
-                       | (not.null) long    = (ALL ds' ms, ["Take the expressions for "++commaEng "and" [name (paTo (head cl)) |cl<-long]++"together"])
-                       | otherwise = (ALL ds ms, [])
-                       where ds'     = [ let p=head cl in
-                                           if length cl==1 then p else p{paDelta=disjNF (foldr1 (.\/.) [paDelta c | c<-cl]), paMotiv=concatMap paMotiv cl}
-                                       | cl<-dCls {- not (null cl) is guaranteed by eqCl -} ]
-                                       ++[d | d<-ds, not (isDo d)]
-                             nds     = map norm ds
-                             msgs    = concatMap snd nds
-                             ops     = map fst nds
-                             doubles = [ d | cl<-eqClass (==) ds, length cl>1, d<-cl ]
-                             dCls :: [[PAclause]]
-                             dCls = eqCl to [d | d<-ds, isDo d]
-                             long :: [[PAclause]]
-                             long = [cl | cl<-dCls, length cl>1]
-                             to d = case d of 
-                                      Do{} -> (paSrt d, paTo d)
-                                      _    -> fatal 74 "illegal call of to(d)"
-     norm (New c p ms)        = ( case p' of
-                                   Blk{} -> p'{paMotiv = ms}
-                                   _     -> New c (\x->let (p'', _) = norm (p x) in p'') ms
-                                , msgs)
-                                where (p', msgs) = norm (p "x")
-     norm (Rmv c p ms)        = ( case p' of
-                                   Blk{} -> p'{paMotiv = ms}
-                                   _     -> Rmv c (\x->let (p'', _) = norm (p x) in p'') ms
-                                , msgs)
-                                where (p', msgs) = norm (p "x")
-     norm p                   = (p, [])
-
-
-{- Normalization of expressions -}
-
-   simplify :: Expression -> Expression
-   simplify expr = expr' 
-       where (expr',_,_) = if null (simpProof shw expr) then fatal 101 "last: empty list" else last (simpProof shw expr)
-             shw _ = ""
-   
-   simpProof :: (Expression -> String) -> Expression -> Proof Expression
-   simpProof shw expr    
-    = if expr==res
-      then [(expr,[],"<=>")]
-      else (expr,steps,equ):simpProof shw res
-    where (res,steps,equ) = normStep shw True True True expr
-
-
-   -- | The purpose of "normStep" is to elaborate a single step in a rewrite process,
-   -- in which the expression is normalized by means of rewrite rules.
-   -- This function can be used for simplification, which means that an Expression is standardized
-   -- using associativity and other 'trivial' rules only.
-   -- These 'trivial' rules do not produce a step in the proof.
-   -- Use normstep shw eq True expr to do simplification only.
-   -- Use normstep shw eq False expr to obtain a single proof step or none when no rule is applicable.
-   -- This function returns a resulting expression that is closer to a normal form.
-   -- The normal form is not unique. This function simply uses the first rewrite rule it encounters.
-   normStep :: (Expression -> String) -> Bool -> Bool -> Bool ->
-               Expression -> (Expression,[String],String) -- This might be generalized to "Expression" if it weren't for the fact that flip is embedded in the Relation type.
-   normStep shw   -- a function to print an expression. Might be "showADL"
-            eq    -- If eq==True, only equivalences are used. Otherwise, implications are used as well.
-            dnf   -- If dnf==True, the result is in disjunctive normal form, otherwise in conjunctive normal form
-            simpl -- If True, only simplification rules are used, which is a subset of all rules. Consequently, simplification is implied by normalization.
-            expr = (res,ss,equ)
-    where
-     (res,ss,equ) = nM True expr []
-     nM :: Bool -> Expression -> [Expression] -> (Expression,[String],String)
--- posCpl indicates whether the expression is positive under a complement. It is False when expr is inside a complemented expression.
-     nM posCpl (EEqu (l,r)) _     | simpl = (t .==. f, steps++steps', fEqu [equ',equ''])
-                                            where (t,steps, equ')  = nM posCpl l []  -- TODO: the use of posCpl is erroneous
-                                                  (f,steps',equ'') = nM posCpl r []  -- TODO: the use of posCpl is erroneous
-     nM posCpl (EImp (l,r)) _     | simpl = (t .|-. f, steps++steps', fEqu [equ',equ''])
-                                            where (t,steps, equ')  = nM (not posCpl) l []
-                                                  (f,steps',equ'') = nM posCpl r []
-     nM posCpl (EUni (EUni (l,k),r)) rs   = nM posCpl (l .\/. (k .\/. r)) rs  -- standardize, using associativity of .\/.
-     nM posCpl (EUni (l,r)) rs    | simpl = (t .\/. f, steps++steps', fEqu [equ',equ''])
-                                            where (t,steps, equ')  = nM posCpl l []
-                                                  (f,steps',equ'') = nM posCpl r (l:rs)
-     nM posCpl (EIsc (EIsc (l,k),r)) rs   = nM posCpl (l ./\. (k ./\. r)) rs  -- standardize, using associativity of ./\.
-     nM posCpl (EIsc (l,r)) rs    | simpl = (t ./\. f, steps++steps', fEqu [equ',equ''])
-                                            where (t,steps, equ')  = nM posCpl l []
-                                                  (f,steps',equ'') = nM posCpl r (l:rs)
-     nM posCpl (ECps (ECps (l,k),r)) rs   = nM posCpl (l .:. (k .:. r)) rs  -- standardize, using associativity of .:. 
-                                                -- Note: function shiftL and shiftR make use of the fact that this normalizes to (l .:. (k .:. r))
-     nM posCpl (ECps (l,r)) rs    | simpl = (t .:. f, steps++steps', fEqu [equ',equ''])
-                                             where (t,steps, equ')  = nM posCpl l []
-                                                   (f,steps',equ'') = nM posCpl r (l:rs)
-     nM posCpl (ELrs (l,r)) _     | simpl = (t ./. f, steps++steps', fEqu [equ',equ''])
-                                            where (t,steps, equ')  = nM posCpl l []
-                                                  (f,steps',equ'') = nM (not posCpl) r []
-     nM posCpl (ERrs (l,r)) _     | simpl = (t .\. f, steps++steps', fEqu [equ',equ''])
-                                            where (t,steps, equ')  = nM (not posCpl) l []
-                                                  (f,steps',equ'') = nM posCpl r []
-     nM posCpl (EDia (l,r)) _     | simpl = (t .<>. f, steps++steps', fEqu [equ',equ''])
-                                            where (t,steps, equ')  = nM posCpl l []  -- TODO: the use of posCpl is erroneous
-                                                  (f,steps',equ'') = nM posCpl r []  -- TODO: the use of posCpl is erroneous
-     nM posCpl (ERad (ERad (l,k),r)) rs   = nM posCpl (l .!. (k .!. r)) rs  -- standardize, using associativity of .!.
-     nM posCpl (ERad (l,r)) rs    | simpl = (t .!. f, steps++steps', fEqu [equ',equ''])
-                                            where (t,steps, equ')    = nM posCpl l []
-                                                  (f,steps',equ'')   = nM posCpl r (l:rs)
-     nM posCpl (EPrd (EPrd (l,k),r)) rs   = nM posCpl (l .*. (k .*. r)) rs  -- standardize, using associativity of .*.
-     nM posCpl (EPrd (l,r)) _     | simpl = (t .*. f, steps++steps', fEqu [equ',equ''])
-                                            where (t,steps, equ')  = nM posCpl l []
-                                                  (f,steps',equ'') = nM posCpl r []
-     nM posCpl (EKl0 e)              _    = (EKl0 res', steps, equ')
-                                            where (res',steps,equ') = nM posCpl e []
-     nM posCpl (EKl1 e)              _    = (EKl1 res', steps, equ')
-                                            where (res',steps,equ') = nM posCpl e []
-     nM posCpl (ECpl (ECpl e))         rs = nM posCpl e rs
-     nM posCpl (ECpl e) _         | simpl = (notCpl res',steps,equ')
-                                            where (res',steps,equ') = nM (not posCpl) e []
-     nM posCpl (EBrk e)                _  = nM posCpl e []
-     nM posCpl (EFlp (ECpl e))         rs = nM posCpl (notCpl (flp e)) rs
-     nM _      x _                | simpl = (x,[],"<=>")
--- up to here, simplification has been treated. The remaining rules can safely assume  simpl==False
-     nM _      (EEqu (l,r)) _                            = ((l .|-. r) ./\. (r .|-. l), ["remove ="],"<=>")
-     nM _      (EImp (x,ELrs (z,y))) _                   = (x .:. y .|-. z, ["remove left residual (/)"],"<=>")
-     nM _      (EImp (y,ERrs (x,z))) _                   = (x .:. y .|-. z, ["remove right residual (\\)"],"<=>")
-     nM _      (EImp (l,r)) _                            = (notCpl l .\/. r, ["remove |-"],"<=>")
---   nM posCpl e@(ECpl EIsc{}) _           | posCpl==dnf = (deMorganEIsc e, ["De Morgan"], "<=>")
---   nM posCpl e@(ECpl EUni{}) _           | posCpl/=dnf = (deMorganEUni e, ["De Morgan"], "<=>")
-     nM _      e@(ECpl EIsc{}) _                         = (deMorganEIsc e, ["De Morgan"], "<=>")
-     nM _      e@(ECpl EUni{}) _                         = (deMorganEUni e, ["De Morgan"], "<=>")
-     nM _      e@(ECpl (ERad (_,ECpl{}))) _              = (deMorganERad e, ["De Morgan"], "<=>")
-     nM _      e@(ECpl (ERad (ECpl{},_))) _              = (deMorganERad e, ["De Morgan"], "<=>")
-     nM _      e@(ECpl (ECps (ECpl{},ECpl{}))) _         = (deMorganECps e, ["De Morgan"], "<=>")
-     nM posCpl (ECpl e) _                                = (notCpl res',steps,equ')
-                                                           where (res',steps,equ') = nM (not posCpl) e []
-     nM _      (ECps (EEps c (Sign s _),EEps c' (Sign _  t'))) _ | c ==c' = (EEps c  (Sign s t'), [], "<=>")
-     nM _      (ECps (EEps c (Sign s t),EEps c' (Sign _  t'))) _ | c ==t  = (EEps c' (Sign s t'), [], "<=>")
-     nM _      (ECps (EEps c (Sign s _),EEps c' (Sign s' t'))) _ | s'==c' = (EEps c  (Sign s t'), [], "<=>")
-     nM _      (ECps (EEps c (Sign s _),ECps(EEps c' (Sign _  t'),r))) _ | c ==c' = (ECps (EEps c  (Sign s t'),r), [], "<=>")
-     nM _      (ECps (EEps c (Sign s t),ECps(EEps c' (Sign _  t'),r))) _ | c ==t  = (ECps (EEps c' (Sign s t'),r), [], "<=>")
-     nM _      (ECps (EEps c (Sign s _),ECps(EEps c' (Sign s' t'),r))) _ | s'==c' = (ECps (EEps c  (Sign s t'),r), [], "<=>")
-     nM _      (ECps (ERrs (x,e),y)) _ | not eq && isIdent e = (ERrs (x,y), ["Jipsen&Tsinakis: (x\\I);y |- x\\y"], "==>")
-     nM _      (ECps (x,ELrs (e,y))) _ | not eq && isIdent e = (ELrs (x,y), ["Jipsen&Tsinakis: x;(I/y) |- x/y"], "==>")
-     nM _      (ECps (ERrs (x,y),z)) _          | not eq = (ERrs (x,ECps (y,z)), ["Jipsen&Tsinakis: (x\\y);z |- x\\(y;z)"], "==>")
-     nM _      (ECps (x,ELrs (y,z))) _          | not eq = (ERrs (x,ECps (y,z)), ["Jipsen&Tsinakis: x;(y/z) |- (x;y)/z"], "==>")
-     nM _      (ECps (ERrs (x,y),ERrs (y',z))) _ | not eq && y==y' = (ERrs (x,z), ["Jipsen&Tsinakis: (x\\y);(y\\z) |- x\\z"], "==>")
-     nM _      (ECps (ELrs (x,y),ELrs (y',z))) _ | not eq && y==y' = (ERrs (x,z), ["Jipsen&Tsinakis: (x/y);(y/z) |- x/z"], "==>")
-     nM _      (ECps (ERrs (x,y),ERrs (y',z))) _ | y==y' && x==y && x==z = (ERrs (x,z), ["Jipsen&Tsinakis: (x\\x);(x\\x) = x\\x"], "<=>")
-     nM _      (ECps (ELrs (x,y),ELrs (y',z))) _ | y==y' && x==y && x==z = (ERrs (x,z), ["Jipsen&Tsinakis: (x/x);(x/x) = x/x"], "<=>")
-     nM _      (ECps (x,ERrs (y,z))) _    | x==y && x==z = (x, ["Jipsen&Tsinakis: x;(x\\x) = x"], "<=>")
-     nM _      (ECps (ELrs (x,y),z)) _    | x==z && y==z = (x, ["Jipsen&Tsinakis: (x/x);x = x"], "<=>")
-     nM _      (ECps (l,r)) _                | isIdent l = (r, ["I;x = x"], "<=>")
-     nM _      (ECps (l,r)) _                | isIdent r = (l, ["x;I = x"], "<=>")
-     nM True   (ECps (r,ERad (s,q))) _          | not eq = ((r.:.s).!.q, ["Peirce: r;(s!q) |- (r;s)!q"],"==>")
-     nM True   (ECps (ERad (r,s),q)) _          | not eq = (r.!.(s.:.q), ["Peirce: (r!s);q |- r!(s;q)"],"==>")
-     nM True   (ECps (EIsc (r,s),q)) _          | not eq = ((r.:.q)./\.(s.:.q), ["distribute ; over /\\"],"==>")
-     nM True   (ECps (r,EIsc (s,q))) _          | not eq = ((r.:.s)./\.(r.:.q), ["distribute ; over /\\"],"==>")
-     nM _      (ECps (EUni (q,s),r)) _                   = ((q.:.r).\/.(s.:.r), ["distribute ; over \\/"],"<=>")
-     nM _      (ECps (l,EUni (q,s))) _                   = ((l.:.q).\/.(l.:.s), ["distribute ; over \\/"],"<=>")
-     nM _      x@(ECps (l@EFlp{},r)) _ | not eq && flp l==r && isInj l   = (EDcI (source x), ["r~;r |- I (r is univalent)"], "==>")
-     nM _      x@(ECps (l,       r)) _ | not eq && l==flp r && isInj l   = (EDcI (source x), ["r;r~ |- I (r is injective)"], "==>")
-     nM _      x@(ECps (l@EFlp{},r)) _ | flp l==r && isInj l && isTot l  = (EDcI (source x), ["r~;r=I because r is univalent and surjective"], "<=>")
-     nM _      x@(ECps (l,       r)) _ | l==flp r && isInj l && isTot l  = (EDcI (source x), ["r;r~=I because r is injective and total"], "<=>")
-     nM posCpl (ECps (l,r))           rs                   = (t .:. f, steps++steps', fEqu [equ',equ''])
-                                                               where (t,steps, equ')  = nM posCpl l []
-                                                                     (f,steps',equ'') = nM posCpl r (l:rs)
-     nM _      x@(EEps i sgn) _ | source sgn==i && i==target sgn = (EDcI i, ["source and target are equal to "++name i++", so "++showADL x++"="++showADL (EDcI i)], "<=>")
-     nM _      (ELrs (ECps (x,y),z)) _ | not eq && y==z    = (x,     ["(x;y)/y |- x"], "==>")
-     nM _      (ELrs (ECps (x,y),z)) _ | not eq && flp x==z= (flp y, [case (x, y) of
-                                                                           (EFlp _, EFlp _) -> "(SJ) (x~;y~)/x |- y"
-                                                                           (     _, EFlp _) -> "(SJ) (x;y~)/x~ |- y"
-                                                                           (EFlp _,      _) -> "(SJ) (x~;y)/x |- y~"
-                                                                           (     _,      _) -> "(SJ) (x;y)/x~ |- y~"], "==>")
-     nM _      (ELrs (ELrs (x,z),y)) _                     = (ELrs (x,ECps (y,z)), ["Jipsen&Tsinakis: x/yz = (x/z)/y"], "<=>")
-     nM posCpl (ELrs (l,r)) _                              = (t ./. f, steps++steps', fEqu [equ',equ''])
-                                                             where (t,steps, equ')  = nM posCpl l []
-                                                                   (f,steps',equ'') = nM (not posCpl) r []
-     nM _      (ERrs (y,ERrs (x,z))) _                     = (ERrs (ECps (x,y),z), ["Jipsen&Tsinakis: xy\\z = y\\(x\\z)"], "<=>")
-     nM _      (ERrs (x,ECps (y,z))) _ | not eq && x==y    = (z,     ["x\\(x;y) |- y"], "==>")
-     nM posCpl (ERrs (l,r)) _                              = (t .\. f, steps++steps', fEqu [equ',equ''])
-                                                             where (t,steps, equ')  = nM (not posCpl) l []
-                                                                   (f,steps',equ'') = nM posCpl r []
-     nM posCpl (EDia (l,r)) _                              = (t .<>. f, steps++steps', fEqu [equ',equ''])
-                                                             where (t,steps, equ')  = nM posCpl l []
-                                                                   (f,steps',equ'') = nM posCpl r []
-     nM _      (ERad (l,r)) _                   | isImin l = (r, ["-I!x = x"], "<=>")
-     nM _      (ERad (l,r)) _                   | isImin r = (l, ["x!-I = x"], "<=>")
---     nM False  (ERad (ECps (r,s),q)) _            | not eq = (r.:.(s.!.q), ["Peirce: (r;s)!q |- r;(s!q)"],"==>")  -- SJ 20131124 TODO: check this rule. It is wrong!
---     nM False  (ERad (r,ECps (s,q))) _            | not eq = ((r.!.s).:.q, ["Peirce: (r!s);q |- r!(s;q)"],"==>")  -- SJ 20131124 TODO: check this rule. It is wrong!
-     nM False  (ERad (EUni (r,s),q)) _            | not eq = ((r.!.q).\/.(s.!.q), ["distribute ! over \\/"],"==>")
-     nM False  (ERad (r,EUni (s,q))) _            | not eq = ((r.!.s).\/.(r.!.q), ["distribute ! over \\/"],"==>")
-     nM _      (ERad (EIsc (q,s),r)) _                     = ((q.!.r)./\.(s.!.r), ["distribute ! over /\\"],"<=>")
-     nM _      (ERad (l,EIsc (q,s))) _                     = ((l.!.q)./\.(l.!.s), ["distribute ! over /\\"],"<=>")
-     nM _      (ERad(ECpl l,r))      _                     = (flp l .\. r, [case l of EFlp{} -> "-l~!r = l\\r"; _ -> "-l!r = l~\\r"], "<=>")
-     nM _      (ERad(l,ECpl r))      _                     = (l ./. flp r, [case r of EFlp{} -> "l!-r~ = l/r"; _ -> "l!-r = l/r~"], "<=>")
-     nM posCpl (ERad (l,r))         rs                     = (t .!. f, steps++steps', fEqu [equ',equ''])
-                                                                 where (t,steps, equ')  = nM posCpl l []
-                                                                       (f,steps',equ'') = nM posCpl r (l:rs)
-     nM _      (EPrd (l,EPrd (_,r))) _                     = (l .*. r, ["eliminate middle in cartesian product"], "<=>")
-     nM posCpl (EPrd (l,r)) _                              = (t .*. f, steps++steps', fEqu [equ',equ''])
-                                                                 where (t,steps, equ')  = nM posCpl l []
-                                                                       (f,steps',equ'') = nM posCpl r []
-     nM posCpl (EIsc (EUni (l,k),r)) _       | posCpl==dnf = ((l./\.r) .\/. (k./\.r), ["distribute /\\ over \\/"],"<=>")
-     nM posCpl (EIsc (l,EUni (k,r))) _       | posCpl==dnf = ((l./\.k) .\/. (l./\.r), ["distribute /\\ over \\/"],"<=>")
-     nM posCpl x@(EIsc (l,r)) rs
--- Absorb equals:    r/\r  -->  r
-         | or [length cl>1 |cl<-absorbClasses]
-              = ( case absorbClasses of [] -> fatal 243 "Going into foldr1 with empty absorbClasses"; _ -> foldr1 (./\.) [head cl | cl<-absorbClasses]
-                , [shw e++" /\\ "++shw e++" = "++shw e | cl<-absorbClasses, length cl>1, let e=head cl]
-                , "<=>"
-                )
--- Absorb True:    r/\V  --> r
-         | isTrue l                      = (r, ["V/\\x = x"], "<=>")
-         | isTrue r                      = (l, ["x/\\V = x"], "<=>")
--- Inconsistency:    r/\-r   -->  False
-         | not (null incons)
-              = let i = head incons in (notCpl (EDcV (sign i)), [shw (notCpl i)++" /\\ "++shw i++" = V-"], "<=>")
--- Inconsistency:    x/\\V-  -->  False
-         | isFalse l                     = (notCpl (EDcV (sign x)), ["-V/\\x = -V"], "<=>")
-         | isFalse r                     = (notCpl (EDcV (sign x)), ["x/\\-V = -V"], "<=>")
--- Absorb if r is antisymmetric:    r/\r~ --> I
-         | not eq && or [length cl>1 |cl<-absorbAsy]
-              = ( foldr1 (./\.) [if length cl>1 then EDcI (source e) else e | cl<-absorbAsy, let e=head cl] 
-                , [shw e++" /\\ "++shw (flp e)++" |- I, because"++shw e++" is antisymmetric" | cl<-absorbAsy, let e=head cl]
-                , "==>"
-                )
--- Absorb if r is antisymmetric and reflexive:    r/\r~ = I
-         | or [length cl>1 |cl<-absorbAsyRfx]
-              = ( foldr1 (./\.) [if length cl>1 then EDcI (source e) else e | cl<-absorbAsyRfx, let e=head cl] 
-                , [shw e++" /\\ "++shw (flp e)++" = I, because"++shw e++" is antisymmetric and reflexive" | cl<-absorbAsyRfx, let e=head cl]
-                , "<=>"
-                )
--- Absorb:    (x\\/y)/\\y  =  y
-         | isEUni l && not (null absor0)
-              = let t'=head absor0  in (r, ["absorb "++shw l++" because of "++shw t'++", using law  (x\\/y)/\\y = y"], "<=>")
-         | isEUni r && not (null absor0')
-              = let t'=head absor0' in (r, ["absorb "++shw r++" because of "++shw t'++", using law  (x\\/y)/\\x = x"], "<=>")
--- Absorb:    (x\\/-y)/\\y  =  x/\\y
-         | isEUni l && not (null absor1)
-              = ( case head absor1 of
-                    (_,[]) -> r
-                    (_,ts) -> foldr1 (.\/.) ts ./\. r
-                , ["absorb "++shw t'++", using law (x\\/-y)/\\y  =  x/\\y" | (t',_)<-absor1]
-                , "<=>"
-                )
-         | isEUni r && not (null absor1')
-              = ( case head absor1' of
-                    (_,[]) -> l
-                    (_,ts) -> l ./\. foldr1 (.\/.) ts
-                , ["absorb "++shw t'++", using law x/\\(y\\/-x)  =  x/\\y" | (t',_)<-absor1']
-                , "<=>"
-                )
-         | otherwise = (t ./\. f, steps++steps', fEqu [equ',equ''])
-         where (t,steps, equ')  = nM posCpl l []
-               (f,steps',equ'') = nM posCpl r (l:rs)
-               absorbClasses = eqClass (==) (exprIsc2list l++exprIsc2list r)
-               incons = [conjunct |conjunct<-exprIsc2list r,conjunct==notCpl l]
-               absor0  = [disjunct | disjunct<-exprUni2list l, f'<-rs++exprIsc2list r, disjunct==f']
-               absor0' = [disjunct | disjunct<-exprUni2list r, f'<-rs++exprIsc2list l, disjunct==f']
-               absor1  = [(disjunct, exprUni2list l>-[disjunct]) | disjunct<-exprUni2list l, ECpl f'<-rs++exprIsc2list r, disjunct==f']++
-                         [(disjunct, exprUni2list l>-[disjunct]) | disjunct@(ECpl t')<-exprUni2list l, f'<-rs++exprIsc2list r, t'==f']
-               absor1' = [(disjunct, exprUni2list r>-[disjunct]) | disjunct<-exprUni2list r, ECpl f'<-rs++exprIsc2list l, disjunct==f']++
-                         [(disjunct, exprUni2list r>-[disjunct]) | disjunct@(ECpl t')<-exprUni2list r, f'<-rs++exprIsc2list l, t'==f']
-               absorbAsy = eqClass same eList where e `same` e' = isAsy e && isAsy e' && e == flp e'
-               absorbAsyRfx = eqClass same eList where e `same` e' = isRfx e && isAsy e && isRfx e' && isAsy e' && e == flp e'
-               eList  = rs++exprIsc2list l++exprIsc2list r
-     nM posCpl (EUni (EIsc (l,k),r)) _  | posCpl/=dnf = ((l.\/.r) ./\. (k.\/.r), ["distribute \\/ over /\\"],"<=>")
-     nM posCpl (EUni (l,EIsc (k,r))) _  | posCpl/=dnf = ((l.\/.k) ./\. (l.\/.r), ["distribute \\/ over /\\"],"<=>")
-     nM posCpl x@(EUni (l,r)) rs
--- Absorb equals:    r\/r  -->  r
-         | or [length cl>1 |cl<-absorbClasses]   -- yields False if absorbClasses is empty
-              = ( foldr1 (.\/.) [head cl | cl<-absorbClasses]  -- cl cannot be empty, because it is made by eqClass
-                , [shw e++" \\/ "++shw e++" = "++shw e | cl<-absorbClasses, length cl>1, let e=head cl]
-                , "<=>"
-                )
--- Tautologies:
-         | (not.null) tauts               = (EDcV (sign x), ["let e = "++ shw (head tauts)++". Since -e\\/e = V we get"], "<=>")   -- r\/-r  -->  V
-         | isTrue l                       = (EDcV (sign x), ["V\\/x = V"], "<=>")                                                  -- r\/V   -->  V
-         | isTrue r                       = (EDcV (sign x), ["x\\/V = V"], "<=>")
--- Absorb -V:    r\/-V  --> r
-         | isFalse l                      = (r, ["-V\\/x = x"], "<=>")
-         | isFalse r                      = (l, ["x\\/-V = x"], "<=>")
--- Absorb:    (x/\\y)\\/y  =  y
-         | isEIsc l && not (null absor0)  = let t'=head absor0  in (r, ["absorb "++shw l++" because of "++shw t'++", using law  (x/\\y)\\/y = y"], "<=>")
-         | isEIsc r && not (null absor0') = let t'=head absor0' in (r, ["absorb "++shw r++" because of "++shw t'++", using law  (x/\\y)\\/x = x"], "<=>")
--- Absorb:    (x/\\-y)\\/y  =  x\\/y
-         | isEIsc l && not (null absor1)
-              = ( case head absor1 of
-                    (_,[]) -> r
-                    (_,ts) -> foldr1 (./\.) ts .\/. r
-                , ["absorb "++shw t'++", using law (x/\\-y)\\/y  =  x\\/y" | (t',_)<-absor1]
-                , "<=>"
-                )
-         | isEIsc r && not (null absor1')
-              = ( case head absor1' of
-                    (_,[]) -> l
-                    (_,ts) -> l .\/. foldr1 (./\.) ts
-                , ["absorb "++shw t'++", using law x\\/(y/\\-x)  =  x\\/y" | (t',_)<-absor1' ]
-                , "<=>"
-                )
-         | otherwise = (t .\/. f, steps++steps', fEqu [equ',equ''])
-         where (t,steps, equ')  = nM posCpl l []
-               (f,steps',equ'') = nM posCpl r (l:rs)
-            -- absorption can take place if two terms are equal. So let us make a list of equal terms: absorbClasses (for substituting r\/r by r)
-               absorbClasses = eqClass (==) (exprUni2list l++exprUni2list r)
-            -- tautologies occur if -r\/r, so we are looking for pairs, (x,l) such that x== -l
-               tauts = [t' |disjunct<-exprUni2list r,disjunct==notCpl l, ECpl t'<-[disjunct,l]]
-               absor0  = [t' | t'<-exprIsc2list l, f'<-rs++exprUni2list r, t'==f']
-               absor0' = [t' | t'<-exprIsc2list r, f'<-rs++exprUni2list l, t'==f']
-               absor1  = [(t', exprIsc2list l>-[t']) | t'<-exprIsc2list l, ECpl f'<-rs++exprUni2list r, t'==f']++[(e, exprIsc2list l>-[e]) | e@(ECpl t')<-exprIsc2list l, f'<-rs++exprUni2list r, t'==f']
-               absor1' = [(t', exprIsc2list r>-[t']) | t'<-exprIsc2list r, ECpl f'<-rs++exprUni2list l, t'==f']++[(e, exprIsc2list r>-[e]) | e@(ECpl t')<-exprIsc2list r, f'<-rs++exprUni2list l, t'==f']
-     nM _ (EFlp e) _ | isSym e =  (e,[shw e++" is symmetric"],"<=>")
-     nM _ x _               = (x,[],"<=>")
-
-   fEqu :: [String] -> String
-   fEqu ss = if and [s=="<=>" | s<-ss] then "<=>" else "==>"
-
-   nfProof :: (Expression -> String) -> Expression -> Proof Expression
-   nfProof shw = nfPr shw True True -- The first boolean True means that clauses are derived using <=> derivations. The second True means that a disjunctive normal form is produced.
-   nfPr :: (Expression -> String) -> Bool -> Bool -> Expression -> [(Expression, [String], String)]
-   nfPr shw eq dnf expr
-    = {-if showADL expr=="r \\/ s"
-      then fatal 360 ("Diagnose expr: "++showADL expr++"\n"++
-                      "eq:            "++show eq++"\n"++
-                      "dnf:           "++show eq++"\n"++
-                      "res:           "++showADL res++"\n"++
-                      "expr==res:     "++show (expr==res)
-                     ) else-}
-      if expr==res
-      then [(expr,[],"<=>")]
-      else (expr,steps,equ):nfPr shw eq dnf (simplify res)
-    where (res,steps,equ) = normStep shw eq dnf False expr
-
-   cfProof :: (Expression -> String) -> Expression -> Proof Expression
-   cfProof shw expr
-    = [line | step, line<-init pr]++
-      [line | step', line<-init pr']++
-      [last ([(expr,[],"<=>")]++
-             [line | step, line<-pr]++
-             [line | step', line<-pr']
-            )]
-      where pr           = nfPr shw True False (simplify expr)
-            (expr',_,_)  = if null pr then fatal 328 "last: empty list" else last pr
-            step         = simplify expr/=expr' -- obsolete?    || and [null s | (_,ss,_)<-pr, s<-ss]
-            pr'          = nfPr shw True False (simplify expr')
-            step'        = simplify expr'/=simplify expr'' -- obsolete?    || and [null s | (_,ss,_)<-pr', s<-ss]
-            (expr'',_,_) = if null pr' then fatal 337 "last: empty list" else last pr'
-
-   conjNF :: Expression -> Expression
-   conjNF expr = e where (e,_,_) = if null (cfProof (\_->"") expr) then fatal 340 "last: empty list" else last (cfProof (\_->"") expr)
-
-   disjNF :: Expression -> Expression
-   disjNF expr = e where (e,_,_) = if null (dfProof (\_->"") expr) then fatal 343 "last: empty list" else last (dfProof (\_->"") expr)
-
-   dfProof :: (Expression -> String) -> Expression -> Proof Expression
-   dfProof shw expr
-    = [line | step, line<-init pr]++
-      [line | step', line<-init pr']++
-      [last ([(expr,[],"<=>")]++
-             [line | step, line<-pr]++
-             [line | step', line<-pr']
-            )]
-      where pr           = nfPr shw True True expr
-            (expr',_,_)  = if null pr then fatal 356 "last: empty list" else last pr
-            step         = simplify expr/=simplify expr'
-            pr'          = nfPr shw True True expr'
-            step'        = simplify expr'/=simplify expr''
-            (expr'',_,_) = if null pr' then fatal 365 "last: empty list" else last pr'
-
-   isEUni :: Expression -> Bool
-   isEUni EUni{}  = True
-   isEUni _       = False
-
-   isEIsc :: Expression -> Bool
-   isEIsc EIsc{}  = True
-   isEIsc _       = False
-

− src/lib/DatabaseDesign/Ampersand/Input.hs 
@@ -1,6 +0,0 @@-{-# OPTIONS_GHC -Wall #-}  
-module DatabaseDesign.Ampersand.Input (
-   module X
-)where
-import DatabaseDesign.Ampersand.Input.ADL1.CtxError as X (CtxError)
-import DatabaseDesign.Ampersand.Input.Parsing as X (parseADL1pExpr)
− src/lib/DatabaseDesign/Ampersand/Input/ADL1/CtxError.hs 
@@ -1,183 +0,0 @@-{-# OPTIONS_GHC -Wall -XFlexibleInstances #-}
-module DatabaseDesign.Ampersand.Input.ADL1.CtxError
-  ( CtxError(PE)
-  , showErr
-  , cannotDisamb, cannotDisambRel
-  , mustBeOrdered, mustBeOrderedLst, mustBeOrderedConcLst
-  , mustBeBound
-  , GetOneGuarded(..), uniqueNames
-  , Guarded(..)
-  , (<?>)
-  )
--- SJC: I consider it ill practice to export CTXE
--- Reason: CtxError should obtain all error messages
--- By not exporting anything that takes a string, we prevent other modules from containing error message
--- If you build a function that must generate an error, put it in CtxError and call it instead
--- see `getOneExactly' / `GetOneGuarded' as a nice example
--- Although I also consider it ill practice to export PE, I did this as a quick fix for the parse errors
-where
-import Control.Applicative
-import DatabaseDesign.Ampersand.ADL1 (Pos(..),source,target,sign,Expression(EDcV,ECpl),A_Concept,SubInterface)
-import DatabaseDesign.Ampersand.Fspec.ShowADL
-import DatabaseDesign.Ampersand.Basics
--- import Data.Traversable
-import Data.List  (intercalate)
-import GHC.Exts (groupWith)
-import DatabaseDesign.Ampersand.Input.ADL1.UU_Scanner (Token)
-import DatabaseDesign.Ampersand.Input.ADL1.UU_Parsing (Message)
-import DatabaseDesign.Ampersand.Core.ParseTree (TermPrim(..),P_ViewD(..),P_SubIfc,Traced(..), Origin(..), SrcOrTgt(..),FilePos(..))
-import DatabaseDesign.Ampersand.Core.AbstractSyntaxTree (Declaration,Association)
-
-fatal,_notUsed :: Int -> String -> a
-fatal = fatalMsg "Input.ADL1.CtxError"
-_notUsed = fatal
-
-infixl 4 <?>
-(<?>) :: (t -> Guarded a) -> Guarded t -> Guarded a  -- This is roughly the monadic definition for >>=, but it does not satisfy the corresponding rules so it cannot be a monad
-(<?>) _ (Errors  a) = Errors a -- note the type change
-(<?>) f (Checked a) = f a
-
-data CtxError = CTXE Origin String -- SJC: I consider it ill practice to export CTXE, see remark at top
-              | PE (Message Token)
-              deriving Show
-
-errors :: Guarded t -> [CtxError]
-errors (Checked _) = []
-errors (Errors lst) = lst
-
-class GetOneGuarded a where
-  getOneExactly :: (Traced a1, ShowADL a1) => a1 -> [a] -> Guarded a
-  getOneExactly _ [a] = Checked a
-  getOneExactly o l@[] = hasNone l o
-  getOneExactly o lst = Errors [CTXE o'$ "Found too many:\n  "++s | CTXE o' s <- errors (hasNone lst o)]
-  hasNone :: (Traced a1, ShowADL a1) => [a] -- this argument should be ignored! It is only here to help indicate a type (you may put [])
-                                     -> a1  -- the object where the problem is arising
-                                     -> Guarded a
-  hasNone _ o = getOneExactly o []
-
-instance GetOneGuarded (P_SubIfc a) where
-  hasNone _ o = Errors [CTXE (origin o)$ "Required: one subinterface in "++showADL o]
-
-instance GetOneGuarded (SubInterface) where
-  hasNone _ o = Errors [CTXE (origin o)$ "Required: one subinterface in "++showADL o]
-
-instance GetOneGuarded Declaration where
-  getOneExactly _ [d] = Checked d
-  getOneExactly o []  = Errors [CTXE (origin o)$ "No declaration for "++showADL o]
-  getOneExactly o lst = Errors [CTXE (origin o)$ "Too many declarations match "++showADL o++".\n  Be more specific. These are the matching declarations:"++concat ["\n  - "++showADL l++" at "++(showFullOrig$origin l) | l<-lst]]
-
-cannotDisambRel :: (ShowADL a2, Association a2) => (TermPrim) -> [a2] -> Guarded a
-cannotDisambRel o [] = Errors [CTXE (origin o)$ "No declarations match the relation: "++showADL o]
-cannotDisambRel o@Prel{} lst = Errors [CTXE (origin o)$ "Cannot disambiguate the relation: "++showADL o++"\n  Please add a signature (e.g. [A*B]) to the relation.\n  Relations you may have intended:"++concat ["\n  "++showADL l++"["++showADL (source l)++"*"++showADL (target l)++"]"|l<-lst]]
-cannotDisambRel o lst = Errors [CTXE (origin o)$ "Cannot disambiguate: "++showADL o++"\n  Please add a signature.\n  You may have intended one of these:"++concat ["\n  "++showADL l|l<-lst]]
-cannotDisamb :: (Traced a1, ShowADL a1) => a1 -> Guarded a
-cannotDisamb o = Errors [CTXE (origin o)$ "Cannot disambiguate: "++showADL o++"\n  Please add a signature to it"]
-
-uniqueNames :: (Identified a, Traced a) =>
-                     [a] -> Guarded ()
-uniqueNames a = case (filter moreThanOne . groupWith name)  a of
-                  [] -> pure ()
-                  xs -> Errors (map messageFor xs)
-    where 
-     moreThanOne (_:_:_) = True
-     moreThanOne  _      = False
-     messageFor :: (Identified a, Traced a) => [a] -> CtxError
-     messageFor (x:xs) = CTXE (origin x) 
-                      ("Names / labels must be unique. "++(show . name) x++", however, is also used at:"++
-                        concatMap (("\n    "++ ) . show . origin) xs
-                        ++"."
-                       )             
-     messageFor _ = fatal 90 "messageFor must only be used on lists with more thatn one element!"
---                  [r] -> Errors [CTXE (origin (head r))$ "Names / labels must be unique. "++(show . name) r++", however, is not."]
---                  r -> Errors [CTXE (origin (head a))$ "Names / labels must be unique. The following are not: "++concat ["\n  - "++l'|l'<-r]]
-class ErrorConcept a where
-  showEC :: a -> String
-  showMini :: a -> String
-
-instance ErrorConcept (P_ViewD a) where
-  showEC x = showADL (vd_cpt x) ++" given in VIEW "++vd_lbl x
-  showMini x = showADL (vd_cpt x)
-
-instance (ShowADL a2) => ErrorConcept (SrcOrTgt, A_Concept, a2) where
-  showEC (p1,c1,e1) = showADL c1++" ("++show p1++" of "++showADL e1++")"
-  showMini (_,c1,_) = showADL c1
-
-instance (ShowADL a2, Association a2) => ErrorConcept (SrcOrTgt, a2) where
-  showEC (p1,e1)
-   = case p1 of
-      Src -> showEC (p1,source e1,e1)
-      Tgt -> showEC (p1,target e1,e1)
-  showMini (p1,e1)
-   = case p1 of
-      Src -> showMini (p1,source e1,e1)
-      Tgt -> showMini (p1,target e1,e1)
-
-mustBeOrdered :: (Traced a1, ErrorConcept a2, ErrorConcept a3) => a1 -> a2 -> a3 -> Guarded a
-mustBeOrdered o a b
- = Errors [CTXE (origin o)$ "Type error, cannot match:\n  the concept "++showEC a
-                                          ++"\n  and concept "++showEC b
-                   ++"\n  if you think there is no type error, add an order between concepts "++showMini a++" and "++showMini b++"."]
-
-mustBeOrderedLst :: (Traced o, ShowADL o, ShowADL a) => o -> [(A_Concept, SrcOrTgt, a)] -> Guarded b
-mustBeOrderedLst o lst
- = Errors [CTXE (origin o)$ "Type error in "++showADL o++"\n  Cannot match:"++ concat
-             [ "\n  - concept "++showADL c++", "++show st++" of "++showADL a
-             | (c,st,a) <- lst ] ++
-             "\n  if you think there is no type error, add an order between the mismatched concepts."
-          ]
- 
-
-
-mustBeOrderedConcLst :: Origin -> (SrcOrTgt, Expression) -> (SrcOrTgt, Expression) -> [[A_Concept]] -> Guarded a
-mustBeOrderedConcLst o (p1,e1) (p2,e2) cs
- = Errors [CTXE o$ "Ambiguous type when matching: "++show p1++" of "++showADL e1++"\n"
-                                          ++" and "++show p2++" of "++showADL e2++".\n"
-                   ++"  The type can be "++intercalate " or " (map (showADL . Slash) cs)
-                   ++"\n  None of these concepts is known to be the smallest, you may want to add an order between them."]
-
-newtype Slash a = Slash [a]
-instance ShowADL a => ShowADL (Slash a) where
-  showADL (Slash x) = intercalate "/" (map showADL x)
-  
-
-mustBeBound :: Origin -> [(SrcOrTgt, Expression)] -> Guarded a
-mustBeBound o [(p,e)]
- = Errors [CTXE o$ "An ambiguity arises in type checking. Be more specific by binding the "++show p++" of the expression "++showADL e++".\n"++
-                   "  You could add more types inside the expression, or just write "++writeBind e++"."]
-mustBeBound o lst
- = Errors [CTXE o$ "An ambiguity arises in type checking. Be more specific in the expressions "++intercalate " and " (map (showADL . snd) lst) ++".\n"++
-                   "  You could add more types inside the expression, or write:"++
-                   concat ["\n  "++writeBind e| (_,e)<-lst]]
-
-writeBind :: Expression -> String
-writeBind (ECpl e)
- = "("++showADL (EDcV (sign e))++"["++showADL (source e)++"*"++showADL (target e)++"]"++" - "++showADL e++")"
-writeBind e
- = "("++showADL e++") /\\ "++showADL (EDcV (sign e))++"["++showADL (source e)++"*"++showADL (target e)++"]"
-
-data Guarded a = Errors [CtxError] | Checked a deriving Show
-
-instance Functor Guarded where
- fmap _ (Errors a) = (Errors a)
- fmap f (Checked a) = Checked (f a)
- 
-instance Applicative Guarded where
- pure = Checked
- (<*>) (Checked f) (Checked a) = Checked (f a)
- (<*>) (Errors  a) (Checked _) = Errors a 
- (<*>) (Checked _) (Errors  b) = Errors b
- (<*>) (Errors  a) (Errors  b) = Errors (a ++ b) -- this line makes Guarded not a monad
- -- Guarded is NOT a monad!
- -- Reason: (<*>) has to be equal to `ap' if it is, and this definition is different
- -- Use <?> if you wish to use the monad-like thing
-
-showErr :: CtxError -> String
-showErr (CTXE o s)
- = s ++ "\n  " ++ showFullOrig o
-showErr (PE s)
- = show s
-
-showFullOrig :: Origin -> String
-showFullOrig (FileLoc (FilePos (filename,DatabaseDesign.Ampersand.ADL1.Pos l c,t)))
-              = "Error at symbol "++ t ++ " in file " ++ filename++" at line " ++ show l++" : "++show c
-showFullOrig x = show x

− src/lib/DatabaseDesign/Ampersand/Input/ADL1/FilePos.hs 
@@ -1,55 +0,0 @@-{-# OPTIONS_GHC -Wall #-}
-module DatabaseDesign.Ampersand.Input.ADL1.FilePos
-       ( FilePos(..), Origin(..), Pos(Pos) , Traced(..))
-where
-   import DatabaseDesign.Ampersand.Input.ADL1.UU_Scanner (Pos(Pos))
---   import DatabaseDesign.Ampersand.Basics      (fatalMsg)
-
---   fatal :: Int -> String -> a
---   fatal = fatalMsg "Input.ADL1.FilePos"
-
-   --Traced a have an origin, which may be unknown.
-   data FilePos = FilePos ( String, Pos, String) deriving (Eq, Ord)
-   data Origin = OriginUnknown | Origin String | FileLoc FilePos | DBLoc String deriving (Eq, Ord)
---line column pos
-
-{- SJ20140216: made obsolete. This was used to tell which concept definitions are declared within a pattern or within a process.
-   posIn :: Traced a => Origin -> a -> Origin -> Bool
-   posIn (FileLoc (FilePos (f , Pos bl bc, _)))
-         x
-         (FileLoc (FilePos (f', Pos el ec, _)))
-         | f/=f' = False
-         | bl==el = bc < colnr x && colnr x < ec
-         | otherwise = bl < linenr x && linenr x < el
-   posIn _ _ _ = False
--}
- 
-   instance Show FilePos where
-     show (FilePos (fn,Pos l c,_))
-       = "line " ++ show l++":"++show c
-            ++ ", file " ++ show fn
-
-   instance Show Origin where
-     show (FileLoc pos) = show pos
-     show (DBLoc str)   = "Database location: "++str
-     show (Origin str)  = str
-     show OriginUnknown = "Unknown origin"
-   class Traced a where
-    origin :: a -> Origin
-    filenm :: a -> String
-    linenr :: a -> Int
-    colnr :: a -> Int
-    filenm x = case origin x of 
-                     FileLoc (FilePos (nm, _, _)) -> nm
-                     _ -> ""
-    linenr x = case origin x of 
-                     FileLoc (FilePos (_,Pos l _,_)) -> l
-                     _ -> 0
-    colnr x  = case origin x of 
-                     FileLoc (FilePos (_,Pos _ c,_)) -> c
-                     _ -> 0
-
-   instance Traced Origin where
-    origin = id
-
-

− src/lib/DatabaseDesign/Ampersand/Input/ADL1/Parser.hs 
@@ -1,794 +0,0 @@-{-# OPTIONS_GHC -Wall -fno-enable-rewrite-rules #-}-{-# LANGUAGE FlexibleContexts, MultiParamTypeClasses #-}-module DatabaseDesign.Ampersand.Input.ADL1.Parser -   (pContext, pPopulations,pTerm, keywordstxt, keywordsops, specialchars, opchars) where-   import DatabaseDesign.Ampersand.Input.ADL1.UU_Scanner-            ( Token(..),TokenType(..),noPos-            , pKey,pConid,pString,pSpec,pAtom,pExpl,pVarid,pComma,pInteger,pSemi)-   import DatabaseDesign.Ampersand.Input.ADL1.UU_Parsing-            (Parser-            , (<$>) , (<$), (<*>), (<*), (*>), (<|>), (<??>)-            ,pList,pListSep,pList1,pList1Sep,pSym-            ,pSucceed-            ,opt, Sequence,Alternative, IsParser-            )-   import DatabaseDesign.Ampersand.Basics  (fatalMsg,Collection(..))-   import DatabaseDesign.Ampersand.Core.ParseTree    -   import Data.List-   import Data.Maybe-   -   fatal :: Int -> String -> a-   fatal = fatalMsg "Input.ADL1.Parser"----  The Ampersand scanner takes the file name (String) for documentation and error messaging.---   scanner :: String -> String -> [Token]---   scanner fn str = scan keywordstxt keywordsops specialchars opchars fn initPos str--   keywordstxt :: [String]-   keywordstxt       = [ "INCLUDE"-                       , "CONTEXT", "ENDCONTEXT", "EXTENDS", "THEMES"-                       , "META"-                       , "PATTERN", "ENDPATTERN"-                       , "PROCESS", "ENDPROCESS"-                       , "INTERFACE", "FOR", "BOX", "INITIAL", "SQLPLUG", "PHPPLUG", "TYPE"-                       , "POPULATION", "CONTAINS"-                       , "UNI", "INJ", "SUR", "TOT", "SYM", "ASY", "TRN", "RFX", "IRF", "PROP", "ALWAYS"-                       , "RULE", "MESSAGE", "VIOLATION", "SRC", "TGT", "TEST"-                       , "RELATION", "MEANING", "CONCEPT", "IDENT"-                       , "VIEW", "TXT", "PRIMHTML"-                       , "KEY" -- HJO, 20130605: Obsolete. Only usefull as long as the old prototype generator is still in use.-                       , "IMPORT", "SPEC", "ISA", "IS", "I", "V"-                       , "CLASSIFY"-                       , "PRAGMA", "PURPOSE", "IN", "REF", "ENGLISH", "DUTCH"-                       , "REST", "HTML", "LATEX", "MARKDOWN"-                       , "ONE"-                       , "BYPLUG"-                       , "ROLE", "EDITS", "MAINTAINS"-                       ]-   keywordsops :: [String]-   keywordsops       = [ "|-", "-", "->", "<-", ">", "=", "~", "+", "*", ";", "!", "#", "::", ":", "\\/", "/\\", "\\", "/", "<>"-                       , "..", "." , "0", "1"]-   specialchars :: String-   specialchars      = "()[],{}"-   opchars :: String-   opchars           = nub (sort (concat keywordsops))--   --to parse files containing only populations-   pPopulations :: Parser Token [P_Population]-   pPopulations = pList1 pPopulation--   pContext :: Parser Token (P_Context, [String]) -- the result is the parsed context and a list of include filenames-   pContext  = rebuild <$> pKey_pos "CONTEXT" <*> pConceptName-                            <*> optional pLanguageRef -                            <*> optional pTextMarkup -                            <*> pList pContextElement <* pKey "ENDCONTEXT"-     where-       rebuild :: Origin -> String -> Maybe Lang -> Maybe PandocFormat -> [ContextElement] -> (P_Context, [String])-       rebuild    pos'      nm        lang          fmt                   ces-        = (PCtx{ ctx_nm     = nm-               , ctx_pos    = [pos']-               , ctx_lang   = lang-               , ctx_markup = fmt-               , ctx_thms   = (nub.concat) [xs | CThm xs<-ces] -- Names of patterns/processes to be printed in the functional specification. (For partial documents.)-               , ctx_pats   = [p | CPat p<-ces]       -- The patterns defined in this context-               , ctx_PPrcs  = [p | CPrc p<-ces]       -- The processes as defined by the parser-               , ctx_rs     = [p | CRul p<-ces]       -- All user defined rules in this context, but outside patterns and outside processes-               , ctx_ds     = [p | CRel p<-ces]       -- The relations defined in this context, outside the scope of patterns-               , ctx_cs     = [c ("CONTEXT "++nm) | CCon c<-ces]    -- The concept definitions defined in this context, outside the scope of patterns-               , ctx_gs     = [g | CGen g<-ces]       -- The gen definitions defined in this context, outside the scope of patterns-               , ctx_ks     = [k | CIndx k<-ces]      -- The identity definitions defined in this context, outside the scope of patterns-               , ctx_vs     = [v | CView v<-ces]      -- The view definitions defined in this context, outside the scope of patterns-               , ctx_ifcs   = [s | Cifc s<-ces]       -- The interfaces defined in this context, outside the scope of patterns -- fatal 78 ("Diagnostic: "++concat ["\n\n   "++show ifc | Cifc ifc<-ces])-               , ctx_sql    = [p | CSqlPlug p<-ces]   -- user defined sqlplugs, taken from the Ampersand scriptplug<-ces]  -               , ctx_php    = [p | CPhpPlug p<-ces]   -- user defined phpplugs, taken from the Ampersand script-               , ctx_ps     = [e | CPrp e<-ces]       -- The purposes defined in this context, outside the scope of patterns-               , ctx_pops   = [p | CPop p<-ces]       -- The populations defined in this contextplug<-ces]  -               , ctx_metas  = [m | CMeta m <-ces]-               }-          , [s | CIncl s<-ces]) -- the INCLUDE filenames--       pContextElement :: Parser Token ContextElement-       pContextElement = CMeta    <$> pMeta         <|>-                         CPat     <$> pPatternDef   <|>-                         CPrc     <$> pProcessDef   <|>-                         CRul     <$> pRuleDef      <|>-                         CCfy     <$> pClassify     <|>-                         CRel     <$> pRelationDef  <|>-                         CCon     <$> pConceptDef   <|>-                         CGen     <$> pGenDef       <|>-                         CIndx    <$> pIndex        <|>-                         CView    <$> pViewDef      <|>-                         Cifc     <$> pInterface    <|>-                         CSqlPlug <$> pSqlplug      <|>-                         CPhpPlug <$> pPhpplug      <|>-                         CPrp     <$> pPurpose      <|>-                         CPop     <$> pPopulation   <|>-                         CThm     <$> pPrintThemes  <|>-                         CIncl    <$> pIncludeStatement---   data ContextElement = CMeta Meta-                       | CPat P_Pattern-                       | CPrc P_Process-                       | CRul (P_Rule TermPrim)-                       | CCfy P_Gen-                       | CRel P_Declaration-                       | CCon (String->ConceptDef)-                       | CGen P_Gen-                       | CIndx P_IdentDef-                       | CView P_ViewDef-                       | Cifc P_Interface-                       | CSqlPlug P_ObjectDef-                       | CPhpPlug P_ObjectDef-                       | CPrp PPurpose-                       | CPop P_Population-                       | CThm [String]    -- a list of themes to be printed in the functional specification. These themes must be PATTERN or PROCESS names.-                       | CIncl String     -- an INCLUDE statement--   pIncludeStatement :: Parser Token String-   pIncludeStatement = pKey "INCLUDE" *> pString--   pLanguageRef :: Parser Token Lang-   pLanguageRef = pKey "IN" *> -                  (( Dutch   <$ pKey "DUTCH"  ) <|>-                   ( English <$ pKey "ENGLISH")-                  )-   pTextMarkup :: Parser Token PandocFormat-   pTextMarkup = ( ReST     <$ pKey "REST"     ) <|>-                 ( HTML     <$ pKey "HTML"     ) <|>-                 ( LaTeX    <$ pKey "LATEX"    ) <|>-                 ( Markdown <$ pKey "MARKDOWN" )--   pMeta :: Parser Token Meta-   pMeta = Meta <$> pKey_pos "META" <*> pMetaObj <*> pString <*> pString-    where pMetaObj = pSucceed ContextMeta -- for the context meta we don't need a keyword-    -   pPatternDef :: Parser Token P_Pattern-   pPatternDef = rebuild <$> pKey_pos "PATTERN" <*> pConceptName   -- The name spaces of patterns, processes and concepts are shared.-                         <*> pList pPatElem-                         <*> pKey_pos "ENDPATTERN"-     where-       rebuild :: Origin -> String -> [PatElem] -> Origin -> P_Pattern-       rebuild pos' nm pes end-        = P_Pat { pt_nm  = nm-                , pt_pos = pos'-                , pt_end = end-                , pt_rls = [r | Pr r<-pes]-                , pt_gns = [g | Pg g<-pes]-                , pt_dcs = [d | Pd d<-pes]-                , pt_rus = [r | Pm r<-pes]-                , pt_res = [r | Pl r<-pes]-                , pt_cds = [c nm | Pc c<-pes]-                , pt_ids = [k | Pk k<-pes]-                , pt_vds = [v | Pv v<-pes]-                , pt_xps = [e | Pe e<-pes]-                , pt_pop = [p | Pp p<-pes]-                } -       pPatElem :: Parser Token PatElem-       pPatElem = Pr <$> pRuleDef      <|>-                  Py <$> pClassify     <|>-                  Pd <$> pRelationDef  <|>-                  Pm <$> pRoleRule     <|>-                  Pl <$> pRoleRelation <|>-                  Pc <$> pConceptDef   <|>-                  Pg <$> pGenDef       <|>-                  Pk <$> pIndex        <|>-                  Pv <$> pViewDef      <|>-                  Pe <$> pPurpose      <|>-                  Pp <$> pPopulation--   data PatElem = Pr (P_Rule TermPrim)-                | Py P_Gen-                | Pd P_Declaration -                | Pm RoleRule-                | Pl P_RoleRelation-                | Pc (String->ConceptDef)-                | Pg P_Gen-                | Pk P_IdentDef-                | Pv P_ViewDef-                | Pe PPurpose-                | Pp P_Population-                              -   pProcessDef :: Parser Token P_Process-   pProcessDef = rebuild <$> pKey_pos "PROCESS" <*> pConceptName   -- The name spaces of patterns, processes and concepts are shared.-                         <*> pList pProcElem-                         <*> pKey_pos "ENDPROCESS"-      where-       rebuild :: Origin -> String -> [ProcElem] -> Origin -> P_Process-       rebuild pos' nm pes end-         = P_Prc { procNm    = nm-                 , procPos   = pos'-                 , procEnd   = end-                 , procRules = [rr | PrR rr<-pes]-                 , procGens  = [g  | PrG g <-pes]-                 , procDcls  = [d  | PrD d <-pes]-                 , procRRuls = [rr | PrM rr<-pes]-                 , procRRels = [rr | PrL rr<-pes]-                 , procCds   = [cd nm | PrC cd<-pes]-                 , procIds   = [ix | PrI ix<-pes]-                 , procVds   = [vd | PrV vd<-pes]-                 , procXps   = [e  | PrE e <-pes]-                 , procPop   = [p  | PrP p <-pes]-                 }-       pProcElem :: Parser Token ProcElem-       pProcElem = PrR <$> pRuleDef      <|>-                   PrY <$> pClassify     <|>-                   PrD <$> pRelationDef  <|>-                   PrM <$> pRoleRule     <|>-                   PrL <$> pRoleRelation <|>-                   PrC <$> pConceptDef   <|>-                   PrG <$> pGenDef       <|>-                   PrI <$> pIndex        <|>-                   PrV <$> pViewDef      <|>-                   PrE <$> pPurpose      <|>-                   PrP <$> pPopulation--   data ProcElem = PrR (P_Rule TermPrim)-                 | PrY P_Gen-                 | PrD P_Declaration-                 | PrM RoleRule-                 | PrL P_RoleRelation-                 | PrC (String->ConceptDef)-                 | PrG P_Gen-                 | PrI P_IdentDef-                 | PrV P_ViewDef-                 | PrE PPurpose-                 | PrP P_Population--   pClassify :: Parser Token P_Gen   -- Example: CLASSIFY A IS B /\ C /\ D-   pClassify = rebuild <$> pKey_pos "CLASSIFY"-                       <*> pConceptRef-                       <*  pKey "IS"-                       <*> pCterm-                  where-                    rebuild po lhs rhs-                      = P_Cy { gen_spc  = lhs             --  Left hand side concept expression -                             , gen_rhs  = rhs             --  Right hand side concept expression-                             , gen_fp   = po-                             }-                    pCterm  = f <$> pList1Sep (pKey "/\\") pCterm1-                    pCterm1 = g <$> pConceptRef                        <|>-                              h <$> (pSpec '(' *> pCterm <* pSpec ')')  -- brackets are allowed for educational reasons.-                    f ccs = concat ccs-                    g c = [c]-                    h cs = cs--   -   pRuleDef :: Parser Token (P_Rule TermPrim)-   pRuleDef =  rebuild <$> pKey_pos "RULE"-                       <*> optional (pADLid <* pKey ":" )-                       <*> pRule-                       <*> pList pMeaning                 -                       <*> pList pMessage-                       <*> optional pViolation-                  where-                    rebuild po mn rexp mean msg mViolation-                      = P_Ru { rr_nm   = fromMaybe (rulid po) mn-                             , rr_exp  = rexp-                             , rr_fps  = po-                             , rr_mean = mean-                             , rr_msg  = msg-                             , rr_viol = mViolation-                             }-                    rulid (FileLoc(FilePos (_,Pos l _,_))) = "rule@line"++show l-                    rulid _ = fatal 226 "pRuleDef is expecting a file location."-                    pViolation :: Parser Token (PairView (Term TermPrim))-                    pViolation = id <$ pKey "VIOLATION" <*> pPairView-               -                    pPairView :: Parser Token (PairView (Term TermPrim))-                    pPairView = PairView <$ pSpec '(' <*> pList1Sep (pSpec ',') pPairViewSegment <* pSpec ')'-               -                    pPairViewSegment :: Parser Token (PairViewSegment (Term TermPrim))-                    pPairViewSegment = PairViewExp <$> pSrcOrTgt <*>  pTerm-                                   <|> PairViewText <$ pKey "TXT" <*> pString-   -   pSrcOrTgt :: Parser Token SrcOrTgt                    -   pSrcOrTgt = Src <$ pKey "SRC" <|> Tgt <$ pKey "TGT"---   pRelationDef :: Parser Token P_Declaration-   pRelationDef      = ( rebuild <$> pVarid  <*> pKey_pos "::"  <*> pConceptRef  <*> pFun  <*> pConceptRef-                         <|> rbd <$> pKey_pos "RELATION" <*> pVarid  <*> pSign-                       )-                         <*> ((True <$ pKey "BYPLUG") `opt` False)-                         <*> (pProps `opt` [])-                         <*> ((True <$ pKey "BYPLUG") `opt` False)-                         <*> (pPragma `opt` [])-                         <*> pList pMeaning-                         <*> ((pKey "=" *> pContent) `opt` [])-                         <* (pKey "." `opt` "")         -- in the syntax before 2011, a dot was required. This optional dot is there to save user irritation during the transition to a dotless era  :-) .-                       where rebuild nm pos' src fun' trg bp1 props --bp2 pragma meanings content-                               = rbd pos' nm (P_Sign src trg,pos') bp1 props' --bp2 pragma meanings content-                                 where props'= nub (props `uni` fun')-                             rbd pos' nm (sgn,_) bp1 props bp2 pragma meanings content-                               = P_Sgn { dec_nm   = nm-                                       , dec_sign = sgn-                                       , dec_prps = props-                                       , dec_prL  = head pr-                                       , dec_prM  = pr!!1-                                       , dec_prR  = pr!!2-                                       , dec_Mean = meanings-                                       , dec_popu = content-                                       , dec_fpos = pos'-                                       , dec_plug = bp1 || bp2-                                       }-                                 where pr = pragma++["","",""]--                             pProps :: Parser Token [Prop]-                             pProps  = (f.concat) <$> (pSpec '[' *> pListSep (pSpec ',') pProp <* pSpec ']')-                                 where f ps = nub (ps ++ concat [[Uni, Inj] | null ([Sym, Asy]>-ps)])-                             pProp :: Parser Token [Prop]-                             pProp   = k [Uni] "UNI" <|> k [Inj] "INJ" <|> k [Sur] "SUR" <|> k [Tot] "TOT" <|>-                                       k [Sym] "SYM" <|> k [Asy] "ASY" <|> k [Trn] "TRN" <|>-                                       k [Rfx] "RFX" <|> k [Irf] "IRF" <|> k [Sym, Asy] "PROP"-                                 where k obj str = f <$> pKey str where f _ = obj-                             pPragma :: Parser Token [String]-                             pPragma = pKey "PRAGMA" *> pList1 pString-                             pFun :: Parser Token [Prop]-                             pFun    = []        <$ pKey "*"  <|> -                                       [Uni,Tot] <$ pKey "->" <|>-                                       [Sur,Inj] <$ pKey "<-" <|>-                                       (rbld     <$  pSpec '['  -                                                 <*> (pMult (Sur,Inj) `opt` [])-                                                 <*  pKey "-"-                                                 <*> (pMult (Tot,Uni) `opt` [])-                                                 <*  pSpec ']'-                                       )       -                                 where -                                   pMult :: (Prop,Prop) -> Parser Token [Prop]-                                   pMult (ts,ui) = rbld  <$> (( []   <$ pKey "0") <|> ([ts] <$ pKey "1") ) -                                                         <*  pKey ".."-                                                         <*> (( [ui] <$ pKey "1") <|> ([]   <$ pKey "*" )) <|>-                                                   [] <$ pKey "*"  <|>-                                                   [ts,ui] <$ pKey "1"-                                   rbld a b = a++b -                                       -   pConceptDef :: Parser Token (String->ConceptDef)-   pConceptDef       = Cd <$> pKey_pos "CONCEPT"-                          <*> pConceptName           -- the concept name-                          <*> ((True <$ pKey "BYPLUG") `opt` False)-                          <*> pString                -- the definition text-                          <*> ((pKey "TYPE" *> pString) `opt` "")     -- the type of the concept.-                          <*> (pString `opt` "")     -- a reference to the source of this definition.--   pGenDef :: Parser Token P_Gen-   pGenDef           = rebuild <$> pKey_pos "SPEC"     <*> pConceptRef <* pKey "ISA" <*> pConceptRef <|>  -- SPEC is obsolete syntax. Should disappear!-                       rebuild <$> pKey_pos "CLASSIFY" <*> pConceptRef <* pKey "ISA" <*> pConceptRef <|>-                       pClassify-                       where rebuild p spc gen = PGen{gen_spc=spc, gen_gen=gen, gen_fp =p}--   -- | A identity definition looks like:   IDENT onNameAdress : Person(name, address),-   -- which means that name<>name~ /\ address<>addres~ |- I[Person].-   -- The label 'onNameAddress' is used to refer to this identity.-   -- You may also use an expression on each attribute place, for example: IDENT onpassport: Person(nationality, passport;documentnr),-   -- which means that nationality<>nationality~ /\ passport;documentnr<>(passport;documentnr)~ |- I[Person].-   pIndex :: Parser Token P_IdentDef-   pIndex  = identity <$ pKey "IDENT" <*> pLabel <*> pConceptRefPos <* pSpec '(' <*> pList1Sep (pSpec ',') pIndSegment <* pSpec ')'-       where identity :: Label -> (P_Concept, Origin) -> [P_IdentSegment] -> P_IdentDef -             identity (Lbl nm _ _) (c, orig) ats-              = P_Id { ix_pos = orig-                     , ix_lbl = nm-                     , ix_cpt = c-                     , ix_ats = ats-                     }--             pIndSegment :: Parser Token P_IdentSegment-             pIndSegment = P_IdentExp <$> pIndAtt-             -             pIndAtt :: Parser Token P_ObjectDef-             pIndAtt  = attL <$> pLabelProps <*> pTerm <|>-                        att <$> pTerm-                 where attL (Lbl nm p strs) attexpr =-                          P_Obj { obj_nm   = nm-                                , obj_pos  = p-                                , obj_ctx  = attexpr -                                , obj_msub = Nothing-                                , obj_strs = strs-                                }-                       att attexpr =-                           P_Obj { obj_nm   = ""-                                 , obj_pos  = Origin "pIndAtt CC664"-                                 , obj_ctx  = attexpr -                                 , obj_msub = Nothing-                                 , obj_strs = []-                                 }--   -- | A view definition looks like:-   --      VIEW onSSN: Person("social security number":ssn)-   -- or-   --      VIEW SaveAdlFile: SaveAdlFile(PRIMHTML "<a href='../../index.php?operation=2&file=", filepath , filename-   --      ,PRIMHTML "&userrole=", savecontext~;sourcefile;uploaded~;userrole-   --      ,PRIMHTML "'>", filename/\V[SaveAdlFile*FileName], PRIMHTML "</a>")-   -- which can be used to define a proper user interface by assigning labels and markup to the attributes in a view.-   pViewDef :: Parser Token P_ViewDef-   pViewDef  = vd <$ (pKey "VIEW" <|> pKey "KEY") <*> pLabelProps <*> pConceptOneRefPos <* pSpec '(' <*> pList1Sep (pSpec ',') pViewSegment <* pSpec ')'-       where vd :: Label -> (P_Concept, Origin) -> [P_ViewSegment] -> P_ViewDef -             vd (Lbl nm _ _) (c, orig) ats-                 = P_Vd { vd_pos = orig-                        , vd_lbl = nm-                        , vd_cpt = c-                        , vd_ats = [ case viewSeg of-                                        P_ViewExp x       -> if null (obj_nm x) then P_ViewExp $ x{obj_nm=show i} else P_ViewExp x -                                        P_ViewText _ -> viewSeg -                                        P_ViewHtml _ -> viewSeg -                                   | (i,viewSeg)<-zip [(1::Integer)..] ats]-                        } -- nrs also count text segments but they're are not important anyway-             pViewSegment :: Parser Token P_ViewSegment-             pViewSegment = P_ViewExp  <$> pViewAtt <|> -                            P_ViewText <$ pKey "TXT" <*> pString <|>-                            P_ViewHtml <$ pKey "PRIMHTML" <*> pString-             pViewAtt :: Parser Token P_ObjectDef-             pViewAtt = rebuild <$> optional pLabelProps <*> pTerm-                 where-                   rebuild mLbl attexpr =-                     case mLbl of-                       Just (Lbl nm p strs) ->-                               P_Obj { obj_nm   = nm-                                     , obj_pos  = p-                                     , obj_ctx  = attexpr -                                     , obj_msub = Nothing-                                     , obj_strs = strs-                                     }-                       Nothing ->-                               P_Obj { obj_nm   = ""-                                     , obj_pos  = origin attexpr-                                     , obj_ctx  = attexpr -                                     , obj_msub = Nothing-                                     , obj_strs = []-                                     }--   pInterface :: Parser Token P_Interface-   pInterface = lbl <$> (pKey "INTERFACE" *> pADLid_val_pos) <*>-                        (pParams `opt` [])                   <*>       -- a list of expressions, which say which relations are editable within this service.-                                                                       -- either  Prel _ nm-                                                                       --       or  PTrel _ nm sgn-                        (pArgs   `opt` [])                   <*>  -                        (pRoles  `opt` [])                   <*>  -                        (pKey ":" *> pTerm)                  <*>  -                        pSubInterface-       where lbl :: (String, Origin) -> [TermPrim] -> [[String]] -> [String] -> (Term TermPrim) -> P_SubInterface -> P_Interface-             lbl (nm,p) params args roles expr sub-                = P_Ifc { ifc_Name   = nm-                        , ifc_Params = params-                        , ifc_Args   = args-                        , ifc_Roles  = roles-                        , ifc_Obj    = P_Obj { obj_nm   = nm    -                                             , obj_pos  = p-                                             , obj_ctx  = expr-                                             , obj_msub = Just sub-                                             , obj_strs = args-                                             }-                        , ifc_Pos    = p-                        , ifc_Prp    = ""   --TODO: Nothing in syntax defined for the purpose of the interface.-                        }-             pParams = pSpec '(' *> pList1Sep (pSpec ',') pRelSign          <* pSpec ')' -             pArgs   = pSpec '{' *> pList1Sep (pSpec ',') (pList1 pADLid)   <* pSpec '}'-             pRoles  = pKey "FOR" *> pList1Sep (pSpec ',') pADLid--   pSubInterface :: Parser Token P_SubInterface -   pSubInterface = P_Box <$> pKey_pos "BOX" <*> pBox -                   <|> rebuild <$ pKey "INTERFACE" <*> pADLid_val_pos  -      where-        rebuild (n,p) = P_InterfaceRef p n--   pObjDef :: Parser Token P_ObjectDef-   pObjDef            = obj <$> pLabelProps-                            <*> pTerm            -- the context expression (for example: I[c])-                            <*> optional pSubInterface  -- the optional subinterface -                        where obj (Lbl nm pos' strs) expr msub  = -                                P_Obj { obj_nm   = nm-                                      , obj_pos  = pos'-                                      , obj_ctx  = expr-                                      , obj_msub = msub -                                      , obj_strs = strs-                                      }-   pBox :: Parser Token [P_ObjectDef]-   pBox              = pSpec '[' *> pList1Sep (pSpec ',') pObjDef <* pSpec ']'--   pSqlplug :: Parser Token P_ObjectDef-   pSqlplug          = pKey_pos "SQLPLUG" *> pObjDef--   pPhpplug :: Parser Token P_ObjectDef-   pPhpplug          = pKey_pos "PHPPLUG" *> pObjDef--   pPurpose :: Parser Token PPurpose-   pPurpose          = rebuild <$> pKey_pos "PURPOSE"  -- "EXPLAIN" has become obsolete-                               <*> pRef2Obj-                               <*> optional pLanguageRef-                               <*> optional pTextMarkup-                               <*> ((pKey "REF" *> (pList1Sep pSemi pString)) `opt` [])-                               <*> pExpl      -        where-          rebuild :: Origin -> PRef2Obj -> Maybe Lang -> Maybe PandocFormat -> [String] -> String -> PPurpose-          rebuild    orig      obj         lang          fmt                   refs       str-              = PRef2 orig obj (P_Markup lang fmt str) (concatMap (splitOn ";") refs)-                 where splitOn :: Eq a => [a] -> [a] -> [[a]]-                       splitOn [] s = [s]-                       splitOn s t  = case findIndex (isPrefixOf s) (tails t) of-                                        Nothing -> [t]-                                        Just i  -> [take i t]  ++ splitOn s (drop (i+length s) t)--          pRef2Obj :: Parser Token PRef2Obj-          pRef2Obj = PRef2ConceptDef  <$ pKey "CONCEPT"   <*> pConceptName <|>-                     PRef2Declaration <$ pKey "RELATION"  <*> pRelSign     <|>-                     PRef2Rule        <$ pKey "RULE"      <*> pADLid       <|>-                     PRef2IdentityDef <$ pKey "IDENT"     <*> pADLid       <|>  -                     PRef2ViewDef     <$ pKey "VIEW"      <*> pADLid       <|>  -                     PRef2Pattern     <$ pKey "PATTERN"   <*> pADLid       <|>-                     PRef2Process     <$ pKey "PROCESS"   <*> pADLid       <|>-                     PRef2Interface   <$ pKey "INTERFACE" <*> pADLid       <|>-                     PRef2Context     <$ pKey "CONTEXT"   <*> pADLid--   pPopulation :: Parser Token P_Population-   pPopulation = prelpop <$> pKey_pos "POPULATION" <*> pRelSign     <* pKey "CONTAINS" <*> pContent <|>-                 pcptpop <$> pKey_pos "POPULATION" <*> pConceptName <* pKey "CONTAINS" <*> (pSpec '[' *> pListSep pComma pValue <* pSpec ']')-       where-         prelpop :: Origin -> TermPrim -> Pairs -> P_Population-         prelpop    orig     (Prel _ nm)  contents-          = P_RelPopu { p_rnme   = nm-                      , p_orig   = orig-                      , p_popps  = contents-                      }-         prelpop orig (PTrel _ nm sgn) contents-          = P_TRelPop { p_rnme   = nm-                      , p_type   = sgn-                      , p_orig   = orig-                      , p_popps  = contents-                      }-         prelpop _ expr _ = fatal 429 ("Expression "++show expr++" should never occur in prelpop.")-         pcptpop :: Origin -> String -> [String] -> P_Population-         pcptpop    orig      cnm       contents -          = P_CptPopu { p_cnme   = cnm-                      , p_orig   = orig-                      , p_popas  = contents-                      }--   pRoleRelation :: Parser Token P_RoleRelation-   pRoleRelation      = rr <$> pKey_pos "ROLE"              <*>-                               pList1Sep (pSpec ',') pADLid <*-                               pKey "EDITS"                 <*>-                               pList1Sep (pSpec ',') pRelSign-                        where rr p roles rels = P_RR roles rels p--   pRoleRule :: Parser Token RoleRule-   pRoleRule         = rr <$> pKey_pos "ROLE"               <*>-                              pList1Sep (pSpec ',') pADLid  <*-                              pKey "MAINTAINS"              <*>-                              pList1Sep (pSpec ',') pADLid -                       where rr p roles rulIds = Maintain roles rulIds p--   pPrintThemes :: Parser Token [String]-   pPrintThemes = pKey "THEMES" -               *> pList1Sep (pSpec ',') pConceptName  -- Patterns, processes and concepts share the same name space, so these names must be checked whether the processes and patterns exist.-   pMeaning :: Parser Token PMeaning-   pMeaning = rebuild <$  pKey "MEANING" -                      <*> optional pLanguageRef-                      <*> optional pTextMarkup-                      <*> (pString <|> pExpl)-      where rebuild :: Maybe Lang -> Maybe PandocFormat -> String -> PMeaning-            rebuild    lang          fmt                   mkup   =-               PMeaning (P_Markup lang fmt mkup)-   pMessage :: Parser Token PMessage-   pMessage = rebuild <$ pKey "MESSAGE" -                      <*> optional pLanguageRef-                      <*> optional pTextMarkup-                      <*> (pString <|> pExpl)-      where rebuild :: Maybe Lang -> Maybe PandocFormat -> String -> PMessage-            rebuild    lang          fmt                   mkup   =-               PMessage (P_Markup lang fmt mkup)-                              -{-  Basically we would have the following expression syntax:-pRule ::= pTrm1   "="    pTerm                           |  -- equivalence-          pTrm1   "|-"   pTerm                           |  -- implication or subset-          pTrm1 .-pTerm ::= pList1Sep "/\\" pTrm2                          |  -- intersection-          pList1Sep "\\/" pTrm2                          |  -- union-          pTrm2 .-pTrm2 ::= pTrm3    "-"    pTrm3                          |  -- set difference-          pTrm3 .-pTrm3 ::= pTrm4   "\\"   pTrm4                           |  -- right residual-          pTrm4   "/"    pTrm4                           |  -- left residual-          pTrm4 .-pTrm4 ::= pList1Sep ";" pTrm5                            |  -- composition       (semicolon)-          pList1Sep "!" pTrm5                            |  -- relative addition (dagger)-          pList1Sep "#" pTrm5                            |  -- cartesian product (asterisk)-          pTrm5 .-pTrm5 ::= "-"     pTrm6                                  |  -- unary complement-          pTrm6   pSign                                  |  -- unary type cast-          pTrm6   "~"                                    |  -- unary flip-          pTrm6   "*"                                    |  -- unary Kleene star-          pTrm6   "+"                                    |  -- unary Kleene plus-          pTrm6 .-pTrm6 ::= pRelation                                      |-          "("   pTerm   ")" .-In practice, we have it a little different.- - In order to avoid "associative" brackets, we parse the associative operators "\/", "/\", ";", and "!" with pList1Sep. That works.- - We would like the user to disambiguate between "=" and "|-" by using brackets. --}---{- In theory, the expression is parsed by:-   pRule :: Parser Token (Term TermPrim)-   pRule  =  fEequ <$> pTrm1  <*>  pKey_pos "="   <*>  pTerm   <|>-             fEimp <$> pTrm1  <*>  pKey_pos "|-"  <*>  pTerm   <|>-             pTrm1-             where fequ  lExp orig rExp = Pequ orig lExp rExp-                   fEimp lExp orig rExp = Pimp orig lExp rExp--- However elegant, this solution needs to be left-factored in order to get a performant parser.--}-   pRule :: Parser Token (Term TermPrim)-   pRule  =  pTerm <??> (fEqu  <$> pKey_pos "="  <*> pTerm <|>-                         fImpl <$> pKey_pos "|-" <*> pTerm )-             where fEqu  orig rExp lExp = Pequ orig lExp rExp-                   fImpl orig rExp lExp = Pimp orig lExp rExp--{--   pTrm1 is slightly more complicated, for the purpose of avoiding "associative" brackets.-   The idea is that each operator ("/\\" or "\\/") can be parsed as a sequence without brackets.-   However, as soon as they are combined, brackets are needed to disambiguate the combination.-   There is no natural precedence of one operator over the other.-   Brackets are enforced by parsing the subexpression as pTrm5.-   In order to maintain performance standards, the parser is left factored.-   The functions pars and f have arguments 'combinator' and 'operator' only to avoid writing the same code twice.--}-   pTerm :: Parser Token (Term TermPrim)-   pTerm   = pTrm2 <??> (f PIsc <$> pars PIsc "/\\" <|> f PUni <$> pars PUni "\\/")-             where pars combinator operator-                    = g <$> pKey_pos operator <*> pTrm2 <*> optional (pars combinator operator)-                             where g orig y Nothing  = (orig, y)-                                   g orig y (Just (org,z)) = (orig, combinator org y z)-                   f combinator (orig, y) x = combinator orig x y---- The left factored version of difference: (Actually, there is no need for left-factoring here, but no harm either)-   pTrm2 :: Parser Token (Term TermPrim)-   pTrm2   = pTrm3 <??> (f <$> pKey_pos "-" <*> pTrm3)-             where f orig rExp lExp = PDif orig lExp rExp---- The left factored version of right- and left residuals:-   pTrm3 :: Parser Token (Term TermPrim)-   pTrm3  =  pTrm4 <??> (fLrs <$> pKey_pos "/" <*> pTrm4 <|> fRrs <$> pKey_pos "\\"  <*> pTrm4 <|> fDia <$> pKey_pos "<>" <*> pTrm4 )-             where fLrs orig rExp lExp = PLrs orig lExp rExp-                   fRrs orig rExp lExp = PRrs orig lExp rExp-                   fDia orig rExp lExp = PDia orig lExp rExp--{- by the way, a slightly different way of getting exactly the same result is:-   pTrm3 :: Parser Token (Term TermPrim)-   pTrm3  =  pTrm4 <??> (f <$>  (pKey_val_pos "/" <|> pKey_val_pos "\\" <|> pKey_val_pos "<>") <*> pTrm4 )-             where f ("\\", orig) rExp lExp = PRrs orig lExp rExp-                   f ("/" , orig) rExp lExp = PLrs orig lExp rExp-                   f (_   , orig) rExp lExp = PDia orig lExp rExp--}---- composition and relational addition are associative, and parsed similar to union and intersect...-   pTrm4 :: Parser Token (Term TermPrim)-   pTrm4   = pTrm5 <??> (f PCps <$> pars PCps ";" <|> f PRad <$> pars PRad "!" <|> f PPrd <$> pars PPrd "#")-             where pars combinator operator-                    = g <$> pKey_pos operator <*> pTrm5 <*> optional (pars combinator operator)-                             where g orig y Nothing  = (orig, y)-                                   g orig y (Just (org,z)) = (orig, combinator org y z)-                   f combinator (orig, y) x = combinator orig x y--   pTrm5 :: Parser Token (Term TermPrim)-   pTrm5  =  f <$> pList (pKey_val_pos "-") <*> pTrm6  <*> pList ( pKey_val_pos "~" <|> pKey_val_pos "*" <|> pKey_val_pos "+" )-             where f ms pe (("~",_):("~",_):ps) = f ms pe ps                     -- e~  converse       (flip, wok)-                   f ms pe (("~",_):ps) = let x=f ms pe ps in PFlp (origin x) x  -- the type checker requires that the origin of x is equal to the origin of its converse.-                   f ms pe (("*",orig):ps) = PKl0 orig (f ms pe ps)              -- e*  Kleene closure (star)-                   f ms pe (("+",orig):ps) = PKl1 orig (f ms pe ps)              -- e+  Kleene closure (plus)-                   f (_:_:ms) pe ps        = f ms pe ps                          -- -e  complement     (unary minus)-                   f ((_,orig):ms) pe ps   = let x=f ms pe ps in PCpl orig x     -- the type checker requires that the origin of x is equal to the origin of its complement.-                   f _ pe _                = pe--   pTrm6 :: Parser Token (Term TermPrim)-   pTrm6  =  (Prim <$> pRelationRef)  <|>-             PBrk <$>  pSpec_pos '('  <*>  pTerm  <*  pSpec ')'--   pRelationRef :: Parser Token TermPrim-   pRelationRef      = pRelSign                                                                         <|>-                       pid   <$> pKey_pos "I"  <*> optional (pSpec '[' *> pConceptOneRef <* pSpec ']')  <|>-                       pfull <$> pKey_pos "V"  <*> optional pSign                                       <|>-                       singl <$> pAtom_val_pos <*> optional (pSpec '[' *> pConceptOneRef <* pSpec ']')-                       where pid orig Nothing = PI orig-                             pid orig (Just c)= Pid orig c-                             pfull orig Nothing = PVee orig-                             pfull orig (Just (P_Sign src trg, _)) = Pfull orig src trg-                             singl (nm,orig) x  = Patm orig nm x--   pRelSign :: Parser Token TermPrim-   pRelSign          = prel  <$> pVarid_val_pos <*> optional pSign-                       where prel (nm,orig) Nothing = Prel orig nm-                             prel (nm,_) (Just (sgn,orig)) = PTrel orig nm sgn-                                                                 -   pSign :: Parser Token (P_Sign,Origin)-   pSign = rebuild <$> pSpec_pos '[' <*> pConceptOneRef <*> optional (pKey "*" *> pConceptOneRef) <* pSpec ']'-      where-        rebuild :: Origin -> P_Concept -> Maybe P_Concept -> (P_Sign,Origin)-        rebuild orig a mb-         = case mb of -             Just b  -> (P_Sign a b, orig)-             Nothing -> (P_Sign a a, orig)-   -   pConceptName ::   Parser Token String-   pConceptName    = pConid <|> pString--   pConceptRef ::    Parser Token P_Concept-   pConceptRef     = PCpt <$> pConceptName--   pConceptOneRef :: Parser Token P_Concept-   pConceptOneRef  = (P_Singleton <$ pKey "ONE") <|> pConceptRef--   pConceptRefPos :: Parser Token (P_Concept, Origin)-   pConceptRefPos     = conid <$> pConid_val_pos   <|>   conid <$> pString_val_pos-                        where conid :: (String, Origin) ->  (P_Concept, Origin)-                              conid (c,orig) = (PCpt c, orig)--   pConceptOneRefPos :: Parser Token (P_Concept, Origin)-   pConceptOneRefPos  = singl <$> pKey_pos "ONE"   <|>   conid <$> pConid_val_pos   <|>   conid <$> pString_val_pos-                        where singl :: Origin ->  (P_Concept, Origin)-                              singl orig     = (P_Singleton, orig)-                              conid :: (String, Origin) ->  (P_Concept, Origin)-                              conid (c,orig) = (PCpt c, orig)----  (SJ) Why does a label have (optional) strings?---  (GM) This is a binding mechanism for implementation specific properties, such as SQL/PHP plug,PHP web app,etc.---  (SJ April 15th, 2013) Since KEY has been replaced by IDENT and VIEW, there is a variant with props  (pLabelProps) and one without (pLabel).-   pLabelProps :: Parser Token Label-   pLabelProps       = lbl <$> pADLid_val_pos-                           <*> (pArgs `opt` [])-                           <*  pKey_pos ":"-                       where lbl :: (String, Origin) -> [[String]] -> Label-                             lbl (nm,pos') strs = Lbl nm pos' strs-                             pArgs = pSpec '{' *> pList1Sep (pSpec ',') (pList1 pADLid) <* pSpec '}'--   pLabel :: Parser Token Label-   pLabel       = lbl <$> pADLid_val_pos <*  pKey ":"-                  where lbl :: (String, Origin) -> Label-                        lbl (nm,pos') = Lbl nm pos' []--   pContent :: Parser Token Pairs-   pContent          = pSpec '[' *> pListSep pComma pRecord <* pSpec ']'-                   <|> pSpec '[' *> pListSep (pKey ";") pRecordObs <* pSpec ']' --obsolete-       where-       pRecord = mkPair<$> pValue <* pKey "*" <*> pValue-       pRecordObs = mkPair<$ pSpec '(' <*> pString <* pComma   <*> pString <* pSpec ')' --obsolete-   pValue :: Parser Token String-   pValue  = pAtom <|> pConid <|> pVarid <|> pInteger <|> ((++)<$>pInteger<*>pConid) <|> ((++)<$>pInteger<*>pVarid)----   pADLid :: Parser Token String-   pADLid            = pVarid <|> pConid <|> pString--   pADLid_val_pos :: Parser Token (String, Origin)-   pADLid_val_pos    = pVarid_val_pos <|> pConid_val_pos <|> pString_val_pos--   optional :: (Sequence p, Alternative p) => p a -> p (Maybe a)-   optional a        = Just <$> a <|> pSucceed Nothing---   get_tok_pos :: Token -> Origin-   get_tok_pos     (Tok _ _ s l f) = FileLoc(FilePos (f,l,s))-   get_tok_val_pos :: Token -> (String, Origin)-   get_tok_val_pos (Tok _ _ s l f) = (s,FileLoc(FilePos (f,l,s)))----   gsym_pos :: IsParser p Token => TokenType -> String -> String -> p Origin-   gsym_pos kind val' val2' = get_tok_pos <$> pSym (Tok kind val' val2' noPos "")--   gsym_val_pos :: IsParser p Token => TokenType -> String -> String -> p (String,Origin)-   gsym_val_pos kind val' val2' = get_tok_val_pos <$> pSym (Tok kind val' val2' noPos "")--   pKey_pos :: String -> Parser Token Origin-   pKey_pos keyword  =   gsym_pos TkKeyword   keyword   keyword-   pSpec_pos :: Char -> Parser Token Origin-   pSpec_pos s       =   gsym_pos TkSymbol    [s]       [s]--   pString_val_pos, pVarid_val_pos, pConid_val_pos, pAtom_val_pos ::  IsParser p Token => p (String,Origin)-   pString_val_pos    =   gsym_val_pos TkString    ""        "?STR?"-   pVarid_val_pos     =   gsym_val_pos TkVarid     ""        "?LC?"-   pConid_val_pos     =   gsym_val_pos TkConid     ""        "?UC?"-   pAtom_val_pos      =   gsym_val_pos TkAtom      ""        ""-   pKey_val_pos ::  IsParser p Token => String -> p (String,Origin)-   pKey_val_pos keyword = gsym_val_pos TkKeyword   keyword   keyword---   pSpec_val_pos ::  IsParser p Token => Char -> p (String,Origin)---   pSpec_val_pos s      = gsym_val_pos TkSymbol    [s]       [s]
− src/lib/DatabaseDesign/Ampersand/Input/ADL1/UU_BinaryTrees.hs 
@@ -1,70 +0,0 @@-module DatabaseDesign.Ampersand.Input.ADL1.UU_BinaryTrees 
-   ( BinSearchTree(..)
-   , tab2tree
-   , btFind
-   , btLocateIn
-   )
-   where
-
-   data BinSearchTree av
-    = Node (BinSearchTree av) av (BinSearchTree av)
-    | Nil
-
-
-   tab2tree :: [av] -> BinSearchTree av
-   tab2tree tab = tree
-    where
-     (tree,[]) = sl2bst (length tab) tab
-     sl2bst 0 list     = (Nil   , list)
-     sl2bst n list     
-      = let 
-         ll = (n - 1) `div` 2 ; rl = n - 1 - ll
-         (lt,a:list1) = sl2bst ll list 
-         (rt,  list2) = sl2bst rl list1
-        in (Node lt a rt, list2)
-
-
-
-   btFind :: (a -> b -> Ordering) -> BinSearchTree (a, c) -> b -> Maybe c
-   btLocateIn :: (a -> b -> Ordering) -> BinSearchTree a      -> b -> Maybe a
-   btFind     = btLookup fst snd
-   btLocateIn = btLookup id id
-   btLookup  key val cmp (Node Nil  kv Nil)
-     =  let comp = cmp (key kv)
-            r    = val kv
-        in \i -> case comp i of
-                 LT -> Nothing    
-                 EQ -> Just r
-                 GT -> Nothing 
-
-   btLookup key val cmp (Node left kv Nil) 
-     =  let comp = cmp (key kv)
-            findleft = btLookup key val cmp left
-            r    = val kv
-        in \i -> case comp i of
-                 LT -> Nothing    
-                 EQ -> Just r
-                 GT -> findleft i 
-
-   btLookup key val cmp (Node Nil kv right )
-     =  let comp      = cmp (key kv)
-            findright = btLookup key val cmp right
-            r         = val kv
-            in \i -> case comp i of
-                     LT -> findright i   
-                     EQ -> Just r
-                     GT -> Nothing 
-
-   btLookup key val cmp (Node left kv right)
-     =  let comp = cmp (key kv)
-            findleft  = btLookup key val cmp left
-            findright = btLookup key val cmp right
-            r    = val kv
-        in \i -> case comp i of
-                 LT -> findright i    
-                 EQ -> Just r
-                 GT -> findleft i
-
-   btLookup _ _ _ Nil   =  const Nothing
-
-   

− src/lib/DatabaseDesign/Ampersand/Input/ADL1/UU_Parsing.hs 
@@ -1,1142 +0,0 @@-{-# LANGUAGE RankNTypes, ExistentialQuantification, FunctionalDependencies, MultiParamTypeClasses, FlexibleInstances, FlexibleContexts #-}
-{-# LANGUAGE UndecidableInstances #-}
-module DatabaseDesign.Ampersand.Input.ADL1.UU_Parsing 
-       (parseIO,parse,getMsgs,evalSteps
-       , Steps(..),Pair(..)
-                      ,Symbol(..),pPacked
-                      ,Parser
-                      ,pList,pListSep,pList1,pList1Sep,pSym
-                      ,opt
-                      ,(<??>), (<**>), Sequence((<$>), (<$), (<*>), (<*), (*>), pSucceed )
-                      ,Alternative(..)
-                      ,IsParser
-                      ,Message(..))
---   (
---   Result,
---   mapOnePars,
---   libSucceed,
---   InputState(..),
---   OutputState(..),
---   Sequence(..),
---   Alternative(..),
---   Symbol(..),
---   SymParser(..),
---   SplitParser(..),
---   IsParser,
---   RealParser(..),
---   RealRecogn(..),
---   Either'(..),
---   ParsRec(..),
---   Message(..),
---
---   AnaParser,
---   Parser,
---   Steps(..),
---   Pair(..),
---   Exp(..),
---   pLocate,
---   pToks,
---   list_of ,
---   usealg ,
---   pMerged,
---   pLength,
---   (<||>) ,
---   pAnySym,
---   pAny ,
---   pChainl,
---   pChainl_ng,
---   pChainl_gr,
---   pChainr,
---   pChainr_ng,
---   pChainr_gr,
---   pList1Sep,
---   pList1Sep_ng,
---   pList1Sep_gr,
---   pListSep,
---   pListSep_ng,
---   pListSep_gr,
---   pList1,
---   pList1_ng,
---   pList1_gr,
---   pList,
---   pList_ng,
---   pList_gr,
---   list_alg,
---   pFoldr1Sep,
---   pFoldr1Sep_ng,
---   pFoldr1Sep_gr,
---   pFoldrSep,
---   pFoldrSep_ng,
---   pFoldrSep_gr,
---   pFoldr1,
---   pFoldr1_ng,
---   pFoldr1_gr,
---   pFoldr,
---   pFoldr_gr,
---   pFoldr_ng,
---   pPacked,
---   (<?>),
---   (<??>),
---   (<$$>),
---   (<**>),
---  -- (*>),
---  -- (<*),
---  -- (<$),
---   (<+>),
---   asOpt,
---   asList1,
---   asList,
---   opt ,
---   pExcept,
---   (<..>) ,
---   mnz,
---   acceptsepsilon,
---   p2p,pPermsSep,pPerms,add,(~$~),(~*~),
---   systemerror,
---   usererror,
---   handleEof,
---   pDynL,
---   pDynE,
---   -- getErrors,
---  -- getMsgs,
---   parse ,parsebasic,parseIO,
---   evalSteps,evalStepsIO,getMsgs,
---  -- pCostRange,
---  -- pCostSym,
---  -- pSym,
---  -- pRange,
---  -- getfirsts,
---  -- setfirsts,
---  -- (<*>),
---  -- pSucceed,
---  -- pLow,
---  -- (<$>),
---  -- (<|>),
---  -- pFail,
---   pMap,
---   pWrap,
---   val
---   )
-   where
-   import Data.Maybe
-   --import PrelGHC
-   --import IOExts
-   import System.IO.Unsafe
-   import DatabaseDesign.Ampersand.Basics  
-   import Prelude hiding (writeFile,readFile,getContents,putStr,putStrLn)
-   
-   fatal :: Int -> String -> a
-   fatal = fatalMsg "Input.ADL1.UU_Parsing"
-
-   btLookup :: BinSearchTree (a -> Ordering) (Maybe b) -> a -> Maybe b
-   tab2tree :: Ord a => [(SymbolR a,b)] -> BinSearchTree (a -> Ordering) b
-   pLocate :: (Alternative a, SymParser a b, Sequence a) => [[b]] -> a [b]
-   pToks :: (Sequence a, SymParser a b) => [b] -> a [b]
-   list_of :: Sequence a => a b -> ([c],a ([b] -> [b]),d -> d)
-   usealg :: Sequence a => (b -> c,d) -> a b -> (d,a c,e -> e)
-   pMerged :: (Symbol b, Sequence a, Alternative a, Show (Exp b), SymParser a b, SplitParser a) => c -> (d,a (d -> d),c -> d -> e) -> a e
-   (<||>) :: (Sequence a, Alternative a) => (b,a (c -> c),d -> e -> f) -> (g,a (h -> h),f -> i -> j) -> ((b,g),a ((c,h) -> (c,h)),d -> (e,i) -> j)
-   pAnySym :: (Alternative a, SymParser a b) => [b] -> a b
-   pAny :: Alternative a => (b -> a c) -> [b] -> a c
-   pChainl :: (Symbol b, SplitParser a, SymParser a b, Show (Exp b), Sequence a, Alternative a) => a (c -> c -> c) -> a c -> a c
-   pChainl_ng :: (Symbol b, SplitParser a, SymParser a b, Show (Exp b), Sequence a, Alternative a) => a (c -> c -> c) -> a c -> a c
-   pChainl_gr :: (Symbol b, SplitParser a, SymParser a b, Show (Exp b), Sequence a, Alternative a) => a (c -> c -> c) -> a c -> a c
-   pChainr :: (Symbol b, SplitParser a, SymParser a b, Show (Exp b), Sequence a, Alternative a) => a (c -> c -> c) -> a c -> a c
-   pChainr_ng :: (Symbol b, SplitParser a, SymParser a b, Show (Exp b), Alternative a, Sequence a) => a (c -> c -> c) -> a c -> a c
-   pChainr_gr :: (Symbol b, SplitParser a, SymParser a b, Show (Exp b), Sequence a, Alternative a) => a (c -> c -> c) -> a c -> a c
-   pList1Sep :: (Symbol b, SplitParser a, SymParser a b, Show (Exp b), Sequence a, Alternative a) => a c -> a d -> a [d]
-   pList1Sep_ng :: (Symbol b, SplitParser a, SymParser a b, Show (Exp b), Sequence a, Alternative a) => a c -> a d -> a [d]
-   pList1Sep_gr :: (Symbol b, SplitParser a, SymParser a b, Show (Exp b), Sequence a, Alternative a) => a c -> a d -> a [d]
-   pListSep :: (Symbol b, SplitParser a, SymParser a b, Show (Exp b), Sequence a, Alternative a) => a c -> a d -> a [d]
-   pListSep_ng :: (Symbol b, SplitParser a, SymParser a b, Show (Exp b), Alternative a, Sequence a) => a c -> a d -> a [d]
-   pListSep_gr :: (Symbol b, SplitParser a, SymParser a b, Show (Exp b), Sequence a, Alternative a) => a c -> a d -> a [d]
-   pList1 :: (Symbol b, SymParser a b, Sequence a, Show (Exp b), SplitParser a, Alternative a) => a c -> a [c]
-   pList1_ng :: (Symbol b, SymParser a b, Sequence a, Show (Exp b), SplitParser a, Alternative a) => a c -> a [c]
-   pList1_gr :: (Symbol b, SymParser a b, Sequence a, Show (Exp b), SplitParser a, Alternative a) => a c -> a [c]
-   pList :: (Symbol b, SymParser a b, Show (Exp b), SplitParser a, Sequence a, Alternative a) => a c -> a [c]
-   pList_ng :: (Symbol b, SymParser a b, Show (Exp b), SplitParser a, Sequence a, Alternative a) => a c -> a [c]
-   pList_gr :: (Symbol b, SymParser a b, Show (Exp b), SplitParser a, Sequence a, Alternative a) => a c -> a [c]
-   list_alg :: (a -> [a] -> [a],[b])
-   pFoldr1Sep :: (Symbol b, SplitParser a, SymParser a b, Show (Exp b), Sequence a, Alternative a) => (c -> d -> d,d) -> a e -> a c -> a d
-   pFoldr1Sep_ng :: (Symbol b, SplitParser a, SymParser a b, Show (Exp b), Sequence a, Alternative a) => (c -> d -> d,d) -> a e -> a c -> a d
-   pFoldr1Sep_gr :: (Symbol b, SplitParser a, SymParser a b, Show (Exp b), Sequence a, Alternative a) => (c -> d -> d,d) -> a e -> a c -> a d
-   pFoldrSep :: (Symbol b, SplitParser a, SymParser a b, Show (Exp b), Sequence a, Alternative a) => (c -> d -> d,d) -> a e -> a c -> a d
-   pFoldrSep_ng :: (Symbol b, SplitParser a, SymParser a b, Show (Exp b), Alternative a, Sequence a) => (c -> d -> d,d) -> a e -> a c -> a d
-   pFoldrSep_gr :: (Symbol b, SplitParser a, SymParser a b, Show (Exp b), Sequence a, Alternative a) => (c -> d -> d,d) -> a e -> a c -> a d
-   pFoldr1 :: (Symbol b, SymParser a b, Sequence a, Show (Exp b), SplitParser a, Alternative a) => (c -> d -> d,d) -> a c -> a d
-   pFoldr1_ng :: (Symbol b, SymParser a b, Sequence a, Show (Exp b), SplitParser a, Alternative a) => (c -> d -> d,d) -> a c -> a d
-   pFoldr1_gr :: (Symbol b, SymParser a b, Sequence a, Show (Exp b), SplitParser a, Alternative a) => (c -> d -> d,d) -> a c -> a d
-   pFoldr :: (Symbol b, SymParser a b, Show (Exp b), SplitParser a, Sequence a, Alternative a) => (c -> d -> d,d) -> a c -> a d
-   pFoldr_gr :: (Symbol b, SymParser a b, Show (Exp b), SplitParser a, Sequence a, Alternative a) => (c -> d -> d,d) -> a c -> a d
-   pFoldr_ng :: (Symbol b, SymParser a b, Show (Exp b), SplitParser a, Sequence a, Alternative a) => (c -> d -> d,d) -> a c -> a d
-   pPacked :: Sequence a => a b -> a c -> a d -> a d
-   (<?>) :: SymParser a b => a c -> String -> a c
-   (<??>) :: (Symbol b, Sequence a, Alternative a, Show (Exp b), SymParser a b, SplitParser a) => a c -> a (c -> c) -> a c
-   (<$$>) :: Sequence a => (b -> c -> d) -> a c -> a (b -> d)
-   (<**>) :: Sequence a => a b -> a (b -> c) -> a c
-   (<+>) :: Sequence a => a b -> a c -> a (b,c)
-   asOpt :: SymParser a b => Exp b -> a c -> a c
-   asList1 :: SymParser a b => Exp b -> a c -> a c
-   asList :: SymParser a b => Exp b -> a c -> a c
-   opt :: (Symbol b, SplitParser a, SymParser a b, Show (Exp b), Sequence a, Alternative a) => a c -> c -> a c
-   pExcept :: (Alternative a, SymParser a b, Eq (SymbolR b), Symbol b) => (b,b,b) -> [b] -> a b
-   (<..>) :: SymParser a b => b -> b -> a b
-   mnz :: (Symbol b, SplitParser a, SymParser a b, Show (Exp b)) => a c -> d -> d
-   acceptsepsilon :: SplitParser a => a b -> Bool
-   p2p :: (Alternative a, Sequence a) => a b -> a c -> Perms a d -> a d
-   pPermsSep :: (Alternative a, Sequence a) => a b -> Perms a c -> a c
-   pPerms :: (Alternative a, Sequence a) => Perms a b -> a b
-   add :: Sequence a => Perms a (b -> c) -> (Maybe (a b),Maybe (a b)) -> Perms a c
-   (~$~) :: (Sequence a, SplitParser a) => (b -> c) -> a b -> Perms a c
-   (~*~) :: (Sequence a, SplitParser a) => Perms a (b -> c) -> a b -> Perms a c
-   systemerror :: String -> String -> a
-   usererror :: String -> a
-   except :: Symbol a => SymbolR a -> [a] -> [SymbolR a]
-   symRS :: Ord a => SymbolR a -> a -> Ordering
-   symInRange :: Ord a => SymbolR a -> a -> Bool
-   mk_range :: Ord a => a -> a -> SymbolR a
-   mergeTables :: (Symbol a, Ord b) => [(SymbolR a,ParsRec c d b e)] -> [(SymbolR a,ParsRec c d b e)] -> [(SymbolR a,ParsRec c d b e)]
-   nat_add :: Nat -> Nat -> Nat
-   nat_min :: Nat -> Nat -> (Nat,(a,a) -> (a,a))
-   nat_le :: Nat -> Nat -> Bool
-   lib_correct :: Ord a => (b -> c -> Steps d a) -> (b -> c -> Steps d a) -> b -> c -> Steps d a
-   mkParser :: InputState a b => Maybe (Bool,Either c (ParsRec a d b c)) -> OneDescr a d b c -> AnaParser a d b c
-   mapOnePars :: (ParsRec a b c d -> ParsRec e f c g) -> (Nat -> Nat) -> OneDescr a b c d -> OneDescr e f c g
-   anaSetFirsts :: InputState a b => Exp b -> AnaParser a c b d -> AnaParser a c b d
-   anaGetFirsts :: AnaParser a b c d -> Exp c
-   pLength :: AnaParser a b c d -> Nat
-   anaCostSym :: SymParser a b => Int{-I-} -> b -> b -> a b
-   anaCostRange :: InputState a b => Int{-I-} -> b -> SymbolR b -> AnaParser a c b b
-   orOneOneDescr :: (Ord a, Ord (Exp a), Eq (SymbolR a)) => OneDescr b c a d -> OneDescr b c a d -> Bool -> OneDescr b c a d
-   seqZeroZero :: Maybe (Bool,Either a b) -> Maybe (Bool,Either c (ParsRec d e f c)) -> (a -> ParsRec d e f c -> g) -> (b -> ParsRec d e f c -> g) -> (a -> c -> h) -> Maybe (Bool,Either h g)
-   anaSeq :: (Ord (Exp a), Eq (SymbolR a), InputState b a) => (c -> ParsRec d e a f -> ParsRec b g a h) -> (ParsRec i j a c -> ParsRec d e a f -> ParsRec b g a h) -> (c -> f -> h) -> AnaParser i j a c -> AnaParser d e a f -> AnaParser b g a h
-   anaOr :: (InputState a b, Ord (Exp b), Eq (SymbolR b), Show (Exp b)) => AnaParser a c b d -> AnaParser a c b d -> AnaParser a c b d
-   anaDynN :: InputState a b => Exp b -> Nat -> SymbolR b -> TableEntry a c b d -> AnaParser a c b d
-   anaDynL :: ParsRec a b c d -> AnaParser a b c d
-   anaDynE :: ParsRec a b c d -> AnaParser a b c d
-   anaLow :: a -> AnaParser b c d a
-   anaSucceed :: a -> AnaParser b c d a
-   pEmpty :: ParsRec a b c d -> (Bool,Either d (ParsRec a b c d)) -> AnaParser a b c d
-   noOneParser :: OneDescr a b c d
-   anaFail :: AnaParser a b c d
-   traverse :: Pairs -> Pairs -> Steps a b -> Int{-I-} -> Pairs
-   libCorrect :: Ord a => Steps b a -> Steps c a -> (b -> d) -> (c -> d) -> Steps d a
-   libBest' :: Ord a => Steps b a -> Steps c a -> (b -> d) -> (c -> d) -> Steps d a
-   libBest :: Ord a => Steps b a -> Steps b a -> Steps b a
-   eor :: Ord (Exp a) => Exp a -> Exp a -> Exp a
-   addexpecting :: Ord a => Exp a -> Steps b a -> Steps b a
-   marks :: String
-   addToMessage :: Ord (Exp a) => Message a -> Exp a -> Message a
-   getStart :: Message a -> Exp a
-   getMsgs :: Steps a b -> [Message b]
-   evalStepsIO :: Symbol a => Steps b a -> IO b
-   evalSteps :: Steps a b -> a
-   hasSuccess :: Steps a b -> Bool
-   starting :: Steps a b -> Exp b
-   libFail :: ParsRec a b c d
-   libOr :: Ord a => ParsRec b c a d -> ParsRec b c a d -> ParsRec b c a d
-   libSeqR :: ParsRec a b c d -> ParsRec a e c f -> ParsRec a e c f
-   libSeqL :: ParsRec a b c d -> ParsRec a e c f -> ParsRec a b c d
-   libDollarR :: a -> ParsRec b c d e -> ParsRec b c d e
-   libDollarL :: a -> ParsRec b c d e -> ParsRec b f d a
-   libDollar :: OutputState a => (b -> c) -> ParsRec d a e b -> ParsRec d a e c
-   libSeq :: OutputState a => ParsRec b a c (d -> e) -> ParsRec b f c d -> ParsRec b f c e
-   libSucceed :: a -> ParsRec b c d a
-   libInsert :: InputState a b => Int{-I-} -> b -> Exp b -> ParsRec a c b b
-   libAccept :: InputState a b => ParsRec a c b b
-   unR :: RealRecogn a b -> (a b -> Result c b) -> a b -> Result c b
-   unP :: RealParser a b c d -> (d -> b e f -> g) -> (a c -> Result (b e f) c) -> a c -> Result g c
-   pDynN :: InputState a b => Exp b -> Nat -> SymbolR b -> TableEntry a c b d -> AnaParser a c b d
-   pDynL :: ParsRec a b c d -> AnaParser a b c d
-   pDynE :: ParsRec a b c d -> AnaParser a b c d
-   handleEof :: InputState a b => a b -> Steps (Pair (a b) c) b
-   parse :: InputState a b => AnaParser a Pair b c -> a b -> Steps (Pair c (Pair (a b) d)) b
-   parseIO :: InputState a b => AnaParser a Pair b c -> a b -> IO c
-   parsebasic :: InputState a b => ParsRec a Pair b c -> a b -> Steps (Pair c (Pair (a b) d)) b
-   parsebasic (PR ( P rp, _))
-    = rp Pair handleEof
-
-   parseIO (pp) inp
-    = do  (Pair v final) <- evalStepsIO (parsebasic (pars pp) inp) 
-          final `seq` return v -- in order to force the trailing error messages to be printed
-
-   parse (pp)
-    = parsebasic (pars pp) 
-
-   handleEof input = case splitStateE input
-                      of Left'  s  ss  ->  StRepair (deleteCost s)  (Msg ("deleting symbol " ++ show s
-                                                                         , "in unused part of input"
-                                                                         , EStr "eof"
-                                                                         )) (handleEof ss)
-                         Right' final  ->  NoMoreSteps (Pair final undefined)
-
-
-
-
-
-   infixl 2 <?>
-   infixl 3 <|>
-   infixl 4 <*>, <$> , <+>
-   infixl 4 ~*~,  ~$~
-
-   infixl 4 <$, <*, *>, <**>, <??>
-   infixl 2 `opt`
-   infixl 5 <..>
-
-
-
-
-
-   type Parser = AnaParser []  Pair 
-
-   data Pair a r = Pair a r
-
-   data Either' state s = Left' s (state s)
-                        | Right' (state s)
-
-   instance Symbol s => InputState [] s where
-    splitStateE []     = Right' []
-    splitStateE (s:ss) = Left'  s ss
-    splitState  (s:ss) = ({-L-} s, ss{-R-})
-    firstState  []     = Nothing
-    firstState  (s:ss) = Just s
-    getPosition []     = "unexpected end of input"
-    getPosition (s:ss) = "before " ++ show s
-    {-# INLINE splitStateE #-}
-    {-# INLINE splitState  #-}
-    
-   instance OutputState Pair  where
-     acceptR            = Pair
-     nextR       acc  f   ~(Pair a r) = acc  (f a) r  
-     dollarR     acc  f  v = acc  (f v)
-     {-# INLINE acceptR #-}
-     {-# INLINE nextR   #-}
-     {-# INLINE dollarR #-}
-
-   instance (Symbol s, InputState state s, OutputState result) => Sequence (AnaParser state result s)    where
-     (<*>) = anaSeq libDollar  libSeq  ($) 
-     (<* ) = anaSeq libDollarL libSeqL const
-     ( *>) = anaSeq libDollarR libSeqR (flip const) 
-     pSucceed = anaSucceed
-     pLow     = anaLow
-
-   instance (Symbol s, InputState state s, OutputState result) => Alternative (AnaParser state result s) where
-     (<|>) = anaOr
-     pFail = anaFail
-
-   instance (Symbol s, InputState state s, OutputState result) => SymParser (AnaParser state result s) s where
-     pCostRange   = anaCostRange
-     pCostSym     = anaCostSym
-     getfirsts    = anaGetFirsts
-     setfirsts    = anaSetFirsts
-
-   instance (InputState state s, OutputState result, Symbol s) => SplitParser (AnaParser state result s) where
-    getzerop  p = case zerop p of
-                    Nothing     -> Nothing
-                    Just (b,e)  -> Just p {pars=libSucceed `either` id $ e
-                                          ,onep=noOneParser
-                                          }
-    getonep   p = let tab = table (onep p)
-                  in if null tab then Nothing else Just (mkParser Nothing (onep p))
-
-   pDynE = anaDynE
-   pDynL = anaDynL
-   pDynN = anaDynN
-
-
-
-
-
-   class    (Sequence p, Alternative p, SymParser p s, SplitParser p,  Show s) => IsParser p s | p -> s
-
-   instance (Sequence p, Alternative p, SymParser p s, SplitParser p,  Show s) => IsParser p s
-
-   class Sequence p where
-     (<*>) :: p (a->b) -> p a -> p b
-     (<* ) :: p  a     -> p b -> p a
-     ( *>) :: p  a     -> p b -> p b
-     (<$>) ::   (a->b) -> p a -> p b
-     (<$ ) ::   f      -> p a -> p f
-     pSucceed :: a -> p a
-     pLow :: a -> p a
-     f <$> p = pSucceed f <*> p
-     f <$  q = pSucceed f <*  q
-     p <*  q = pSucceed       const  <*> p <*> q
-     p  *> q = pSucceed (flip const) <*> p <*> q
-
-   class Alternative p where
-     (<|>) :: p a -> p a -> p a
-     pFail :: p a
-
-   class SymParser p s | p -> s where
-    pCostRange :: Int{-I-} -> s -> SymbolR s -> p s
-    pCostSym :: Int{-I-} -> s -> s         -> p s
-    pSym ::             s         -> p s
-    pRange ::        s -> SymbolR s -> p s
-    getfirsts ::  p v -> Exp s
-    setfirsts ::  Exp s -> p v ->  p v
-    pSym a       =  pCostSym   5{-I-} a a
-    pRange       =  pCostRange 5{-I-}
-
-   class SplitParser p where
-    getzerop ::  p v -> Maybe (p v)
-    getonep ::  p v -> Maybe (p v)
-
-   class Symbol s => InputState state s where
-    splitStateE :: state s            -> Either' state s
-    splitState :: state s            -> ({-L-} s, state s {-R-})
-    firstState :: state s            -> Maybe s
-    getPosition :: state s            -> String
-
-   class OutputState r  where
-     acceptR ::                              v             -> rest        -> r v rest
-     nextR ::    (a ->     rest -> rest') -> (b -> a)      -> r b rest  -> rest'
-     dollarR ::  (a -> r c rest -> rest') -> (b -> a) -> b -> r c rest  -> rest'
-
-   class (Ord s, Show s) => Symbol s where
-    deleteCost :: s -> Int{-I-}
-    symBefore :: s -> s
-    symAfter :: s -> s
-    deleteCost b = 5{-I-}
-    symBefore  = fatal 398 "You should have made your token type an instance of the Class Symbol. eg by defining symBefore = pred"
-    symAfter   = fatal 399 "You should have made your token type an instance of the Class Symbol. eg by defining symAfter  = succ"
-
-
-
-
-
-   type Result val s = Steps val s
-
-   newtype RealParser    state result s a = P(forall r r' b. (a -> result b r -> r') ->
-                                                             (state s -> Result (result b r) s) ->  state s -> Result r' s)
-
-   newtype RealRecogn    state        s   = R(forall r     . (state s -> Result           r  s) ->  state s -> Result r  s)
-
-   newtype ParsRec       state result s a = PR  ( RealParser  state result s a
-                                                , RealRecogn  state        s
-                                                )
-
-   {-# INLINE unP #-}
-   {-# INLINE unR #-}
-   unP  (P  p) = p
-   unR  (R  p) = p
-
-
-
-
-
-   libAccept            =  PR  (P (\ acc k state ->
-                                   case splitState state of
-                                   ({-L-} s, ss {-R-})  -> OkVal (acc s) (k ss))
-                               ,R (\ k state ->
-                                   case splitState state of
-                                   ({-L-} s, ss {-R-})  ->   Ok (k ss))
-                               )
-   libInsert  c sym  firsts = PR ( P (\acc k state ->  StRepair c (Msg  ("inserting symbol " ++ show sym
-                                                                        , getPosition state
-                                                                        , firsts
-                                                                        )) (val (acc sym) (k state)))
-                                 , R (\    k state ->  StRepair c (Msg  ("inserting symbol " ++ show sym
-                                                                        , getPosition state
-                                                                        , firsts
-                                                                        ))                (k state))
-                                 )
-   {-# INLINE libSeq  #-}
-   {-# INLINE libSeqL #-}
-   {-# INLINE libSeqR #-}
-   {-# INLINE libDollar #-}
-   {-# INLINE libDollarL #-}
-   {-# INLINE libDollarR #-}
-   {-# INLINE libSucceed #-}
-
-   libSucceed v                                 = PR ( P (\ acc -> let accv = val (acc v) in \ k state -> accv (k state))
-                                                     , R id
-                                                     )
-   libSeq  (PR (P pp, R pr)) ~(PR (P qp, R qr)) = PR ( P (\ acc -> pp (nextR acc).qp acceptR)
-                                                     , R (pr.qr)
-                                                     )
-   libDollar f                (PR (P qp, R qr)) = PR ( P (\ acc -> qp (dollarR acc f))
-                                                     , R qr
-                                                     )
-   libDollarL f               (PR (P qp, R qr)) = PR ( P (\ acc -> let accf = val (acc f) in \ k -> qr (accf . k))
-                                                     , R qr
-                                                     )
-   libDollarR f               (PR (P qp, R qr)) = PR (P qp, R qr)
-
-   libSeqL (PR (P pp, R pr)) ~(PR (P qp, R qr)) = PR  ( P (\acc -> pp acc.qr)
-                                                      , R(pr.qr)
-                                                      )
-   libSeqR (PR (P pp, R pr)) ~(PR (P qp, R qr)) = PR  ( P (\acc -> pr.qp acc )
-                                                      , R(pr.qr)
-                                                      )
-   libOr   (PR (P pp, R pr))  (PR (P qp, R qr)) = PR  ( P (\ acc -> let p = pp acc
-                                                                        q = qp acc
-                                                                    in \ k state   -> p  k state `libBest` q  k state)
-                                                      , R (\             k state   -> pr k state `libBest` qr k state)
-                                                      )
-   libFail                                      = PR ( P (\ _ _  _  -> (usererror  "calling an always failing parser"    ))
-                                                     , R (\   _  _  -> (usererror  "calling an always failing recogniser"))
-                                                     )
-         
-
-
-
-
-
-   data Steps val s 
-                = forall a . OkVal           (a -> val)                             (Steps a   s)
-                |            Ok         {                                    rest :: Steps val s}
-                |            Cost       {costing::Int{-I-}                 , rest :: Steps val s}
-                |            StRepair   {costing::Int{-I-}, m :: Message s , rest :: Steps val s}
-                | forall v w.Best       (Steps v s) (Steps val s) (Exp s) ( Steps w s)
-                |            NoMoreSteps val
-   val f (OkVal a rest) = OkVal (f.a) rest
-   val f (Ok      rest) = OkVal  f rest
-   val f (Cost i  rest) = Cost i (val f rest)
-   val f (StRepair c m r) = StRepair c m (val f r)
-   val f (Best l s e r)   = Best l (val f s) e r
-   val f (NoMoreSteps v)  = NoMoreSteps (f v)
-
-   starting (StRepair _ m _ ) = getStart m
-   starting (Best _ _ s _ )   = s
-   starting _                 = systemerror "UU_Parsing" "starting"
-
-   hasSuccess (OkVal _ _ ) = True
-   hasSuccess (Ok      _ ) = True
-   hasSuccess (NoMoreSteps _) = True
-   hasSuccess (Cost i  _    ) = True
-   hasSuccess _               = False
-
-   evalSteps (OkVal v  rest    ) = v (evalSteps rest)
-   evalSteps (Ok       rest    ) =    evalSteps rest
-   evalSteps (Cost  _  rest    ) =    evalSteps rest
-   evalSteps (StRepair _ msg rest    ) =    evalSteps rest
-   evalSteps (Best _   rest _ _) =  evalSteps rest
-   evalSteps (NoMoreSteps v    ) =  v
-
-   evalStepsIO (OkVal v  rest    ) = do arg <- unsafeInterleaveIO (evalStepsIO rest)
-                                        return (v arg)
-   evalStepsIO (Ok       rest    ) = evalStepsIO rest
-
-   evalStepsIO (Cost  _  rest    ) = evalStepsIO rest
-   evalStepsIO (StRepair _ msg rest    ) = do putStr (fatal 519 (show msg)) -- was: do putStr (show msg) -- b.joosten
-                                              evalStepsIO rest
-   evalStepsIO (Best _   rest _ _) =  evalStepsIO rest
-   evalStepsIO (NoMoreSteps v    ) =  return v
-
-   getMsgs (OkVal _        rest) = getMsgs rest
-   getMsgs (Ok             rest) = getMsgs rest
-   getMsgs (Cost _         rest) = getMsgs rest
-   getMsgs (StRepair _ m   rest) = m:getMsgs rest
-   getMsgs (Best _ m _ _)        = getMsgs m
-   getMsgs (NoMoreSteps _      ) = []
-
-   newtype Message s  =  Msg (String, String, Exp s) -- action, position, expecting 
-                         deriving Eq
-   getStart (Msg (_,_,st)) = st
-
-   addToMessage (Msg (act, pos, exp)) more = Msg (act, pos, more `eor` exp)
-
-   marks = '\n':take 60 qmarks
-           where qmarks = '?':qmarks
-
-   instance Symbol s => Show (Message s) where
-    show (Msg (action, position, expecting))  
-      =  "\n" ++ position ++
-         "\nExpecting " ++ show expecting ++
-         "\nTry " ++ action ++ "\n"
-
-   addexpecting more  (StRepair    cost   msg   rest) = StRepair cost (addToMessage msg more) rest
-   addexpecting more  (Best     l    sel  starting r) = Best l (addexpecting more sel) starting r
-   addexpecting more  (OkVal v rest                 ) =  systemerror "UU_Parsing" "addexpecting: OkVal"
-   addexpecting more  (Ok   _                       ) =  systemerror "UU_Parsing" "addexpecting: Ok"
-   addexpecting more  (Cost _ _                     ) =  systemerror "UU_Parsing" "addexpecting: Cost"
-   addexpecting more  _                               =  systemerror "UU_Parsing" "addexpecting: other"
-   data Exp s = ESym (SymbolR s)
-              | EStr String
-              | EOr  [Exp s]
-              | ESeq [Exp s]
-              deriving (Ord, Eq)
-
-   eor p  q  = EOr (merge (tolist p) (tolist q))
-               where merge x@(l:ll) y@(r:rr) = case compare l r of
-                                               LT -> l:( ll `merge`  y)
-                                               GT -> r:( x  `merge` rr)
-                                               EQ -> l:( ll `merge` rr)
-                     merge l [] = l
-                     merge [] r = r
-                     tolist (EOr l) = l
-                     tolist x       = [x]
-
-   instance Symbol s => Show (Exp s) where
-    show (ESym     s)   = show s
-    show (EStr   str)   = str
-    show (EOr     [])   = "Nothing expected "
-    show (EOr    [e])   = show e
-    show (EOr  (e:ee))  = show e ++ " or " ++ show (EOr ee)
-    show (ESeq  seq)    = concatMap show seq
-
-
-
-
-
-
-   libBest ls rs = libBest' ls rs id id
-   libBest' (OkVal v ls) (OkVal w rs) lf rf = Ok (libBest' ls rs (lf.v) (rf.w))
-   libBest' (OkVal v ls) (Ok      rs) lf rf = Ok (libBest' ls rs (lf.v)  rf   )
-   libBest' (Ok      ls) (OkVal w rs) lf rf = Ok (libBest' ls rs  lf    (rf.w))
-   libBest' (Ok      ls) (Ok      rs) lf rf = Ok (libBest' ls rs  lf     rf   )
-   libBest' (OkVal v ls) _            lf rf = OkVal (lf.v) ls 
-   libBest' _            (OkVal w rs) lf rf = OkVal (rf.w) rs 
-   libBest' (Ok      ls) _            lf rf = OkVal lf ls           
-   libBest' _            (Ok      rs) lf rf = OkVal rf rs   
-   libBest' l@(Cost i ls ) r@(Cost j rs ) lf rf
-    | i =={-I-} j = Cost i (libBest' ls rs lf rf)
-    | i <{-I-} j  = Cost i (val lf ls)
-    | i >{-I-} j  = Cost j (val rf rs)
-   libBest' l@(Cost i ls)     _                 lf rf = Cost i (val lf ls)
-   libBest' _                 r@(Cost j rs)     lf rf = Cost j (val rf rs)
-   libBest' l@(NoMoreSteps v) _                 lf rf = NoMoreSteps (lf v)
-   libBest' _                 r@(NoMoreSteps w) lf rf = NoMoreSteps (rf w)
-   libBest' l                 r                 lf rf = libCorrect l r lf rf
-
-   libCorrect ls rs lf rf
-    =  let (Pairs  _ select) = traverse (traverse (Pairs 999{-I-} fst) (Pairs 0{-I-} fst) ls 4{-I-})  (Pairs 0{-I-} snd) rs 4{-I-} 
-           leftstart  = starting ls
-           rightstart = starting rs
-       in Best ls
-               (select (val lf (addexpecting rightstart ls), val rf (addexpecting leftstart rs)))
-               (leftstart `eor` rightstart)
-               rs
-
-   data Pairs = Pairs Int{-I-} (forall a. (a,a) -> a)
-   traverse b@(Pairs bv br) t@(Pairs tv tr) _                             0{-I-}  = if bv <{-I-} tv then b else t
-   traverse b@(Pairs bv br) t@(Pairs tv tr) (Ok            l)             n       = traverse b t l (n -{-I-} 1{-I-})
-   traverse b@(Pairs bv br) t@(Pairs tv tr) (OkVal  v      l)             n       = traverse b t l (n -{-I-} 1{-I-})
-   traverse b@(Pairs bv br) t@(Pairs tv tr) (Cost i   l)                  n       = if i +{-I-} tv >={-I-} bv then b else traverse b (Pairs (i +{-I-} tv) tr) l (n -{-I-} 1{-I-})
-   traverse b@(Pairs bv br) t@(Pairs tv tr) (Best l _ _ r)                n = traverse (traverse b t l n) t r n
-   traverse b@(Pairs bv br) t@(Pairs tv tr) (StRepair     i   msgs     r) n = if i +{-I-} tv >={-I-} bv then b else traverse b (Pairs (i +{-I-} tv) tr) r (n -{-I-} 1{-I-})
-   traverse b@(Pairs bv br) t@(Pairs tv tr) (NoMoreSteps _)               n = if bv <{-I-} tv then b else t
-
-
-
-
-
-   data AnaParser  state result s a
-    = AnaParser { pars :: ParsRec state result s a
-                , zerop :: Maybe (Bool, Either a (ParsRec state result s a))
-                , onep :: OneDescr state  result s a
-                } -- deriving Show
-   data OneDescr  state result s a
-    = OneDescr  { leng :: Nat
-                , firsts :: Exp s
-                , table :: [(SymbolR s, TableEntry state result s a)]
-                } -- deriving Show
-                
-   data TableEntry state result s a = TableEntry (ParsRec  state result s a) (Exp s -> ParsRec state result s a)
-
-
-
-
-
-   anaFail = AnaParser { pars    = libFail
-                       , zerop   = Nothing
-                       , onep    = noOneParser
-                       }
-   noOneParser = OneDescr Infinite (EOr []) []
-
-   pEmpty p zp = AnaParser { pars    = p
-                           , zerop   = Just zp
-                           , onep    = noOneParser
-                           }
-
-   anaSucceed  v = pEmpty (libSucceed v) (False, Left v)
-   anaLow      v = pEmpty (libSucceed v) (True,  Left v)
-   anaDynE     p = pEmpty p              (False, Right p)
-   anaDynL     p = pEmpty p              (True , Right p)
-   anaDynN  fi len range p = mkParser  Nothing (OneDescr len fi [(range, p)]) 
-
-   anaOr ld@(AnaParser _ zl ol)  rd@(AnaParser _ zr or)
-    = mkParser newZeroDescr newOneDescr
-      where newZeroDescr  = case zl of {Nothing -> zr
-                                       ;_       -> case zr of {Nothing -> zl
-                                                              ;_       -> usererror ("Two empty alternatives, where expecting"++show (firsts newOneDescr))
-                                       }                      }
-            newOneDescr   =  orOneOneDescr ol or False
-
-   {-# INLINE anaSeq #-}
-   anaSeq libdollar libseq comb (AnaParser  pl zl ol)  ~rd@(AnaParser pr zr or)
-    = case zl of
-      Just (b, zp ) -> let newZeroDescr = seqZeroZero zl zr   libdollar libseq comb
-                           newOneDescr = let newOneOne  = mapOnePars (   `libseq` pr) (const Infinite) ol
-                                             newZeroOne = case zp of
-                                                          Left  f -> mapOnePars (f `libdollar`   ) id or
-                                                          Right p -> mapOnePars (p `libseq`      ) id or
-                                         in orOneOneDescr newZeroOne newOneOne  b -- left one is shortest
-                       in mkParser newZeroDescr newOneDescr
-      _            ->  AnaParser  (pl `libseq` pr) Nothing  (mapOnePars (`libseq` pr) (`nat_add` (pLength rd)) ol)
-
-   seqZeroZero Nothing             _                    _          _      _   = Nothing
-   seqZeroZero _                   Nothing              _          _      _   = Nothing 
-   seqZeroZero (Just (llow, left)) (Just (rlow, right))  libdollar libseq comb
-       = Just      ( llow || rlow
-                  , case left of
-                    Left  lv  -> case right of
-                                 Left  rv -> Left (comb lv rv)
-                                 Right rp -> Right (lv `libdollar` rp)
-                    Right lp  -> case right of
-                                 Left  rv  -> Right (lp `libseq` libSucceed rv)
-                                 Right rp  -> Right (lp `libseq` rp)
-                  )
-
-   orOneOneDescr ~(OneDescr ll fl tl) ~(OneDescr lr fr tr)  b
-                     = let newfirsts       = (fl `eor` fr) 
-                           (newlength, maybeswap) = ll `nat_min` lr
-                           (tla, tra)      = if b then (tl, tr) else maybeswap (tl, tr)
-                           keystr          = map fst tra
-                           lefttab         = if b then [r | r@(k,_) <- tla, k `notElem` keystr] else tla
-                       in OneDescr newlength (fl `eor` fr) (lefttab ++ tra)
-
-   anaCostRange _        _     EmptyR = anaFail
-   anaCostRange ins_cost ins_sym range
-     = mkParser Nothing ( OneDescr (Succ Zero) (ESym range) [(range, TableEntry  libAccept 
-                                                                                 (libInsert ins_cost ins_sym)
-                                                            )]) 
-
-   anaCostSym   i ins sym = pCostRange i ins (Range sym sym)
-
-   pLength (AnaParser _ (Just _)  _ ) = Zero
-   pLength (AnaParser _  Nothing  od) = leng od
-
-   anaGetFirsts (AnaParser  p z od) = firsts od
-
-   anaSetFirsts newexp (AnaParser  _ zd od)
-    = mkParser zd (od{firsts = newexp })
-
-
-
-
-
-   mapOnePars fp fl ~(OneDescr l fi t) = OneDescr (fl l) fi [ (k, TableEntry (fp p) (fp.corr))
-                                                            | (k, TableEntry     p      corr ) <- t
-                                                            ]
-
-
-
-
-
-   mkParser  zd ~descr@(OneDescr _ firsts tab) -- pattern matching should be lazy for lazy computation of length for empty parsers
-    = let parstab    = if null tab then fatal 726 "parstab undefined" else
-                       foldr1 mergeTables  [[(k, p)] | (k, TableEntry p _) <- tab]
-          mkactualparser getp 
-            = let find       = case  parstab of
-                               [(ran,  pp)]     -> let comp = symInRange ran
-                                                       pars = Just (getp pp) 
-                                                   in \ s -> if comp s then pars else Nothing
-                               _           -> btLookup.tab2tree $  [(k,Just (getp pr) ) | (k, pr) <- parstab]
-                  zerop      = getp (case zd of
-                                    Nothing           -> libFail
-                                    Just (_, Left v)  -> libSucceed v
-                                    Just (_, Right p) -> p
-                                    ) 
-                  insertsyms = if null tab then fatal 739 "insertsyms undefined" else
-                               foldr1 lib_correct [   getp (pr firsts) | (_ , TableEntry _ pr) <- tab    ]
-                  correct k inp
-                    = case splitState inp of
-                          ({-L-} s, ss {-R-}) -> libCorrect (StRepair(deleteCost s) (Msg  ("deleting symbol " ++ show s
-                                                                                          , getPosition inp
-                                                                                          , firsts
-                                                                                    )     ) (result k ss)) 
-                                                            (insertsyms k inp) id id
-                  result = if null tab then zerop
-                           else case zd of
-                           Nothing        ->(\k inp -> case splitStateE inp of
-                                                       Left' s ss -> case find s of 
-                                                                     Just p  ->  p k inp
-                                                                     Nothing -> correct k inp
-                                                       Right' _   -> insertsyms   k inp)
-                           Just (True, _) ->(\k inp -> case splitStateE inp of
-                                                       Left' s ss -> case find s of 
-                                                                     Just p  -> p k inp 
-                                                                     Nothing -> let r = zerop k inp 
-                                                                                in if hasSuccess r then r else libCorrect r (correct k inp) id id
-                                                       Right' _   -> zerop k inp)
-                           Just (False, _) ->(\k inp -> case splitStateE inp of
-                                                       Left' s ss -> case find s of 
-                                                                     Just p  -> p k inp `libBest` zerop k inp
-                                                                     Nothing -> let r = zerop k inp 
-                                                                                in if hasSuccess r then r else libCorrect r (correct k inp) id id
-                                                       Right' _   -> zerop k inp)
-              in result
-          res    = PR (P ( \ acc ->  mkactualparser (\ (PR (P p, _)) -> p acc))
-                      ,R (           mkactualparser (\ (PR (_, R p)) -> p    ))
-                      )            
-      in AnaParser res zd descr
-      
-   lib_correct p q k inp = libCorrect (p k inp) (q k inp) id id
-
-
-
-
-
-   data Nat = Zero
-            | Succ Nat
-            | Infinite
-            deriving (Eq, Show)
-
-   nat_le Zero      _        = True
-   nat_le _         Zero     = False
-   nat_le Infinite  _        = False
-   nat_le _         Infinite = True
-   nat_le (Succ l) (Succ r) = nat_le l r
-
-   nat_min Infinite   r          = (r, swap) where swap (a,b) = (b,a)
-   nat_min l          Infinite   = (l, id)
-   nat_min Zero       _          = (Zero, id)
-   nat_min _          Zero       = (Zero, swap) where swap (a,b) = (b,a)
-   nat_min (Succ ll)  (Succ rr)  = let (v, fl) = ll `nat_min` rr in (Succ v, fl)
-
-   nat_add Infinite  _ = Infinite
-   nat_add Zero      r = r
-   nat_add (Succ l)  r = Succ (nat_add l r)
-
-
-
-
-
-   mergeTables l []  = l
-   mergeTables [] r  = r
-   mergeTables lss@(l@(le@(Range a b),ct ):ls) rss@(r@(re@(Range c d),ct'):rs)
-    = let ct'' =  ct `libOr` ct'
-      in  if      c<a then   mergeTables rss lss     -- swap
-          else if b<c then l:mergeTables ls  rss     -- disjoint case
-          else if a<c then (Range a (symBefore c),ct) :mergeTables ((Range c b,ct):ls)             rss
-          else if b<d then (Range a b,ct'')           :mergeTables ((Range (symAfter b) d,ct'):rs) ls
-          else if b>d then mergeTables rss lss
-                      else (le,ct'') : mergeTables ls rs-- equals
-
-
-
-
-
-   libMap ::    (forall r r'' . (b -> r -> r'') -> state s -> Result (a, r) s -> ( state s, Result  r'' s)) 
-             -> (forall r      .                   state s -> Result     r  s -> ( state s, Result  r   s))
-             -> ParsRec state result s a -> ParsRec state result s b
-   libMap f f' (PR (P p, R r))       = PR ( P(\acc -> let pp   = p (,)
-                                                          facc = f acc 
-                                                      in \ k instate  -> let inresult = pp k outstate
-                                                                             (outstate, outresult) = facc instate inresult
-                                                                         in outresult
-                                             )
-                                          , R(\ k instate  -> let inresult = r k outstate
-                                                                  (outstate, outresult) = f' instate inresult
-                                                              in outresult)
-                                          )
-
-   pMap ::    OutputState result =>
-                (forall r r'' . (b -> r -> r'') -> state s -> Result (a, r) s -> ( state s, Result r'' s)) 
-             -> (forall r     .                    state s -> Result     r  s -> ( state s, Result r   s))
-             ->  AnaParser state result s a -> AnaParser state result s b
-
-   pMap f f'  (AnaParser p z o) = AnaParser (libMap f f' p)
-                                             (case z of
-                                              Nothing     -> Nothing
-                                              Just (b, v) -> Just (b, case v of
-                                                                      Left w   -> Right (libMap f f' (libSucceed w))
-                                                                      Right pp -> Right (libMap f f' pp)))
-                                             (mapOnePars (libMap f f') id o)
-   libWrap ::    (forall r r'' .   (b -> r -> r'') 
-                                       -> state s 
-                                       -> Result (a, r) s 
-                                       -> (state s -> Result r s) 
-                                       -> (state s, Result r'' s, state s -> Result r s))
-              -> (forall r         .   state s 
-                                   -> Result r  s 
-                                   -> (state s -> Result r s) 
-                                   -> (state s, Result r s, state s -> Result r s)) 
-              -> ParsRec state result s a -> ParsRec state result s b
-   libWrap f f' (PR (P p, R r)) = PR ( P(\ acc -> let pp = p (,)
-                                                      facc = f acc
-                                                  in \ k instate  -> let (stl, ar, str2rr) = facc instate rl k
-                                                                         rl                = pp str2rr stl
-                                                                     in  ar
-                                        )
-                                     , R(\ k instate  -> let (stl, ar, str2rr) = f' instate rl k
-                                                             rl                = r str2rr stl
-                                                         in  ar)
-                                     )
-
-   pWrap ::    OutputState result 
-              => (forall r  r''.   (b -> r -> r'') 
-                                       -> state s 
-                                       -> Result (a, r) s 
-                                       -> (state s -> Result r s) 
-                                       -> (state s, Result r'' s, state s -> Result r s))
-              -> (forall r         .   state s 
-                                   -> Result r s 
-                                   -> (state s -> Result r s) 
-                                   -> (state s, Result r s, state s -> Result r s)) 
-              -> AnaParser state result s a -> AnaParser state result s b
-
-   pWrap f f'  (AnaParser p z o) = AnaParser (libWrap f f' p)
-                                             (case z of
-                                              Nothing     -> Nothing
-                                              Just (b, v) -> Just (b, case v of
-                                                                      Left w   -> Right (libWrap f f' (libSucceed w))
-                                                                      Right pp -> Right (libWrap f f' pp)))
-                                             (mapOnePars (libWrap f f') id o)
-
-
-
-
-
-   data  SymbolR s  =  Range s s | EmptyR deriving (Eq,Ord)
-
-   instance Symbol s => Show (SymbolR s) where
-    show EmptyR      = "the empty range"
-    show (Range a b) = if a == b then show a else show a ++ ".." ++ show b
-
-   mk_range             l    r =  if l > r then EmptyR else Range l r
-
-   symInRange (Range l r) = if l == r then (l==)
-                                      else (\ s -> not (s < l || r < s ))
-
-   symRS (Range l r)
-     = if l == r then (compare l)
-       else (\ s -> if      s < l then GT
-                    else if s > r then LT
-                    else               EQ)
-
-   range `except` elems
-    = foldr removeelem [range] elems
-      where removeelem elem ranges = [r | ran <- ranges, r <- ran `minus` elem]
-            EmptyR          `minus` _    = []
-            ran@(Range l r) `minus` elem = if symInRange ran elem
-                                           then [mk_range l (symBefore elem), mk_range (symAfter elem) r]
-                                           else [ran]
-
-
-
-
-
-   usererror   m = fatal 917 $ "Your grammar contains a problem:\n" ++ m
-   systemerror modname m
-     = fatal 919 $ "I apologise: I made a mistake in my design. This should not have happened.\n" ++
-                   " Please report: " ++ modname ++": " ++ m ++ " to doaitse@cs.uu.nl\n"
-
-
-
-
-
-   newtype Perms p a = Perms (Maybe (p a), [Br p a])
-   data Br p a = forall b. Br (Perms p (b -> a)) (p b)
-
-   perms ~*~ p = perms `add` (getzerop p, getonep p)
-   f     ~$~ p = Perms (Just (pLow f), []) ~*~ p
-
-   add b2a@(Perms (eb2a, nb2a)) bp@(eb, nb)
-    =  let changing :: Sequence a => (b -> c) -> Perms a b -> Perms a c
-           f `changing` Perms (ep, np) = Perms (fmap (f <$>) ep, [Br ((f.) `changing` pp) p | Br pp p <- np])
-       in Perms
-         ( do { f <- eb2a
-              ; x <- eb
-              ; return (f <*>  x)
-              }
-         ,  (case nb of
-             Nothing     -> id
-             Just pb     -> (Br b2a  pb:)
-           )[ Br ((flip `changing` c) `add`  bp) d |  Br c d <- nb2a]
-         )
-
-   pPerms (Perms (empty,nonempty))
-    = foldl (<|>) (fromMaybe pFail empty) [ (flip ($)) <$> p <*> pPerms pp
-                                          | Br pp  p <- nonempty
-                                          ]
-
-   pPermsSep  = p2p (pSucceed ()) 
-
-   p2p fsep sep (Perms (mbempty, nonempties)) = foldr (<|>) empty (map pars nonempties)
-    where empty      = fromMaybe  pFail mbempty
-          pars (Br t p)  = flip ($) <$ fsep <*> p <*> p2p sep sep t
-
-
-
-
-
-   acceptsepsilon p       = case getzerop p of {Nothing -> False; _ -> True}
-
-   mnz p v
-      = if( acceptsepsilon p)
-        then   usererror ("You are calling a list based derived combinator with a parser that accepts the empty string.\n"
-                       ++
-                      "We cannot handle the resulting left recursive formulation (and it is ambiguous too).\n"++
-                      (case getfirsts p of
-                       ESeq []  ->  "There are no other alternatives for this parser"
-                       d        ->  "The other alternatives of this parser may start with:\n"++ show d
-                     ))
-        else v
-
-
-
-
-
-   a <..> b   = pRange a (Range a b)
-   (l,r,err) `pExcept` elems = let ranges = filter (/= EmptyR) (Range l r `except` elems)
-                               in if null ranges then pFail
-                                  else foldr (<|>) pFail (map (pRange err) ranges)
-
-   p `opt` v       = mnz p (p  <|> pLow v)   -- note that opt is greedy, if you do not want this
-                                                 -- use "... <|> pSucceed v"  instead
-                                                 -- p should not recognise the empty string
-
-
-
-
-
-   asList  exp = setfirsts (ESeq [EStr "(",  exp, EStr  " ...)*"])
-   asList1 exp = setfirsts (ESeq [EStr "(",  exp, EStr  " ...)+"])
-   asOpt   exp = setfirsts (ESeq [EStr "( ", exp, EStr  " ...)?"])
-   pa <+> pb       = (,) <$> pa <*> pb
-   p <**> q        = (\ x f -> f x) <$> p <*> q
-   f <$$> p        = pSucceed (flip f) <*> p
-   p <??> q        = p <**> (q `opt` id)
-   p <?>  str      = setfirsts  (EStr str) p
-   pPacked l r x   =   l *>  x <*   r
-
-
-
-
-
-   pFoldr_ng      alg@(op,e)     p = mnz p (asList (getfirsts p) pfm)
-                                     where pfm = (op <$> p <*> pfm)  <|> pSucceed e
-   pFoldr_gr      alg@(op,e)     p = mnz p (asList (getfirsts p) pfm)
-                                     where pfm = (op <$> p <*> pfm) `opt` e
-   pFoldr                          = pFoldr_gr
-
-   pFoldr1_gr     alg@(op,e)     p = asList1 (getfirsts p) (op <$> p <*> pFoldr_gr  alg p)
-   pFoldr1_ng     alg@(op,e)     p = asList1 (getfirsts p) (op <$> p <*> pFoldr_ng  alg p)
-   pFoldr1                         = pFoldr1_gr
-
-   pFoldrSep_gr   alg@(op,e) sep p = mnz p (asList (getfirsts p)((op <$> p <*> pFoldr_gr alg (sep *> p)) `opt` e ))
-   pFoldrSep_ng   alg@(op,e) sep p = mnz p (asList (getfirsts p)((op <$> p <*> pFoldr_ng alg (sep *> p))  <|>  pSucceed e))
-   pFoldrSep                       = pFoldrSep_gr
-
-   pFoldr1Sep_gr  alg@(op,e) sep p = if acceptsepsilon sep then mnz p pfm else pfm
-                                     where pfm = op <$> p <*> pFoldr_gr alg (sep *> p)
-   pFoldr1Sep_ng  alg@(op,e) sep p = if acceptsepsilon sep then mnz p pfm else pfm
-                                     where pfm = op <$> p <*> pFoldr_ng alg (sep *> p)
-   pFoldr1Sep                      = pFoldr1Sep_gr
-
-   list_alg = ((:), [])
-
-   pList_gr        = pFoldr_gr     list_alg  
-   pList_ng        = pFoldr_ng     list_alg  
-   pList           = pList_gr
-
-   pList1_gr       = pFoldr1_gr    list_alg  
-   pList1_ng       = pFoldr1_ng    list_alg  
-   pList1          = pList1_gr               
-
-   pListSep_gr     = pFoldrSep_gr  list_alg
-   pListSep_ng     = pFoldrSep_ng  list_alg
-   pListSep        = pListSep_gr
-
-   pList1Sep_gr    = pFoldr1Sep_gr list_alg
-   pList1Sep_ng    = pFoldr1Sep_ng list_alg
-   pList1Sep       = pList1Sep_gr
-
-   pChainr_gr op x    =  if acceptsepsilon op then mnz x r else r
-                      where r = x <??> (flip <$> op <*> r)
-   pChainr_ng op x    =  if acceptsepsilon op then mnz x r else r
-                      where r = x <**> ((flip <$> op <*> r)  <|> pSucceed id)
-   pChainr            = pChainr_gr
-
-   pChainl_gr op x    =  if acceptsepsilon op then mnz x r else r
-                         where
-                          r      = (f <$> x <*> pList_gr (flip <$> op <*> x) )
-                          f x [] = x
-                          f x (func:rest) = f (func x) rest
-
-   pChainl_ng op x    =  if acceptsepsilon op then mnz x r else r
-                      where
-                       r      = (f <$> x <*> pList_ng (flip <$> op <*> x) )
-                       f x [] = x
-                       f x (func:rest) = f (func x) rest
-   pChainl            = pChainl_gr
-
-   pAny  f l = if null l then usererror "pAny: argument may not be empty list" else foldr1 (<|>) (map f l)
-   pAnySym   = pAny pSym -- used to be called pAnySym
-
-
-
-
-
-
-   (pe, pp, punp) <||> (qe, qp, qunp)
-    =( (pe, qe)
-     , (\f (pv, qv) -> (f pv, qv)) <$> pp
-                 <|>
-       (\f (pv, qv) -> (pv, f qv)) <$> qp
-     , \f (x, y) -> qunp (punp f x) y
-     )
-
-   sem `pMerged` (units, alts, unp)
-    = let pres = alts <*> pres `opt` units
-      in unp sem <$> pres
-
-   usealg (op, e) p = (e, op <$> p, id)
-   list_of = usealg list_alg
-
-   pToks []     = pSucceed []
-   pToks (a:as) = (:) <$> pSym a <*> pToks as
-
-   pLocate = pAny pToks
-
-
-
-
-
-   data BinSearchTree a b
-    = Node (BinSearchTree a b) (a, b) (BinSearchTree a b)
-    | Nil
-
-   tab2tree tab = tree
-    where
-     (tree,[]) = sl2bst (length tab) [ (symRS k, v) | (k, v) <- tab]
-     sl2bst 0 list     = (Nil   , list)
-     sl2bst n list
-      = let
-         ll = (n - 1) `div` 2 ; rl = n - 1 - ll
-         (lt,a:list1) = sl2bst ll list
-         (rt,  list2) = sl2bst rl list1
-        in (Node lt a rt, list2)
-
-
-
-   btLookup
-    = find_in
-      where find_in  Nil = \i -> Nothing
-            find_in (Node Nil (k,v) Nil)
-             = (\i -> case k i of    { LT -> Nothing
-                                     ; EQ ->  v
-                                     ; GT -> Nothing
-                                     })
-            find_in (Node Nil (k,v) right)
-             = (\i -> case k i of    { LT -> findright i
-                                     ; EQ ->  v
-                                     ; GT -> Nothing
-                                     })
-               where findright = find_in right
-            find_in (Node left (k,v) Nil)
-             = (\i -> case k i of    { LT -> Nothing
-                                     ; EQ -> v
-                                     ; GT -> findleft  i
-                                     })
-               where findleft  = find_in left
-            find_in (Node left (k,v) right)
-             = (\i -> case k i of    { LT -> findright i
-                                     ; EQ -> v
-                                     ; GT -> findleft  i
-                                     })
-               where findleft  = find_in left
-                     findright = find_in right

− src/lib/DatabaseDesign/Ampersand/Input/ADL1/UU_Scanner.hs 
@@ -1,363 +0,0 @@-{-# LANGUAGE FlexibleContexts, MultiParamTypeClasses #-}
-module DatabaseDesign.Ampersand.Input.ADL1.UU_Scanner where
-
-   import Data.Char
-   import Data.List
-   import Data.Maybe
-   import DatabaseDesign.Ampersand.Input.ADL1.UU_BinaryTrees(tab2tree,btLocateIn)
-   import DatabaseDesign.Ampersand.Input.ADL1.UU_Parsing(Symbol(..),IsParser,pSym,(<$>),pListSep,pPacked)
-
-   data TokenType
-     = TkSymbol
-     | TkVarid
-     | TkConid
-     | TkKeyword
-     | TkOp
-     | TkString
-     | TkExpl
-     | TkAtom
-     | TkChar
-     | TkInteger8
-     | TkInteger10
-     | TkInteger16
-     | TkTextnm
-     | TkTextln
-     | TkSpace
-     | TkError
-     deriving (Eq, Ord)
-
-   type Line = Int
-   type Column = Int
-
-   data Pos = Pos{line:: !Line, column:: !Column} deriving (Eq, Ord)
-   type Filename   = String
-
-   data Token = Tok { tp :: TokenType
-                    , val1 :: String
-                    , val2 :: String
-                    , pos :: !Pos
-                    , file :: !Filename
-                    }
-
-   instance Eq Token where
-     --(Tok TkOp       ""      l _ _) ==  (Tok TkOp       ""      r _ _) =  l == r
-     --(Tok TkOp       ""      l _ _) ==  (Tok TkOp       r       _ _ _) =  l == r
-     --(Tok TkOp       l       _ _ _) ==  (Tok TkOp       ""      r _ _) =  l == r
-     (Tok ttypel     stringl _ _ _) ==  (Tok ttyper     stringr _ _ _) =  ttypel == ttyper && stringl == stringr
-
-   instance   Ord Token where
-     compare x y | x==y      = EQ
-                 | x<=y      = LT
-                 | otherwise = GT
-     (Tok ttypel     stringl _ _ _ ) <= (Tok ttyper    stringr _ _  _ )
-         =     ttypel <  ttyper
-           || (ttypel == ttyper && stringl <= stringr)
-
-   maybeshow :: Pos -> Filename -> String
-   maybeshow (Pos 0 0) fn =  ""
-   maybeshow (Pos l c) fn =  " at line " ++ show l
-                          ++ ", column " ++ show c
-                          ++ " of file " ++ show fn
-
-   initPos :: Pos
-   initPos = Pos 1 1
-
-   noPos :: Pos
-   noPos = Pos 0 0
-
-   advl ::  Line -> Pos ->Pos
-   advl i (Pos l c) = Pos (l+i) 1
-
-   advc :: Column -> Pos ->  Pos
-   advc i (Pos l c) = Pos l (c+i)
-
-   adv :: Pos -> Char -> Pos
-   adv pos c = case c of
-     '\t' -> advc (tabWidth (column pos)) pos
-     '\n' -> advl 1 pos
-     _    -> advc 1 pos
-
-   tabWidth :: Column -> Int
-   tabWidth c = 8 - ((c-1) `mod` 8)
-
-   instance Show Token where
-     showsPrec _ token
-       = showString
-          (case token of
-           (Tok TkSymbol    _  s2 i fn)  -> "symbol "                ++ s2         ++ maybeshow i fn
-           (Tok TkOp        _  s2 i fn)  -> "operator "              ++ s2         ++ maybeshow i fn
-           (Tok TkKeyword   _  s2 i fn)  ->                        show s2         ++ maybeshow i fn
-           (Tok TkString    _  s2 i fn)  -> "string \""              ++ s2 ++ "\"" ++ maybeshow i fn
-           (Tok TkExpl      _  s2 i fn)  -> "explanation {+"         ++ s2 ++ "-}" ++ maybeshow i fn
-           (Tok TkAtom      _  s2 i fn)  -> "atom '"                 ++ s2 ++ "'"  ++ maybeshow i fn
-           (Tok TkChar      _  s2 i fn)  -> "character '"            ++ s2 ++ "'"  ++ maybeshow i fn
-           (Tok TkInteger8  _  s2 i fn)  -> "octal integer "         ++ s2         ++ maybeshow i fn
-           (Tok TkInteger10 _  s2 i fn)  -> "decimal Integer "       ++ s2         ++ maybeshow i fn
-           (Tok TkInteger16 _  s2 i fn)  -> "hexadecimal integer "   ++ s2         ++ maybeshow i fn
-           (Tok TkVarid     _  s2 i fn)  -> "lower case identifier " ++ s2         ++ maybeshow i fn
-           (Tok TkConid     _  s2 i fn)  -> "upper case identifier " ++ s2         ++ maybeshow i fn
-           (Tok TkTextnm    _  s2 i fn)  -> "text name "             ++ s2         ++ maybeshow i fn
-           (Tok TkTextln    _  s2 i fn)  -> "text line "             ++ s2         ++ maybeshow i fn
-           (Tok TkSpace     _  s2 i fn)  -> "spaces "                              ++ maybeshow i fn
-           (Tok TkError     _  s2 i fn)  -> "error in scanner: "     ++ s2         ++ maybeshow i fn
-          )
-
-   instance  Symbol Token where
-     deleteCost (Tok TkKeyword _ _ _ _) = 10
-     deleteCost _                       = 5
-
-   keyToken,token :: TokenType -> String -> Pos -> Filename -> Token
-   keyToken tp key  = Tok tp key key
-   token  tp  = Tok tp ""  
-
-   errToken :: String -> Pos -> Filename -> Token
-   errToken = token TkError
-
-   skipline s = let (_,rest) = span (/='\n') s
-                in  rest
-
-   scan :: [String] -> [String] -> String -> String -> String -> Pos -> String -> [Token]
-   scan keywordstxt keywordsops specchars opchars fn pos input
-     = doScan pos input
-
-    where
-      locatein :: Ord a => [a] -> a -> Bool
-      locatein es = isJust . btLocateIn compare (tab2tree (sort es))
-      iskw     = locatein keywordstxt
-      isop     = locatein keywordsops
-      isSymbol = locatein specchars
-      isOpsym  = locatein opchars
-
-      isIdStart c = isLower c || c == '_'
-
-      isIdChar c =  isAlphaNum c
---               || c == '\''   -- character literals are not used in Ampersand. Since this scanner was used for Haskell-type languages, this alternative is commented out...
-                 || c == '_'
-
-      scanIdent p s = let (name,rest) = span isIdChar s
-                      in (name,advc (length name) p,rest)
-      doScan p [] = []
-      doScan p (c:s)        | isSpace c = let (sp,next) = span isSpace s
-                                          in  doScan (foldl adv p (c:sp)) next
-
-      doScan p ('-':'-':s)  = doScan p (dropWhile (/= '\n') s)
-      doScan p ('-':'+':s)  = token TkExpl (dropWhile isSpace (takeWhile (/= '\n') s)) p fn
-                              : doScan p (dropWhile (/= '\n') s)
-      doScan p ('{':'-':s)  = lexNest fn doScan (advc 2 p) s
-      doScan p ('{':'+':s)  = lexExpl fn doScan (advc 2 p) s
-      doScan p ('"':ss)
-        = let (s,swidth,rest) = scanString ss
-          in if null rest || head rest /= '"'
-                then errToken "Unterminated string literal" p fn : doScan (advc swidth p) rest
-                else token TkString s p fn : doScan (advc (swidth+2) p) (tail rest)
-{- In Ampersand, atoms may be promoted to singleton relations by single-quoting them. For this purpose, we treat
-   single quotes exactly as the double quote for strings. That substitutes the scanner code for character literals. -}
-      doScan p ('\'':ss)
-        = let (s,swidth,rest) = scanAtom ss
-          in if null rest || head rest /= '\''
-                then errToken "Unterminated atom literal" p fn : doScan (advc swidth p) rest
-                else token TkAtom s p fn : doScan (advc (swidth+2) p) (tail rest)
-
-{- character literals are not used in Ampersand.  doScan p ('\'':ss) is commented out to make room for singleton atoms.
-      doScan p ('\'':ss)
-        = let (mc,cwidth,rest) = scanChar ss
-          in case mc of
-               Nothing -> errToken "Error in character literal" p fn : doScan (advc cwidth p) rest
-               Just c  -> if null rest || head rest /= '\''
-                             then errToken "Unterminated character literal" p fn : doScan (advc (cwidth+1) p) rest
-                             else token TkChar [c] p fn : doScan (advc (cwidth+2) p) (tail rest)
--}
-
-      -- In Haskell infix identifiers consist of three separate tokens(two backquotes + identifier)
-      doScan p ('`':ss)
-        = case ss of
-            []    -> [errToken "Unterminated infix identifier" p fn]
-            (c:s) -> let res | isIdStart c || isUpper c =
-                                      let (name,p1,rest) = scanIdent (advc 2 p) s
-                                          ident = c:name
-                                          tokens | null rest ||
-                                                   head rest /= '`' = errToken "Unterminated infix identifier" p fn
-                                                                    : doScan p1 rest
-                                                 | iskw ident       = errToken ("Keyword used as infix identifier: " ++ ident) p fn
-                                                                    : doScan (advc 1 p1) (tail rest)
-                                                 | otherwise        = token TkOp ident p fn
-                                                                    : doScan (advc 1 p1) (tail rest)
-                                      in tokens
-                             | otherwise = errToken ("Unexpected character in infix identifier: " ++ show c) p fn
-                                         : doScan (adv p c) s
-                     in res
-      doScan p cs@(c:s)
-        | isSymbol c = keyToken TkSymbol [c] p fn
-                     : doScan(advc 1 p) s
-        | isIdStart c || isUpper c
-            = let (name', p', s')    = scanIdent (advc 1 p) s
-                  name               = c:name'
-                  tok    | iskw name = keyToken TkKeyword name p fn
-                         | null name' && isSymbol c
-                                     = keyToken TkSymbol [c] p fn
-                         | otherwise = token (if isIdStart c then TkVarid else TkConid) name p fn
-              in tok :  doScan p' s'
-        | isOpsym c = let (name, s') = getOp cs   -- was:      span isOpsym cs
-                          tok | isop name = keyToken TkKeyword name p fn
-                              | otherwise = keyToken TkOp name p fn
-                      in tok : doScan (foldl adv p name) s'
-        | isDigit c = let (tktype,number,width,s') = getNumber cs
-                      in  token tktype number p fn : doScan (advc width p) s'
-        | otherwise = errToken ("Unexpected character " ++ show c) p fn
-                    : doScan (adv p c) s
-
-      getOp cs -- the longest prefix of cs occurring in keywordsops
-       = f keywordsops cs ""
-         where
-          f ops (e:s) op = if null [s | o:s<-ops, e==o] then (op,e:s) --was: f ops (e:s) op = if and (map null ops) then (op,e:s) --b.joosten
-                           else f [s | o:s<-ops, e==o] s (op++[e])
-          f [] es op     = ("",cs)
-          f ops [] op    = (op,[])
-
-
-
-   lexNest fn cont pos inp = lexNest' cont pos inp
-    where lexNest' c p ('-':'}':s) = c (advc 2 p) s
-          lexNest' c p ('{':'-':s) = lexNest' (lexNest' c) (advc 2 p) s
-          lexNest' c p (x:s)       = lexNest' c (adv p x) s
-          lexNest' _ _ []          = [ errToken "Unterminated nested comment" pos fn ]
-
-   lexExpl fn cont pos inp = lexExpl' "" cont pos inp
-    where lexExpl' str c p ('-':'}':s) = token TkExpl str p fn: c (advc 2 p) s
-          lexExpl' str c p ('{':'-':s) = lexNest fn (lexExpl' str c) (advc 2 p) s
-          lexExpl' str c p ('-':'-':s) = lexExpl' str c  p (dropWhile (/= '\n') s)
-          lexExpl' str c p (x:s)       = lexExpl' (str++[x]) c (adv p x) s
-          lexExpl' _ _ _ []            = [ errToken "Unterminated PURPOSE section" pos fn ]
-
-   scanString []            = ("",0,[])
-   scanString ('\\':'&':xs) = let (str,w,r) = scanString xs
-                              in (str,w+2,r)
-   scanString ('\'':xs)     = let (str,w,r) = scanString xs
-                              in ('\'': str,w+1,r)
-   scanString xs = let (ch,cw,cr) = getchar xs
-                       (str,w,r)  = scanString cr
---                       str' = maybe "" (:str) ch
-                   in maybe ("",0,xs) (\c -> (c:str,cw+w,r)) ch
-
-   scanAtom []              = ("",0,[])
-   scanAtom ('\\':'&':xs)   = let (str,w,r) = scanAtom xs
-                              in (str,w+2,r)
-   scanAtom ('"':xs)        = let (str,w,r) = scanAtom xs
-                              in ('"': str,w+1,r)
-   scanAtom xs   = let (ch,cw,cr) = getchar xs
-                       (str,w,r)  = scanAtom cr
---                       str' = maybe "" (:str) ch
-                   in maybe ("",0,xs) (\c -> (c:str,cw+w,r)) ch
-
-   scanChar ('"' :xs) = (Just '"',1,xs)
-   scanChar xs        = getchar xs
-
-   getchar []          = (Nothing,0,[])
-   getchar s@('\n':_ ) = (Nothing,0,s )
-   getchar s@('\t':_ ) = (Nothing,0,s)
-   getchar s@('\'':_ ) = (Nothing,0,s)
-   getchar s@('"' :_ ) = (Nothing,0,s)
-   getchar   ('\\':xs) = let (c,l,r) = getEscChar xs
-                         in (c,l+1,r)
-   getchar (x:xs)      = (Just x,1,xs)
-
-   getEscChar [] = (Nothing,0,[])
-   getEscChar s@(x:xs) | isDigit x = let (tp,n,len,rest) = getNumber s
-                                         val = case tp of
-                                                 TkInteger8  -> readn 8  n
-                                                 TkInteger16 -> readn 16 n
-                                                 TkInteger10 -> readn 10 n
-                                     in  if val >= 0 && val <= 255
-                                            then (Just (chr val),len, rest)
-                                            else (Nothing,1,rest)
-                       | otherwise = case x `lookup` cntrChars of
-                                    Nothing -> (Nothing,0,s)
-                                    Just c  -> (Just c,1,xs)
-     where cntrChars = [('a','\a'),('b','\b'),('f','\f'),('n','\n'),('r','\r'),('t','\t')
-                       ,('v','\v'),('\\','\\'),('"','\"')]
--- character literals are not used in Ampersand. Since this scanner was used for Haskell-type languages, ('\'','\'') has been removed from cntrChars...
-
-   readn base = foldl (\r x  -> value x + base * r) 0
-
-   getNumber cs@(c:s)
-     | c /= '0'         = num10
-     | null s           = const0
-     | hs `elem` "xX"   = num16
-     | hs `elem` "oO"   = num8
-     | otherwise        = num10
-     where (hs:ts) = s
-           const0 = (TkInteger10, "0",1,s)
-           num10  = let (n,r) = span isDigit cs
-                    in (TkInteger10,n,length n,r)
-           num16   = readNum isHexaDigit  ts TkInteger16
-           num8    = readNum isOctalDigit ts TkInteger8
-           readNum p ts tk
-             = let nrs@(n,rs) = span p ts
-               in  if null n then const0
-                             else (tk         , n, 2+length n,rs)
-
-   isHexaDigit  d = isDigit d || (d >= 'A' && d <= 'F') || (d >= 'a' && d <= 'f')
-   isOctalDigit d = d >= '0' && d <= '7'
-
-   value c | isDigit c = ord c - ord '0'
-           | isUpper c = ord c - ord 'A' + 10
-           | isLower c = ord c - ord 'a' + 10
-
-
-
-
-
-   get_tok_val (Tok _ _ s _ _) = s
-
-   gsym :: IsParser p Token => TokenType -> String -> String -> p String
-   gsym kind val val2 = get_tok_val <$> pSym (Tok kind val val2 noPos "")
-   pString, pExpl, pAtom, pChar, pInteger8, pInteger10, pInteger16, pVarid, pConid,
-     pTextnm, pTextln, pInteger :: IsParser p Token => p String
-   pOper name     =   gsym TkOp        name      name
-   pKey  keyword  =   gsym TkKeyword   keyword   keyword
-   pSpec s        =   gsym TkSymbol    [s]       [s]
-
-   pString        =   gsym TkString    ""        ""
-   pExpl          =   gsym TkExpl      ""        ""
-   pAtom          =   gsym TkAtom      ""        ""
-   pChar          =   gsym TkChar      ""        "\NUL"
-   pInteger8      =   gsym TkInteger8  ""        "1"
-   pInteger10     =   gsym TkInteger10 ""        "1"
-   pInteger16     =   gsym TkInteger16 ""        "1"
-   pVarid         =   gsym TkVarid     ""        "?lc?"
-   pConid         =   gsym TkConid     ""        "?uc?"
-   pTextnm        =   gsym TkTextnm    ""        ""
-   pTextln        =   gsym TkTextln    ""        ""
-
-   pInteger       =   pInteger10
-
-   pComma, pSemi, pOParen, pCParen, pOBrack, pCBrack, pOCurly, pCCurly :: IsParser p Token => p String
-   pComma  = pSpec ','
-   pSemi   = pSpec ';'
-   pOParen = pSpec '('
-   pCParen = pSpec ')'
-   pOBrack = pSpec '['
-   pCBrack = pSpec ']'
-   pOCurly = pSpec '{'
-   pCCurly = pSpec '}'
-
-   pCommas ::  IsParser p Token => p a -> p [a]
-   pSemics ::  IsParser p Token => p a -> p [a]
-   pParens ::  IsParser p Token => p a -> p a
-   pBracks ::  IsParser p Token => p a -> p a
-   pCurly ::  IsParser p Token => p a -> p a
-
-   pCommas  = pListSep pComma
-   pSemics  = pListSep pSemi
-   pParens  = pPacked pOParen pCParen
-   pBracks  = pPacked pOBrack pCBrack
-   pCurly   = pPacked pOCurly pCCurly
-
-   pParens_pCommas :: IsParser p Token => p a -> p [a]
-   pBracks_pCommas :: IsParser p Token => p a -> p [a]
-   pCurly_pSemics :: IsParser p Token => p a -> p [a]
-
-   pParens_pCommas = pParens.pCommas
-   pBracks_pCommas = pBracks.pCommas
-   pCurly_pSemics  = pCurly .pSemics
-   

− src/lib/DatabaseDesign/Ampersand/Input/Parsing.hs 
@@ -1,215 +0,0 @@-{-# OPTIONS_GHC  -XScopedTypeVariables #-}
-module DatabaseDesign.Ampersand.Input.Parsing ( parseContext
-                                        , parseADL1pExpr
-                                        , ParseError)
-where
-
-import Control.Monad
-import Data.List
-import Data.Char
-import System.Directory
-import System.FilePath
-import DatabaseDesign.Ampersand.Input.ADL1.Parser (pContext,pPopulations,pTerm,keywordstxt, keywordsops, specialchars, opchars)
-import DatabaseDesign.Ampersand.Misc
-import DatabaseDesign.Ampersand.Basics
-import DatabaseDesign.Ampersand.Input.ADL1.UU_Scanner -- (scan,initPos)
-import DatabaseDesign.Ampersand.Input.ADL1.UU_Parsing -- (getMsgs,parse,evalSteps,parseIO)
-import DatabaseDesign.Ampersand.ADL1
-import Control.Exception
-
-type ParseError = Message Token
-
-fatal :: Int -> String -> a
-fatal = fatalMsg "Input.Parsing"
-
--- | The parser currently needs to be monadic, because there are multiple versions of the Ampersand language supported. Each parser
---   currently throws errors on systemerror level. They can only be 'catch'ed in a monad.
---   This parser is for parsing of a Context
-parseContext :: Options                          -- ^ flags to be taken into account
-             -> FilePath                         -- ^ the full path to the file to parse 
-             -> IO (Either ParseError P_Context) -- ^ The IO monad with the parse tree. 
-parseContext flags file 
-             = do { verboseLn flags $ "Parsing with "++show (parserVersion flags)++"..."
-                  ; rapRes <- if includeRap flags
-                              then do let rapFile = ampersandDataDir flags </> "RepoRap" </> "RAP.adl"
-                                      exists <- doesFileExist rapFile
-                                      when (not exists) (fatal 39 $ "RAP file isn't installed properly. RAP.adl expected at:"
-                                                                  ++"\n  "++show rapFile
-                                                                  ++"\n  (You might want to reinstall ampersand...)") 
-                                      parseADL flags rapFile
-                              else return (Right emptyContext)
-                  ; (case rapRes of
-                      Left err -> do verboseLn flags "Parsing of RAP failed"
-                                     return rapRes
-                      Right rapCtx 
-                               -> do eRes   <- parseADL flags file
-                                     case eRes of  
-                                       Right ctx  -> verboseLn flags "Parsing successful"
-                                                  >> return (Right (mergeContexts ctx rapCtx))
-                                       Left err -> verboseLn flags "Parsing failed"
-                                                >> return eRes
-                    )
-                  }
-                  
-                                             
--- | Parse isolated ADL1 expression strings
-parseADL1pExpr :: String -> String -> Either String (Term TermPrim)
-parseADL1pExpr pexprstr fn = parseExpr Current pexprstr fn
-
--- | Parse isolated ADL1 expression strings
-parseExpr :: ParserVersion     -- ^ The specific version of the parser to be used
-          -> String            -- ^ The string to be parsed
-          -> String            -- ^ The name of the file (used for error messages)
-          -> Either String (Term TermPrim)  -- ^ The result: Either an error message,  or a good result 
-parseExpr pv str fn =
-    case runParser pv pTerm fn str of
-      Right result -> Right result
-      Left  msg    -> Left $ "Parse errors for "++show pv++":\n"++show msg
-
-
-
-parseADL :: Options
-         -> FilePath      -- ^ The name of the .adl file
-         -> IO (Either ParseError P_Context) -- ^ The result: Either some errors, or the parsetree.
-parseADL flags file =
- do { verboseLn flags $ "Files read:"
-    ; (result, parsedFiles) <- readAndParseFile flags 0 [] Nothing "" file
-    ; verboseLn flags $ "\n"
-    ; return result
-    }
-
--- parse the input file and read and parse the imported files
--- The alreadyParsed parameter keeps track of filenames that have been parsed already, which are ignored when included again.
--- Hence, include cycles do not cause an error.
--- We don't distinguish between "INCLUDE SomeADL" and "INCLUDE SoMeAdL" to prevent errors on case-insensitive file systems.
--- (on a case-sensitive file system you do need to keep your includes with correct capitalization though)
-
-readAndParseFile :: Options -> Int -> [String] -> Maybe String -> String -> String ->
-                    IO (Either ParseError P_Context, [String])
-readAndParseFile flags depth alreadyParsed mIncluderFilepath fileDir relativeFilepath =
- catch myMonad myHandler
-   where 
-     myMonad =
-       do { canonicFilepath <- fmap (map toUpper) $ canonicalizePath filepath
-            -- Legacy parser has no includes, so no need to print here
-      
-          ; if canonicFilepath `elem` alreadyParsed 
-            then do { verboseLn flags $ replicate (3*depth) ' ' ++ "(" ++ filepath ++ ")"
-                    ; return (Right emptyContext, alreadyParsed) -- returning an empty context is easier than a maybe (leads to some plumbing in readAndParseIncludeFiles)
-                    } 
-            else do { fileContents <- DatabaseDesign.Ampersand.Basics.readFile filepath
-                    ; verboseLn flags $ replicate (3*depth) ' ' ++ filepath
-                    ; parseFileContents flags (depth+1) (canonicFilepath:alreadyParsed)
-                                        fileContents newFileDir newFilename     
-                    }
-          }
-     myHandler :: IOException ->
-                  IO (Either ParseError P_Context, [String])
-     myHandler =   
-             (\exc -> do { error $ case mIncluderFilepath of
-                                 Nothing -> 
-                                   "\n\nError: cannot read ADL file " ++ show filepath
-                                 Just includerFilepath ->
-                                   "\n\nError: cannot read include file " ++ show filepath ++ 
-                                   ", included by " ++ show includerFilepath})
-     filepath = combine fileDir relativeFilepath
-     newFileDir = let dir = takeDirectory filepath in if dir == "." then "" else dir
-     newFilename = takeFileName filepath
-
-parseFileContents :: Options  -- ^ command-line options 
-                  -> Int      -- ^ The include depth
-                  -> [String] -- ^ Already parsed files (canonicalized) 
-                  -> String   -- ^ The string to be parsed
-                  -> String   -- ^ The path to the .adl file 
-                  -> String   -- ^ The name of the .adl file
-                  -> IO (Either ParseError P_Context, [String]) -- ^ The result: The updated already-parsed contexts and Either some errors, or the parsetree.
-parseFileContents flags depth alreadyParsed fileContents fileDir filename =
-  do { let filepath = combine fileDir filename
-     ; case parseSingleADL (parserVersion flags) fileContents filepath of
-           Left err -> return (Left err, alreadyParsed)
-           Right (parsedContext, includeFilenames) ->
-             do { (includeParseResults, alreadyParsed') <-
-                     readAndParseIncludeFiles flags alreadyParsed depth (Just $ combine fileDir filename) fileDir includeFilenames
-                ; return ( case includeParseResults of
-                             Left err              -> Left err
-                             Right includeContexts -> Right $ foldl mergeContexts parsedContext includeContexts
-                         , alreadyParsed' )             
-                }     
-    }
-
-readAndParseIncludeFiles :: Options -> [String] -> Int -> Maybe String -> String -> [String] ->
-                            IO (Either ParseError [P_Context], [String])
-readAndParseIncludeFiles flags alreadyParsed depth mIncluderFilepath fileDir [] = return (Right [], alreadyParsed)
-readAndParseIncludeFiles flags alreadyParsed depth mIncluderFilepath fileDir (relativeFilepath:relativeFilepaths) = 
- do { (result, alreadyParsed') <- readAndParseFile flags depth alreadyParsed mIncluderFilepath fileDir relativeFilepath
-    ; case result of                               -- Include is only implemented in Current parser
-        Left err -> return (Left err, alreadyParsed')
-        Right context ->
-         do { (results, alreadyParsed'') <- readAndParseIncludeFiles flags alreadyParsed' depth mIncluderFilepath fileDir relativeFilepaths
-            ; case results of
-                Left err -> return (Left err, alreadyParsed'')
-                Right contexts -> return (Right $ context : contexts, alreadyParsed'') 
-            }
-    }
- 
-emptyContext :: P_Context
-emptyContext = PCtx "" [] Nothing Nothing [] [] [] [] [] [] [] [] [] [] [] [] [] [] []
-
-mergeContexts :: P_Context -> P_Context -> P_Context
-mergeContexts (PCtx nm1 pos1 lang1 markup1 thms1 pats1 pprcs1 rs1 ds1 cs1 ks1 vs1 gs1 ifcs1 ps1 pops1 sql1 php1 metas1)
-              (PCtx nm2 pos2 lang2 markup2 thms2 pats2 pprcs2 rs2 ds2 cs2 ks2 vs2 gs2 ifcs2 ps2 pops2 sql2 php2 metas2) =
-  PCtx{ ctx_nm = nm1
-      , ctx_pos = pos1 ++ pos2
-      , ctx_lang = lang1
-      , ctx_markup = markup1
-      , ctx_thms = thms1 ++ thms2
-      , ctx_pats = pats1 ++ pats2
-      , ctx_PPrcs = pprcs1 ++ pprcs2
-      , ctx_rs = rs1 ++ rs2
-      , ctx_ds = ds1 ++ ds2
-      , ctx_cs = cs1 ++ cs2
-      , ctx_ks = ks1 ++ ks2
-      , ctx_vs = vs1 ++ vs2
-      , ctx_gs = gs1 ++ gs2
-      , ctx_ifcs = ifcs1 ++ ifcs2
-      , ctx_ps = ps1 ++ ps2
-      , ctx_pops = pops1 ++ pops2
-      , ctx_sql = sql1 ++ sql2
-      , ctx_php = php1 ++ php2
-      , ctx_metas = metas1 ++ metas2
-      }
-
-
-parseSingleADL :: ParserVersion -- ^ The specific version of the parser to be used
-         -> String        -- ^ The string to be parsed
-         -> String        -- ^ The name of the .adl file (used for error messages)
-         -> Either ParseError (P_Context, [String]) -- ^ The result: Either some errors, or the parsetree. 
-
-parseSingleADL pv str fn =
-  case pv of
-      Current  -> runParser pv pContext                              fn str
- where addEmptyIncludes parsedContext = (parsedContext, []) -- the old parsed does not support include filenames, so we add an empty list
-
-
--- | Same as parseCtx_ , however this one is for a list of populations
-parsePops :: String            -- ^ The string to be parsed
-          -> String            -- ^ The name of the .pop file (used for error messages)
-          -> ParserVersion     -- ^ The specific version of the parser to be used
-          -> Either String [P_Population] -- ^ The result: Either a list of populations, or some errors. 
-parsePops str fn pv = 
-    case  runParser pv pPopulations fn str of
-      Right result -> Right result
-      Left  msg    -> Left $ "Parse errors for "++show pv++":\n"++show msg
-
-
-      
-runParser :: forall res . ParserVersion -> Parser Token res -> String -> String -> Either ParseError res
-runParser parserVersion parser filename input = 
-  let scanner = case parserVersion of 
-                  Current -> scan              keywordstxt              keywordsops              specialchars              opchars filename initPos
-      steps :: Steps (Pair res (Pair [Token] a)) Token
-      steps = parse parser $ scanner input
-  in  case  getMsgs steps of
-        []       -> Right $ let Pair result _ = evalSteps steps in result
-        msg:msgs -> Left msg
-

− src/lib/DatabaseDesign/Ampersand/InputProcessing.hs 
@@ -1,166 +0,0 @@-{-# OPTIONS_GHC -Wall #-}
--- This module provides an interface to be able to parse a scritp and to 
--- return an Fspec, conform the user defined flags. 
--- This might include that RAP is included in the returned Fspec. 
-module DatabaseDesign.Ampersand.InputProcessing (
-   createFspec
-)
-where
-import qualified DatabaseDesign.Ampersand.Basics as Basics
-import DatabaseDesign.Ampersand.Fspec
-import DatabaseDesign.Ampersand.Misc
-import DatabaseDesign.Ampersand.ADL1.P2A_Converters
-import DatabaseDesign.Ampersand.Input.ADL1.UU_Scanner -- (scan,initPos)
-import DatabaseDesign.Ampersand.Input.ADL1.UU_Parsing --  (getMsgs,parse,evalSteps,parseIO)
-import DatabaseDesign.Ampersand.Input.ADL1.Parser
-import DatabaseDesign.Ampersand.ADL1
-import DatabaseDesign.Ampersand.Input.ADL1.CtxError (CtxError(PE))
-import Data.List
-import System.Directory
-import System.FilePath
-import Control.Monad
-import Data.Traversable (sequenceA)
-import Control.Applicative
-
-fatal :: Int -> String -> a
-fatal = Basics.fatalMsg "InputProcessing"
-
--- | create an Fspec, based on the user defined flags. 
-createFspec :: Options  -- ^The options derived from the command line 
-            -> IO(Guarded Fspc) 
-createFspec flags = 
-  do userCtx <- parseWithIncluded flags (fileName flags)
-     bothCtx <- if includeRap flags
-                then do let rapFile = ampersandDataDir flags </> "FormalAmpersand" </> "FormalAmpersand.adl" 
-                        exists <- doesFileExist rapFile
-                        when (not exists) (fatal 39 $ "Ampersand isn't installed properly. Formal specification of Ampersand expected at:"
-                                                    ++"\n  "++show rapFile
-                                                    ++"\n  (You might want to re-install ampersand...)") 
-                        rapCtx <- parseWithIncluded flags rapFile
-                        popsCtx <- popsCtxOf userCtx
-                        case sequenceA [userCtx, rapCtx, popsCtx] of
-                           Errors err -> return (Errors err)
-                           Checked ps -> return (Checked 
-                                               (foldr mergeContexts emptyContext ps))
-                else return userCtx
-     case bothCtx of
-        Errors err -> return (Errors err)
-        Checked pCtx
-           -> do let (gaCtx) = pCtx2aCtx pCtx 
-                 case gaCtx of
-                   (Errors  err ) -> return (Errors err)
-                   (Checked aCtx) -> return (Checked (makeFspec flags aCtx ))
-  where
-    popsCtxOf :: Guarded P_Context ->IO(Guarded P_Context)
-    popsCtxOf gp =
-     (case gp of
-       Errors _ -> return (Errors []) -- The errors are already in the error list
-       Checked pCtx 
-         -> case pCtx2aCtx pCtx of
-              (Errors  err ) -> return (Errors err)
-              (Checked aCtx)
-                 -> do let fspc = makeFspec flags aCtx
-                           popScript = meatGrinder flags fspc
-                       when (genMeat flags) 
-                          (do let (nm,content) = popScript
-                                  outputFile = combine (dirOutput flags) $ replaceExtension nm ".adl"
-                              writeFile outputFile content
-                              verboseLn flags $ "Meta population written into " ++ outputFile ++ "."
-                          )
-                       case parse1File2pContext popScript of
-                         (Errors  err) -> fatal 64 ("MeatGrinder has errors!" 
-                                                 ++ intercalate "\n"(map showErr err))
-                         (Checked (pctx,[])) -> return (Checked pctx)
-                         (Checked _ )        -> fatal 67 "Meatgrinder returns included file????"
-     )
-
-     
--------------
-type FileContent = (FilePath, String) -- The name and its contents
-type ParseResult = (P_Context, [FilePath]) -- A positive parse of a single file deliverse a P_Context and a list of includedes
-
-parseWithIncluded :: Options -> FilePath -> IO(Guarded P_Context)
-parseWithIncluded flags fp = tailRounds [] (emptyContext,[fp])
- where
-    tailRounds :: [FileContent] -- the files already processed
-               -> ParseResult   -- the result so far.  
-               -> IO(Guarded P_Context) 
-    tailRounds dones (pCtx, names) =
-     do let filesToProcessThisRound = [f | f<-names, f `notElem` map fst dones]
-        case filesToProcessThisRound of 
-         []    -> do return (Checked pCtx)
-         newNs -> do fs <- readFiles newNs
-                     res <- oneRound fs dones pCtx
-                     case res of
-                             Errors err -> return (Errors err)
-                             Checked (pCtx',included)
-                                -> tailRounds (nub ( dones++fs)) (pCtx', included)
-    readFiles :: [FilePath] -> IO [FileContent]
-    readFiles fs = mapM readFile' fs
-     where
-       readFile' f = 
-          do verboseLn flags ("reading "++f)
-             content <- Basics.readFile f
-             return (f,content)
-    oneRound :: [FileContent] -- Files that have not been parsed yet
-             -> [FileContent] -- Files that have been parsed already
-             -> P_Context     -- The result so far from previous parsed files
-             -> IO(Guarded ParseResult)
-    oneRound todos dones pCtx = pure parseNext
-     where 
-       parseNext :: Guarded ParseResult
-       parseNext  =
-         case nub [f | f <- todos, f `notElem` dones] of
-           [] -> Checked (pCtx,[])
-           fs -> case sequenceA (map parse1File2pContext fs) of
-                   Checked prs -> Checked ( foldl mergeContexts pCtx (map fst prs)
-                                          , concatMap snd prs)
-                   Errors errs -> Errors errs
-parse1File2pContext :: FileContent -> Guarded ParseResult
-parse1File2pContext (fPath, fContent) =
-   let scanner = scan keywordstxt keywordsops specialchars opchars fPath initPos
-       steps :: Steps (Pair ParseResult (Pair [Token] a)) Token
-       steps = parse pContext (scanner fContent)
-   in  case  getMsgs steps of
-         []  -> let Pair (pCtx,includes) _ = evalSteps steps 
-                in Checked (pCtx,map normalize includes)
-         msgs-> Errors (map PE msgs)
-  where
-  normalize ::FilePath -> FilePath
-  normalize name = takeDirectory fPath </> name
-
-
- 
-emptyContext :: P_Context
-emptyContext = PCtx "" [] Nothing Nothing [] [] [] [] [] [] [] [] [] [] [] [] [] [] []
-
-mergeContexts :: P_Context -> P_Context -> P_Context
-mergeContexts (PCtx nm1 pos1 lang1 markup1 thms1 pats1 pprcs1 rs1 ds1 cs1 ks1 vs1 gs1 ifcs1 ps1 pops1 sql1 php1 metas1)
-              (PCtx nm2 pos2 lang2 markup2 thms2 pats2 pprcs2 rs2 ds2 cs2 ks2 vs2 gs2 ifcs2 ps2 pops2 sql2 php2 metas2) =
-  PCtx{ ctx_nm     = if null nm1 then nm2 else nm1
-      , ctx_pos    = pos1 ++ pos2
-      , ctx_lang   = lang1   `orElse` lang2   `orElse` Nothing
-      , ctx_markup = markup1 `orElse` markup2 `orElse` Nothing
-      , ctx_thms   = thms1 ++ thms2
-      , ctx_pats   = pats1 ++ pats2
-      , ctx_PPrcs  = pprcs1 ++ pprcs2
-      , ctx_rs     = rs1 ++ rs2
-      , ctx_ds     = ds1 ++ ds2
-      , ctx_cs     = cs1 ++ cs2
-      , ctx_ks     = ks1 ++ ks2
-      , ctx_vs     = vs1 ++ vs2
-      , ctx_gs     = gs1 ++ gs2
-      , ctx_ifcs   = ifcs1 ++ ifcs2
-      , ctx_ps     = ps1 ++ ps2
-      , ctx_pops   = pops1 ++ pops2
-      , ctx_sql    = sql1 ++ sql2
-      , ctx_php    = php1 ++ php2
-      , ctx_metas  = metas1 ++ metas2
-      }
-
--- | Left-biased choice on maybes
-orElse :: Maybe a -> Maybe a -> Maybe a
-x `orElse` y = case x of
-                 Just _  -> x
-                 Nothing -> y
-

− src/lib/DatabaseDesign/Ampersand/Misc.hs 
@@ -1,10 +0,0 @@-{-# OPTIONS_GHC -Wall #-}
-module DatabaseDesign.Ampersand.Misc (module X) where
-import DatabaseDesign.Ampersand.Misc.Languages as X
-       (Lang(..), plural)
-import DatabaseDesign.Ampersand.Misc.Options as X
-       (getOptions, Options(..), ParserVersion(..),
-        verboseLn, verbose, DocTheme(..), FspecFormat(..),
-        FileFormat(..), helpNVersionTexts)
-import DatabaseDesign.Ampersand.Misc.Explain as X
-       (string2Blocks, blocks2String, PandocFormat(..))

− src/lib/DatabaseDesign/Ampersand/Misc/Explain.hs 
@@ -1,60 +0,0 @@-{-# OPTIONS_GHC -Wall #-}
-module DatabaseDesign.Ampersand.Misc.Explain
-    ( string2Blocks
-    , blocks2String
-    , PandocFormat(..)
-    )
-where
-
-import Text.Pandoc
-import Data.List (isPrefixOf)
-import DatabaseDesign.Ampersand.Core.ParseTree      (PandocFormat(..))
-
-
--- | use a suitable format to read generated strings. if you have just normal text, ReST is fine.
--- | defaultPandocReader flags should be used on user-defined strings.
-string2Blocks :: PandocFormat -> String -> [Block]
-string2Blocks defaultformat str
- = case blocks of             -- WHY (SJ, dec 7th, 2011): What is the point of changing Para into Plain?
-    [Para is] -> [Plain is]   -- BECAUSE (SJ, dec 7th, 2011): The table of relations in the LaTeX output of ChapterDataAnalysis gives errors when LaTeX is run, because Para generates a newline that LaTeX cannot cope with.
-    _         -> blocks       --                              However, this Para is generated by Pandoc, so I'm wondering whether the mistake is in Pandoc? Anyway, this solution is a dirty fix, which I don't like.
-   where 
-     Pandoc _ blocks = thePandocParser (removeCRs str')
-     removeCRs :: String -> String
-     removeCRs [] = []
-     removeCRs ('\r' :'\n' : xs) = '\n' : removeCRs xs
-     removeCRs (c:xs) = c:removeCRs xs
-     (thePandocParser,str') = whatParser2UseOnWhatString
-     whatParser2UseOnWhatString :: (String -> Pandoc,String)
-     whatParser2UseOnWhatString -- = (readRST, str)
-        | markDownPrefix `isPrefixOf` str = (readMarkdown def, drop (length markDownPrefix) str)
-        | reSTPrefix     `isPrefixOf` str = (readRST      def, drop (length reSTPrefix)     str)
-        | hTMLPrefix     `isPrefixOf` str = (readHtml     def, drop (length hTMLPrefix)     str)
-         --stateParseRaw=True e.g. such that "\ref{something}" is not read as "\{something\}". with parse raw it's read as inline latex
-         --maybe html should be parsed raw too...
-        | laTeXPrefix    `isPrefixOf` str = (readLaTeX    def, drop (length laTeXPrefix)    str)
-        | otherwise   = case defaultformat of
-                               Markdown  -> (readMarkdown def, str)
-                               ReST      -> (readRST      def, str)
-                               HTML      -> (readHtml     def, str)
-                               LaTeX     -> (readLaTeX    def, str)
-       where markDownPrefix = makePrefix Markdown
-             reSTPrefix     = makePrefix ReST
-             hTMLPrefix     = makePrefix HTML
-             laTeXPrefix    = makePrefix LaTeX
-
-makePrefix :: PandocFormat -> String             
-makePrefix format = ":"++show format++":"
-
--- | write [Block] as String in a certain format using defaultWriterOptions
-blocks2String :: PandocFormat -> Bool -> [Block] -> String
-blocks2String format writeprefix ec 
- = [c | c<-makePrefix format,writeprefix]
-   --you cannot unwords lines for all writers, because white lines have a meaning in LaTeX i.e. \par
-   --if your application of blocks2String may not have line breaks, then unwords lines there
-   ++ {- unwords -} ( {-lines $ -} writer def (Pandoc nullMeta ec))
-   where writer = case format of
-            Markdown  -> writeMarkdown
-            ReST      -> writeRST
-            HTML      -> writeHtmlString
-            LaTeX     -> writeLaTeX

− src/lib/DatabaseDesign/Ampersand/Misc/Languages.hs 
@@ -1,53 +0,0 @@-{-# OPTIONS_GHC -Wall #-}
--- | This module does some string manipulation based on natural languages
-module DatabaseDesign.Ampersand.Misc.Languages
-              (  Lang(English,Dutch)
-               , allLangs
-               , plural
-              ) where
-   import Data.Char (toLower)
-   import Data.List (isSuffixOf)
-   import DatabaseDesign.Ampersand.Core.ParseTree      (Lang(..))
-   
-   allLangs :: [Lang]
-   allLangs = [Dutch,English] -- All supported natural languages in Ampersand
-
-
-   -- | Returns the plural of a given word based on a specific language
-   plural :: Lang -> String -> String
-   plural English str
-    | null str = str
-    | last str=='y' = init str++"ies"
-    | last str=='s' = str++"es"
-    | last str=='x' = str++"es"
-    | last str=='f' = init str++"ves"
-    | otherwise     = head ([p |(s,p)<-exceptions, s==str]++[str++"s"])
-    where exceptions = [("child","children"),("Child","Children"),("mouse","mice"),("Mouse","Mice"),("sheep","sheep"),("Sheep","Sheep")]
-   plural Dutch str
-    | null str = str
-    | not (null matches)    = head matches
-    | take 3 (reverse str)== reverse "ium" = (reverse.drop 3.reverse) str++"ia"
-    | take 2 (reverse str) `elem` map reverse ["el", "em", "en", "er", "um", "ie"] = str++"s"
-    | "ij" `isSuffixOf` str = str++"en"
-    | "io" `isSuffixOf` str = str++"'s"
-    | klinker (last str)    = str++"s"
-    | (take 2.drop 1.reverse) str `elem` ["aa","oo","ee","uu"] = (reverse.drop 2.reverse) str++mede (drop (length str-1) str)++"en"
-    | otherwise                  = str++"en"
-    where mede "f" = "v"
-          mede "s" = "z"
-          mede x = x
-          klinker c = c `elem` "aeiou"
-          matches = [(reverse.drop (length s).reverse) str++p |(s,p) <-exceptions, (map toLower.reverse.take (length s).reverse) str==s]
-          exceptions = [ ("aanbod", "aanbiedingen")
-                       , ("beleg", "belegeringen")
-                       , ("dank", "dankbetuigingen")
-                       , ("gedrag", "gedragingen")
-                       , ("genot", "genietingen")
-                       , ("lof", "loftuitingen")
-                       , ("lende", "lendenen")
-                       , ("onderzoek", "onderzoekingen")
-                       , ("archiefstuk", "archiefbescheiden")
-                       , ("titel", "titels")
-                       , ("plan", "plannen")
-                       , ("kind", "kinderen")
-                       ]

− src/lib/DatabaseDesign/Ampersand/Misc/Options.hs 
@@ -1,532 +0,0 @@-{-# LANGUAGE PatternGuards #-}
-{-# OPTIONS_GHC -Wall #-}
-module DatabaseDesign.Ampersand.Misc.Options 
-        (Options(..),getOptions,usageInfo'
-        ,ParserVersion(..)
-        ,verboseLn,verbose,FspecFormat(..),FileFormat(..)
-        ,DocTheme(..),allFspecFormats,helpNVersionTexts)
-where
-import System.Environment    (getArgs, getProgName,getEnvironment,getExecutablePath )
-import DatabaseDesign.Ampersand.Misc.Languages (Lang(..))
-import Data.Char (toUpper)
-import System.Console.GetOpt
-import System.FilePath
-import System.Directory
-import Data.Time.Clock
-import Data.Time.LocalTime
-import Control.Monad
-import Data.Maybe
-import DatabaseDesign.Ampersand.Basics  
-import Paths_ampersand (getDataDir)
-import Prelude hiding (writeFile,readFile,getContents,putStr,putStrLn)
-import Data.List
-
-fatal :: Int -> String -> a
-fatal = fatalMsg "Misc.Options"
-
-data ParserVersion = Current | Legacy deriving Eq
-
-instance Show ParserVersion where
-  show Current = "syntax since Ampersand 2.1.1."
-  show Legacy = "syntax664"
-
--- | This data constructor is able to hold all kind of information that is useful to 
---   express what the user would like Ampersand to do. 
-data Options = Options { showVersion :: Bool
-                       , preVersion :: String
-                       , postVersion :: String  --built in to aid DOS scripting... 8-(( Bummer. 
-                       , showHelp :: Bool
-                       , verboseP :: Bool
-                       , development :: Bool
-                       , validateSQL :: Bool
-                       , genPrototype :: Bool 
-                       , dirPrototype :: String  -- the directory to generate the prototype in.
-                       , allInterfaces :: Bool
-                       , dbName :: String
-                       , genAtlas :: Bool
-                       , namespace :: String
-                       , autoRefresh :: Maybe Int
-                       , testRule :: Maybe String                       
-                       , customCssFile :: Maybe FilePath                       
-                       , importfile :: FilePath --a file with content to populate some (Populated a)
-                                                   --class Populated a where populate::a->b->a
-                       , fileformat :: FileFormat --file format e.g. of importfile or export2adl
-                       , theme :: DocTheme --the theme of some generated output. (style, content differentiation etc.)
-                       , genXML :: Bool
-                       , genFspec :: Bool   -- if True, generate a functional specification
-                       , diag :: Bool   -- if True, generate a diagnosis only
-                       , fspecFormat :: FspecFormat
-                       , genGraphics :: Bool   -- if True, graphics will be generated for use in Ampersand products like the Atlas or Functional Spec
-                       , genEcaDoc :: Bool   -- if True, generate ECA rules in the Functional Spec
-                       , proofs :: Bool
-                       , haskell :: Bool   -- if True, generate the F-structure as a Haskell source file
-                       , dirOutput :: String -- the directory to generate the output in.
-                       , outputfile :: String -- the file to generate the output in.
-                       , crowfoot :: Bool   -- if True, generate conceptual models and data models in crowfoot notation
-                       , blackWhite :: Bool   -- only use black/white in graphics
-                       , doubleEdges :: Bool   -- Graphics are generated with hinge nodes on edges.    
-                       , showPredExpr :: Bool   -- for generated output, show predicate logic?
-                       , noDiagnosis :: Bool   -- omit the diagnosis chapter from the functional specification document
-                       , diagnosisOnly :: Bool   -- give a diagnosis only (by omitting the rest of the functional specification document)
-                       , genLegalRefs :: Bool   -- Generate a table of legal references in Natural Language chapter
-                       , genUML :: Bool   -- Generate a UML 2.0 data model
-                       , genFPAExcel :: Bool   -- Generate an Excel workbook containing Function Point Analisys
-                       , genStaticFiles :: Bool-- Generate the static files into the prototype
-                       , genBericht :: Bool
-                       , genMeat :: Bool  -- Generate the meta-population and output it to an .adl file
-                       , language :: Maybe Lang  -- The language in which the user wants the documentation to be printed.
-                       , dirExec :: String --the base for relative paths to input files
-                       , ampersandDataDir :: FilePath -- the directory where Ampersand data files are. 
-                       , progrName :: String --The name of the adl executable
-                       , fileName :: FilePath --the file with the Ampersand context
-                       , baseName :: String
-                       , logName :: FilePath
-                       , genTime :: LocalTime
-                       , export2adl :: Bool
-                       , test :: Bool
-                       , includeRap :: Bool  -- When set, the standard RAP is 'merged' into the generated prototype.(experimental)
-                       , pangoFont :: String  -- use specified font in PanDoc. May be used to avoid pango-warnings.
-                       , sqlHost ::  String  -- do database queries to the specified host
-                       , sqlLogin :: String  -- pass login name to the database server
-                       , sqlPwd :: String  -- pass password on to the database server
-                       , parserVersion :: ParserVersion
-                       } 
-  
-                
-getOptions :: IO Options
-getOptions =
-   do args     <- getArgs
-      progName <- getProgName
-      exePath <- getExecutablePath -- findExecutable progName
-      env <- getEnvironment
-      haskellInstallationDirectoryOfAmpersand <- getDataDir
-      let dataDirOfAmpersandInstallation = takeDirectory exePath </> ".." </> "AmpersandData" 
-      let usage = "\nType '"++ progName++" --help' for usage info."
-      let (actions, nonOptions, errors) = getOpt Permute (each options) args
-      let fName = head (nonOptions++(error $ "Please supply the name of an ampersand file" ++ usage))
-      localTime <- getLocalTime 
-      when ((not.null) errors) (error $ concat errors ++ usage)
-      
-      -- Here we thread startOptions through all supplied option actions
-      flags <- foldl (>>=) (return (startOptions fName localTime env exePath progName dataDirOfAmpersandInstallation)) actions
-    --  defaultOpts <- defaultOptionsM 
-    --  let flags = foldl (flip id) opts actions
-      if showHelp flags || showVersion flags
-      then return flags
-      else checkNSetOptionsAndFileNameM (flags,nonOptions) usage
-        
-  where 
-     getLocalTime :: IO LocalTime
-     getLocalTime = do utcTime <- getCurrentTime
-                       timeZone <- getCurrentTimeZone
-                       return (utcToLocalTime timeZone utcTime)
-     startOptions  :: String -> LocalTime -> [(String,String)] -> FilePath -> String -> FilePath -> Options 
-     startOptions  fName localTime env exePath progName dataDirOfAmpersandInstallation=
-       Options {genTime       = localTime
-              , dirOutput     = fromMaybe "."       (lookup envdirOutput    env)
-              , outputfile    = fatal 83 "No monadic options available."
-              , dirPrototype  = fromMaybe ("." </> (addExtension (takeBaseName fName) ".proto"))
-                                          (lookup envdirPrototype env) </> (addExtension (takeBaseName fName) ".proto")
-              , dbName        = fromMaybe ""        (lookup envdbName       env)
-              , logName       = fromMaybe "Ampersand.log" (lookup envlogName      env)
-              , dirExec       = takeDirectory exePath
-              , ampersandDataDir = dataDirOfAmpersandInstallation
-              , preVersion    = fromMaybe ""        (lookup "CCPreVersion"  env)
-              , postVersion   = fromMaybe ""        (lookup "CCPostVersion" env)
-              , theme         = DefaultTheme
-              , showVersion   = False
-              , showHelp      = False
-              , verboseP      = False
-              , development   = False
-              , validateSQL   = False
-              , genPrototype  = False
-              , allInterfaces = False
-              , genAtlas      = False   
-              , namespace     = []
-              , autoRefresh   = Nothing
-              , testRule      = Nothing
-              , customCssFile = Nothing
-              , importfile    = []
-              , fileformat    = fatal 101 "--fileformat is required for --import."
-              , genXML        = False
-              , genFspec      = False 
-              , diag          = False 
-              , fspecFormat   = fatal 105 $ "Unknown fspec format. Currently supported formats are "++allFspecFormats++"."
-              , genGraphics   = True
-              , genEcaDoc     = False
-              , proofs        = False
-              , haskell       = False
-              , crowfoot      = False
-              , blackWhite    = False
-              , doubleEdges   = False
-              , showPredExpr  = False
-              , noDiagnosis   = False
-              , diagnosisOnly = False
-              , genLegalRefs  = False
-              , genUML        = False
-              , genFPAExcel   = False
-              , genStaticFiles= True
-              , genBericht    = False
-              , genMeat       = False
-              , language      = Nothing
-              , progrName     = progName
-              , fileName      = fatal 119 "no default value for fileName."
-              , baseName      = fatal 120 "no default value for baseName."
-              , export2adl    = False
-              , test          = False
-              , includeRap    = False
-              , pangoFont     = "Sans"
-              , sqlHost       = "localhost"
-              , sqlLogin      = "ampersand"
-              , sqlPwd        = "ampersand"
-              , parserVersion = Current
-              }
-
-
-
-     checkNSetOptionsAndFileNameM :: (Options,[String]) -> String -> IO Options 
-     checkNSetOptionsAndFileNameM (flags,fNames) usage= 
-          if showVersion flags || showHelp flags 
-          then return flags 
-          else case fNames of
-                []      -> error $ "no file to parse" ++usage
-                [fName] -> checkInvalidOptionCombinations flags
-                        >> verboseLn flags "Checking output directories..."
-                        >> checkLogName flags
-                        >> checkDirOutput flags
-                        --REMARK -> checkExecOpts in comments because it is redundant
-                        --          it may throw fatals about PATH not set even when you do not need the dir of the executable.
-                        --          if you need the dir of the exec, then you should use (dirExec flags) which will throw the fatal about PATH when needed.
-                        -- >> checkExecOpts flags
-                        >> checkProtoOpts flags
-                        >> return flags { fileName    = if hasExtension fName
-                                                         then fName
-                                                         else addExtension fName "adl" 
-                                        , baseName    = takeBaseName fName
-                                        , dbName      = case dbName flags of
-                                                            ""  -> takeBaseName fName
-                                                            str -> str
-                                        , genAtlas = not (null(importfile flags)) && fileformat flags==Adl1Format
-                                        , importfile  = if null(importfile flags) || hasExtension(importfile flags)
-                                                        then importfile flags
-                                                        else case fileformat flags of 
-                                                                Adl1Format -> addExtension (importfile flags) "adl"
-                                                                Adl1PopFormat -> addExtension (importfile flags) "pop"
-                                        }
-                x:xs    -> error $ "too many files: "++ intercalate ", " (x:xs) ++usage
-       
-       where
-          checkInvalidOptionCombinations :: Options -> IO ()
-          checkInvalidOptionCombinations f
-            | development f && validateSQL f = error "--dev and --validate must not be used at the same time." --(Reason: see ticket #378)
-            | otherwise = return()  
-          checkLogName :: Options -> IO ()
-          checkLogName   f = createDirectoryIfMissing True (takeDirectory (logName f))
-          checkDirOutput :: Options -> IO ()
-          checkDirOutput f = createDirectoryIfMissing True (dirOutput f)
-
-          --checkExecOpts :: Options -> IO ()
-          --checkExecOpts f = do execPath <- findExecutable (progrName f) 
-            --                   when (execPath == Nothing) 
-              --                      (fatal 206 $ "Specify the path location of "++(progrName f)++" in your system PATH variable.")
-          checkProtoOpts :: Options -> IO ()
-          checkProtoOpts f = when (genPrototype f) (createDirectoryIfMissing True (dirPrototype f))
-            
-data DisplayMode = Public | Hidden 
-
-data FspecFormat = FPandoc| Fasciidoc| Fcontext| Fdocbook| Fhtml| FLatex| Fman| Fmarkdown| Fmediawiki| Fopendocument| Forg| Fplain| Frst| Frtf| Ftexinfo| Ftextile deriving (Show, Eq)
-allFspecFormats :: String
-allFspecFormats = show (map (tail . show) [FPandoc, Fasciidoc, Fcontext, Fdocbook, Fhtml, FLatex, Fman, Fmarkdown, Fmediawiki, Fopendocument, Forg, Fplain, Frst, Frtf, Ftexinfo, Ftextile])
-
-data FileFormat = Adl1Format | Adl1PopFormat  deriving (Show, Eq) --file format that can be parsed to some b to populate some Populated a
-data DocTheme = DefaultTheme   -- Just the functional specification
-              | ProofTheme     -- A document with type inference proofs
-              | StudentTheme   -- Output for normal students of the business rules course
-              | StudentDesignerTheme   -- Output for advanced students of the business rules course
-              | DesignerTheme   -- Output for non-students
-                 deriving (Show, Eq)
-    
-usageInfo' :: Options -> String
--- When the user asks --help, then the public options are listed. However, if also --verbose is requested, the hidden ones are listed too.  
-usageInfo' flags = usageInfo (infoHeader (progrName flags)) (if verboseP flags then each options else publics options)
-          
-infoHeader :: String -> String
-infoHeader progName = "\nUsage info:\n " ++ progName ++ " options file ...\n\nList of options:"
-
-publics :: [(a, DisplayMode) ] -> [a]
-publics flags = [o | (o,Public)<-flags]
-each :: [(a, DisplayMode) ] -> [a]
-each flags = [o |(o,_) <- flags]
-
-type OptionDef = OptDescr (Options -> IO Options)
-options :: [(OptionDef, DisplayMode) ]
-options = map pp
-          [ (Option "v"     ["version"]
-               (NoArg (\flags -> return flags{showVersion = True}))
-               "show version and exit."
-            , Public)
-          , (Option "h?"    ["help"]
-               (NoArg (\flags -> return flags{showHelp = True}))
-               "get (this) usage information."
-            , Public)
-          , (Option ""      ["verbose"]
-               (NoArg (\flags -> return flags{verboseP = True}))
-               "verbose error message format."
-            , Public)
-          , (Option ""      ["dev"]
-               (NoArg (\flags -> return flags{development = True}))
-               "Report and generate extra development information"
-            , Hidden)
-          , (Option ""      ["validate"]
-               (NoArg (\flags -> return flags{validateSQL = True}))
-               "Compare results of rule evaluation in Haskell and SQL (requires command line php with MySQL support)"
-            , Hidden)
-          , (Option "p"     ["proto"]
-               (OptArg (\nm flags -> return flags {dirPrototype = fromMaybe (dirPrototype flags) nm
-                                                  ,genPrototype = True}
-                       ) "DIRECTORY")
-               ("generate a functional prototype (overwrites environment variable "++ envdirPrototype ++ ").")
-            , Public)
-          , (Option "d"     ["dbName"]
-               (ReqArg (\nm flags -> return flags{dbName = if nm == "" 
-                                                           then baseName flags
-                                                           else nm}                          
-                       ) "NAME")
-               ("database name (overwrites environment variable "++ envdbName ++ ", defaults to filename)")
-            , Public)
-          , (Option []      ["theme"]
-               (ReqArg (\t flags -> return flags{theme = case map toUpper t of 
-                                                          "STUDENT"  -> StudentTheme
-                                                          "STUDENTDESIGNER" -> StudentDesignerTheme
-                                                          "DESIGNER" -> DesignerTheme
-                                                          "PROOF"    -> ProofTheme
-                                                          _          -> DefaultTheme}
-                        ) "THEME")
-               "differentiate between certain outputs e.g. student"
-            , Public)
-          , (Option "x"     ["interfaces"]
-               (NoArg (\flags -> return flags{allInterfaces  = True}))
-               "generate interfaces."
-            , Public)
-          , (Option "e"     ["export"]
-               (OptArg (\mbnm flags -> return flags{export2adl = True
-                                                   ,outputfile = fromMaybe "Export.adl" mbnm}) "file")
-               "export as plain Ampersand script."
-            , Public)
-          , (Option "o"     ["outputDir"]
-               (ReqArg (\nm flags -> return flags{dirOutput = nm}
-                       ) "DIR")
-               ("output directory (dir overwrites environment variable "++ envdirOutput ++ ").")
-            , Public)
-          , (Option []      ["log"]
-               (ReqArg (\nm flags -> return flags{logName = nm}
-                       ) "NAME")
-               ("log file name (name overwrites environment variable "++ envlogName  ++ ").")
-            , Hidden)
-          , (Option []      ["import"]
-               (ReqArg (\nm flags -> return flags{importfile = nm}
-                       ) "FILE")
-               "import this file as the population of the context."
-            , Public)
-          , (Option []      ["fileformat"]
-               (ReqArg (\f flags -> return 
-                             flags{fileformat = case map toUpper f of
-                                                 "ADL" -> Adl1Format
-                                                 "ADL1"-> Adl1Format
-                                                 "POP" -> Adl1PopFormat
-                                                 "POP1"-> Adl1PopFormat
-                                                 _     -> fileformat flags
-                                  }
-                       ) "FORMAT")
-               ("format of import file (format=ADL (.adl), ADL1 (.adl), POP (.pop), POP1 (.pop)).")
-            , Public)
-          , (Option []      ["namespace"]
-               (ReqArg (\nm flags -> return flags{namespace = nm}
-                       ) "NAMESPACE")
-               "places the population in this namespace within the context."
-            , Public)
-          , (Option "f"     ["fspec"]
-               (ReqArg (\w flags -> return flags
-                                { genFspec=True
-                                , fspecFormat= case map toUpper w of
-                                    ('A': _ )             -> Fasciidoc
-                                    ('C': _ )             -> Fcontext
-                                    ('D': _ )             -> Fdocbook
-                                    ('H': _ )             -> Fhtml
-                                    ('L': _ )             -> FLatex
-                                    ('M':'A':'N': _ )     -> Fman
-                                    ('M':'A': _ )         -> Fmarkdown
-                                    ('M':'E': _ )         -> Fmediawiki
-                                    ('O':'P': _ )         -> Fopendocument
-                                    ('O':'R': _ )         -> Forg
-                                    ('P':'A': _ )         -> FPandoc
-                                    ('P':'L': _ )         -> Fplain
-                                    ('R':'S': _ )         -> Frst
-                                    ('R':'T': _ )         -> Frtf
-                                    ('T':'E':'X':'I': _ ) -> Ftexinfo
-                                    ('T':'E':'X':'T': _ ) -> Ftextile
-                                    _                     -> fspecFormat flags}
-                       ) "FORMAT")  
-               ("generate a functional specification document in specified format (format="++allFspecFormats++").")
-            , Public)
-          , (Option []        ["refresh"]
-               (OptArg (\r flags -> return 
-                            flags{autoRefresh = Just (case r of
-                                                       Just str | [(i,"")] <- reads str -> i
-                                                       _                                -> 5
-                                                     )}
-                       ) "INTERVAL")
-               "Experimental auto-refresh feature"
-            , Hidden)
-          , (Option []        ["testRule"]
-               (ReqArg (\ruleName flags -> return flags{ testRule = Just ruleName }
-                       ) "RULE")
-               "Show contents and violations of specified rule."
-            , Hidden)
-          , (Option []        ["css"]
-               (ReqArg (\pth flags -> return flags{ customCssFile = Just pth }) "file")
-               "Custom.css file to customize the style of the prototype."
-            , Public)
-          , (Option []        ["noGraphics"]
-               (NoArg (\flags -> return flags{genGraphics = False}))
-               "save compilation time by not generating any graphics."
-            , Public)
-          , (Option []        ["ECA"]
-               (NoArg (\flags -> return flags{genEcaDoc = True}))
-               "generate documentation with ECA rules."
-            , Public)
-          , (Option []        ["proofs"]
-               (NoArg (\flags -> return flags{proofs = True}))
-               "generate derivations."
-            , Public)
-          , (Option []        ["XML"]
-               (NoArg (\flags -> return flags{genXML = True}))
-               "generate internal data structure, written in XML (for debugging)."
-            , Public)
-          , (Option []        ["haskell"]
-               (NoArg (\flags -> return flags{haskell = True}))
-               "generate internal data structure, written in Haskell (for debugging)."
-            , Public)
-          , (Option []        ["crowfoot"]
-               (NoArg (\flags -> return flags{crowfoot = True}))
-               "generate crowfoot notation in graphics."
-            , Public)
-          , (Option []        ["blackWhite"]
-               (NoArg (\flags -> return flags{blackWhite = True}))
-               "do not use colours in generated graphics"
-            , Public)
-          , (Option []        ["doubleEdges"]
-               (NoArg (\flags -> return flags{doubleEdges = not (doubleEdges flags)}))
-               "generate graphics in an alternate way. (you may experiment with this option to see the differences for yourself)"
-            , Public)
-          , (Option []        ["predLogic"]
-               (NoArg (\flags -> return flags{showPredExpr = True}))
-               "show logical expressions in the form of predicate logic."
-            , Public)
-          , (Option []        ["noDiagnosis"]
-               (NoArg (\flags -> return flags{noDiagnosis = True}))
-               "omit the diagnosis chapter from the functional specification document."
-            , Public)
-          , (Option []        ["diagnosis"]
-               (NoArg (\flags -> return flags{diagnosisOnly = True}))
-               "diagnose your Ampersand script (generates a .pdf file)."
-            , Public)
-          , (Option []        ["legalrefs"]
-               (NoArg (\flags -> return flags{genLegalRefs = True}))
-               "generate a table of legal references in Natural Language chapter."
-            , Public)
-          , (Option []        ["uml"]
-               (NoArg (\flags -> return flags{genUML = True}))
-               "Generate a UML 2.0 data model."
-            , Hidden)
-          , (Option []        ["FPA"]
-               (NoArg (\flags -> return flags{genFPAExcel = True}))
-               "Generate a Excel workbook (.xls)."
-            , Hidden)
-          , (Option []        ["bericht"]
-               (NoArg (\flags -> return flags{genBericht = True}))
-               "Generate definitions for 'berichten' (specific to INDOORS project)."
-            , Hidden)
-          , (Option []        ["language"]
-               (ReqArg (\l flags-> return flags{language = case map toUpper l of
-                                                       "NL"  -> Just Dutch
-                                                       "UK"  -> Just English
-                                                       "US"  -> Just English
-                                                       "EN"  -> Just English
-                                                       _     -> Nothing}
-                       ) "LANG")
-               "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."
-            , Public)
-          , (Option []        ["test"]
-               (NoArg (\flags -> return flags{test = True}))
-               "Used for test purposes only."
-            , Hidden)
-          , (Option []        ["rap"]
-               (NoArg (\flags -> return flags{includeRap = True}))
-               "Include RAP into the generated artifacts (experimental)"
-            , Hidden)
-          , (Option []        ["meta"]
-               (NoArg (\flags -> return flags{genMeat = True}))
-               "Generate meta-population in an .adl file (experimental)"
-            , Hidden)
-          , (Option []        ["pango"]
-               (ReqArg (\nm flags -> return flags{pangoFont = nm}
-                       ) "FONTNAME")
-               "specify font name for Pango in graphics."
-            , Hidden)
-          , (Option []   ["no-static-files"]
-               (NoArg  (\flags -> return flags{genStaticFiles = False}))
-               "Do not generate static files into the prototype directory"
-            , Public)
-          , (Option []        ["sqlHost"]
-               (ReqArg (\nm flags -> return flags{sqlHost = nm}
-                       ) "HOSTNAME")
-               "specify database host name."
-            , Hidden)
-          , (Option []        ["sqlLogin"]
-               (ReqArg (\nm flags -> return flags{sqlLogin = nm}
-                       ) "NAME")
-               "specify database login name."
-            , Hidden)
-          , (Option []        ["sqlPwd"]
-               (ReqArg (\nm flags -> return flags{sqlPwd = nm}
-                       ) "STR")
-               "specify database password."
-            , Hidden)
-          ]
-     where pp :: (OptionDef, DisplayMode) -> (OptionDef, DisplayMode)
-           pp (Option a b' c d,e) = (Option a b' c d',e)
-              where d' =  afkappen [] [] (words d) 40
-                    afkappen :: [[String]] -> [String] -> [String] -> Int -> String
-                    afkappen regels []    []   _ = intercalate "\n" (map unwords regels)
-                    afkappen regels totnu []   b = afkappen (regels++[totnu]) [] [] b
-                    afkappen regels totnu (w:ws) b 
-                          | length (unwords totnu) < b - length w = afkappen regels (totnu++[w]) ws b
-                          | otherwise                             = afkappen (regels++[totnu]) [w] ws b     
-           
-                    
-envdirPrototype :: String
-envdirPrototype = "CCdirPrototype"
-envdirOutput :: String
-envdirOutput="CCdirOutput"
-envdbName :: String
-envdbName="CCdbName"
-envlogName :: String
-envlogName="CClogName"
-
-
-verbose :: Options -> String -> IO ()
-verbose flags x
-   | verboseP flags = putStr x
-   | otherwise      = return ()
-   
-verboseLn :: Options -> String -> IO ()
-verboseLn flags x
-   | verboseP flags = -- each line is handled separately, so the buffer will be flushed in time. (see ticket #179)
-                      mapM_ putStrLn (lines x)
-   | otherwise      = return ()
-helpNVersionTexts :: String -> Options -> [String]
-helpNVersionTexts vs flags          = ["Executable: "++show (dirExec flags)++"\n"++
-                                       preVersion flags++vs++postVersion flags++"\n" | showVersion flags]++
-                                      [usageInfo' flags                              | showHelp    flags]
-

− src/lib/DatabaseDesign/Ampersand/Misc/TinyXML.hs 
@@ -1,47 +0,0 @@-{-# OPTIONS_GHC -Wall #-}
-module DatabaseDesign.Ampersand.Misc.TinyXML where
-
-   -----------------some new data types for simple XML structures--------
-   data XTree = Elem { etag :: XTag
-                     , etrees :: [XTree]
-                     }
-              | Node { ntag :: XTag  -- WHY? is Node nodig? Immers een Elem met een lege etrees doet precies hetzelfde...
-                                      -- BECAUSE! De show van een Node laat maar één tag zien. Een Elem showt een begin- en end-tag.
-                     }
-              | PlainText {ptstr :: String}
-   data XTag =  Tag  { tName :: String
-                     , tAtts :: [XAtt]
-                     }
-   data XAtt = Att { attName :: String
-                   , attValue :: String
-                   }
-
-
-   showXTree :: XTree -> String
-   showXTree tree = case tree of
-                        Elem{} -> showStart tag
-                               ++ concatMap showXTree (etrees tree)
-                               ++ showEnd tag
-                                   where tag = etag tree
-                        Node{} -> showNode (ntag tree)
-                        PlainText{} -> show (ptstr tree)
-   showStart :: XTag -> String
-   showStart a = "<" ++ tName a ++ showAtts (tAtts a) ++ ">" 
-  
-   showAtts :: [XAtt] -> String
-   showAtts = concatMap showAtt
-      where showAtt :: XAtt -> String
-            showAtt a= " "++attName a++"="++show (attValue a)
-
-   showEnd :: XTag -> String
-   showEnd a = "</" ++ tName a ++ ">"   
-   
-   showNode :: XTag -> String
-   showNode a = "<" ++ tName a ++ showAtts (tAtts a) ++ "/>"   
-
-   mkAttr :: String -> String -> XAtt
-   mkAttr  = Att 
-   
-   simpleTag :: String -> XTag
-   simpleTag nm = Tag nm []
-   

− src/lib/DatabaseDesign/Ampersand/Output.hs 
@@ -1,6 +0,0 @@-{-# OPTIONS_GHC -Wall #-}
-module DatabaseDesign.Ampersand.Output (module X) where
-import DatabaseDesign.Ampersand.Output.Fspec2Pandoc as X
-       (fSpec2Pandoc)
-import DatabaseDesign.Ampersand.Output.PandocAux as X (writepandoc)
-import DatabaseDesign.Ampersand.Output.Fspec2Excel as X
− src/lib/DatabaseDesign/Ampersand/Output/Fspec2Excel.hs 
@@ -1,153 +0,0 @@-{-# OPTIONS_GHC -Wall #-}
-module DatabaseDesign.Ampersand.Output.Fspec2Excel (fspec2Workbook,showSpreadsheet)
-where
-import Text.XML.SpreadsheetML.Builder
-import Text.XML.SpreadsheetML.Types
-import Text.XML.SpreadsheetML.Writer (showSpreadsheet)
-import DatabaseDesign.Ampersand.Misc
-import DatabaseDesign.Ampersand.Fspec
-import DatabaseDesign.Ampersand.Core.AbstractSyntaxTree
-import DatabaseDesign.Ampersand.Fspec.FPA
-import DatabaseDesign.Ampersand.Basics
-
-fspec2Workbook :: Fspc -> Options -> Workbook
-fspec2Workbook fSpec flags =
-   Workbook
-      { workbookDocumentProperties = Just
-          DocumentProperties { documentPropertiesTitle = Just $ "FunctiePuntAnalyse van "++baseName flags
-                             , documentPropertiesSubject = Nothing
-                             , documentPropertiesKeywords  = Nothing
-                             , documentPropertiesDescription = Just $ "Dit document is gegenereerd dmv. "++ampersandVersionStr++"."
-                             , documentPropertiesRevision = Nothing
-                             , documentPropertiesAppName = Just "Ampersand"
-                             , documentPropertiesCreated = Just $ show (genTime flags)
-                             }
-      , workbookWorksheets = [pimpWs wsResume,pimpWs wsDatasets,pimpWs wsFunctions]
-      }
-  where
-    lang = fsLang fSpec
-    wsResume =
-      Worksheet { worksheetName =
-                            Name $ case lang of
-                                    English -> "Resume"
-                                    Dutch   -> "Overzicht"
-                , worksheetTable = Just $ emptyTable 
-                    { tableRows = 
-                          [ mkRow [string $ case lang of
-                                               English -> "Detailed function point count (according to NESMA 2.1) of the application "
-                                               Dutch   -> "Gedetailleerde functiepunentelling (volgens NESMA 2.2) van het systeem "
-                                             ++ baseName flags
-                                  ]
-                          , emptyRow
-                          , mkRow [string totalen]
-                          , mkRow [string gegevensverzamelingen,(number.fromIntegral) totaalFPgegevensverzamelingen]
-                          , mkRow [string gebruikerstransacties,(number.fromIntegral) totaalFPgebruikerstransacties]
-                          , mkRow [string grandTotaal,(number.fromIntegral) (totaalFPgegevensverzamelingen + totaalFPgebruikerstransacties)]
-                          , emptyRow
-                          , mkRow [string $ case lang of
-                                    English -> "For this function point count it is assumed that:"
-                                    Dutch   -> "Voor deze telling is aangenomen dat:"
-                                  ]
-                          , mkRow [string $ case lang of
-                                    English -> "- the application is built from scratch."
-                                    Dutch   -> "- het een nieuw informatiesyteem betreft."
-                                  ]
-                          , mkRow [string $ case lang of
-                                    English -> "- all persistent information will be stored internally"
-                                    Dutch   -> "- alle informatie wordt intern opgeslagen"
-                                  ]
-                          ]
-                    }
-                }    
-    wsDatasets = 
-      Worksheet { worksheetName = Name $ gegevensverzamelingen
-                , worksheetTable = Just $ emptyTable 
-                    { tableRows = 
-                          [ mkRow [string gegevensverzamelingen, (number.fromIntegral.length.plugInfos) fSpec]
-                          ] ++ 
-                          map (mkRow.showDetailsOfPlug)(plugInfos fSpec)
-                       ++ map mkRow [replicate 3 emptyCell ++ [string totaal, (number.fromIntegral) totaalFPgegevensverzamelingen]]
-                    }
-                }
-    -- TODO: Also count the PHP plugs
-    totaalFPgegevensverzamelingen :: Int
-    totaalFPgegevensverzamelingen = (sum.(map fPoints)) [pSql | InternalPlug pSql <- plugInfos fSpec]
-    wsFunctions = 
-      Worksheet { worksheetName  = Name $ gebruikerstransacties
-                , worksheetTable = Just $ emptyTable 
-                    { tableRows = 
-                          [ mkRow [string $ gebruikerstransacties, (number.fromIntegral.length.interfaceS) fSpec]
-                          ] 
-                          ++ map (mkRow.showDetailsOfFunction) (interfaceS fSpec)
-                          ++ map mkRow [replicate 4 emptyCell ++ [string totaal, (number.fromIntegral.sum.(map fPoints)) (interfaceS fSpec)]]
-                          ++ map mkRow [[string "Gegenereerde interfaces" , (number.fromIntegral.length.interfaceG) fSpec]]
-                          ++ map (mkRow.showDetailsOfFunction) (interfaceG fSpec)
-                          ++ map mkRow [replicate 4 emptyCell ++ [string totaal, (number.fromIntegral.sum.(map fPoints)) (interfaceG fSpec)]]
-                          ++ map mkRow [replicate 5 emptyCell ++ [string grandTotaal, (number.fromIntegral) totaalFPgebruikerstransacties ]]
-                    }
-                }
-    totaalFPgebruikerstransacties :: Int
-    totaalFPgebruikerstransacties = (sum.(map fPoints)) (interfaceS fSpec++interfaceG fSpec)
-    gegevensverzamelingen :: String
-    gegevensverzamelingen = case lang of
-       Dutch   -> "Gegevensverzamelingen"
-       English -> "Data function types"
-
-    gebruikerstransacties :: String
-    gebruikerstransacties = case lang of
-       Dutch   -> "Gebruikerstransacties"
-       English -> "Transactional function types"
-    totalen :: String
-    totalen = case lang of
-       Dutch   -> "Totalen:"
-       English -> "Totals:"
-    totaal :: String
-    totaal = case lang of
-       Dutch   -> "Totaal:"
-       English -> "Total:"
-    grandTotaal :: String
-    grandTotaal = case lang of
-       Dutch   -> "Grandtotaal:"
-       English -> "Grand total:"
-    
-    showDetailsOfPlug :: PlugInfo -> [Cell]
-    showDetailsOfPlug plug =
-       [ emptyCell
-       , (string.name) plug
-       , string (case plug of
-                  InternalPlug p -> showFPA lang p
-                  ExternalPlug _ -> "???"
-                )
-       , (number.fromIntegral) (case plug of
-                                 InternalPlug p -> fPoints p
-                                 ExternalPlug _ -> 0
-                               )
-       , string ( case (lang,plug) of
-                   (English, ExternalPlug _)             -> "PHP plugs are not (yet) taken into account!"
-                   (Dutch  , ExternalPlug _)             -> "PHP plugs worden (nog) niet meegerekend!"
-                   (English, InternalPlug p@TblSQL{})    -> "Table with "++(show.length.fields) p++" attributes."
-                   (Dutch  , InternalPlug p@TblSQL{})    -> "Tabel met "++(show.length.fields) p++" attributen."
-                   (English, InternalPlug   BinSQL{})    -> "Link table"
-                   (Dutch  , InternalPlug   BinSQL{})    -> "Koppel tabel"
-                   (English, InternalPlug   ScalarSQL{}) -> "Enumeration tabel"
-                   (Dutch  , InternalPlug   ScalarSQL{}) -> "Toegestane waarden tabel"
-                )
-       ] 
-    showDetailsOfFunction :: Interface -> [Cell]
-    showDetailsOfFunction ifc =
-       [ emptyCell
-       , (string.name.ifcObj) ifc
-       , string (showFPA lang ifc)
-       , (number.fromIntegral.fPoints) ifc
-       ]
-    
-pimpWs :: Worksheet -> Worksheet
-pimpWs ws = ws{worksheetTable = fmap pimpWsT (worksheetTable ws)
-              }
-pimpWsT :: Table -> Table
-pimpWsT t = t{tableColumns = map (\c -> c{columnAutoFitWidth = Just AutoFitWidth}) 
-                              (tableColumns t ++ replicate (maximum (map (length.rowCells) (tableRows t))) emptyColumn)
-             ,tableRows = map pimpRow (tableRows t)
-             }
-pimpRow :: Row -> Row
-pimpRow r = r{rowAutoFitHeight = Just AutoFitHeight}
− src/lib/DatabaseDesign/Ampersand/Output/Fspec2Pandoc.hs 
@@ -1,106 +0,0 @@-{-# OPTIONS_GHC -Wall #-}-{-# LANGUAGE ScopedTypeVariables #-}-module DatabaseDesign.Ampersand.Output.Fspec2Pandoc (fSpec2Pandoc)-where-import DatabaseDesign.Ampersand.Output.ToPandoc.SharedAmongChapters-import DatabaseDesign.Ampersand.Output.ToPandoc.ChapterInterfaces         (chpInterfacesBlocks, chpInterfacesPics)-import DatabaseDesign.Ampersand.Output.ToPandoc.ChapterIntroduction       (chpIntroduction)-import DatabaseDesign.Ampersand.Output.ToPandoc.ChapterNatLangReqs        (chpNatLangReqs)-import DatabaseDesign.Ampersand.Output.ToPandoc.ChapterDiagnosis          (chpDiagnosis)-import DatabaseDesign.Ampersand.Output.ToPandoc.ChapterConceptualAnalysis (chpConceptualAnalysis)-import DatabaseDesign.Ampersand.Output.ToPandoc.ChapterProcessAnalysis    (chpProcessAnalysis)-import DatabaseDesign.Ampersand.Output.ToPandoc.ChapterECArules           (chpECArules)-import DatabaseDesign.Ampersand.Output.ToPandoc.ChapterDataAnalysis       (chpDataAnalysis)-import DatabaseDesign.Ampersand.Output.ToPandoc.ChapterSoftwareMetrics    (fpAnalysis)-import DatabaseDesign.Ampersand.Output.ToPandoc.ChapterGlossary           (chpGlossary)-import Data.Time.Format (formatTime)-import Data.List (nub)---import Debug.Trace---DESCR ->---The functional specification starts with an introduction---The second chapter defines the functionality of the system for stakeholders.---Because we assume these stakeholders to speak the language of the primary process without any technical knowledge,---the second chapter contains natural language only. ---The third chapter is intended for the analyst. It contains all the rules mentioned in---natural language in the second chapter. It presents the trace from natural language---to the formal rule.---The fourth chapter presents a datamodel together with all the multiplicity rules.--- by datasets and rules.---Datasets are specified through PLUGS in Ampersand. The dataset is build around one concept, ---also called the theme. Functionalities defined on the theme by one or more plugs are---described together with the rules that apply to the dataset. Rules not described by---the dataset are described in the last section of chapter 2.---The following chapters each present a INTERFACE---The specification end with a glossary.-------TODO: Invent a syntax for meta information that is included in the source file...----The following general requirements apply to the functional specification document:---Descriptive title, number, identifier, etc. of the specification---Date of last effective revision and revision designation---A logo (trademark recommended) to declare the document copyright, ownership and origin---Table of Contents---Person, office, or agency responsible for questions on the specification, updates, and deviations.---The significance, scope or importance of the specification and its intended use.---Terminology, definitions and abbreviations to clarify the meanings of the specification---Test methods for measuring all specified characteristics---Material requirements: physical, mechanical, electrical, chemical, etc. Targets and tolerances.---Performance testing requirements. Targets and tolerances.---Drawings, photographs, or technical illustrations---Workmanship---Certifications required.---Safety considerations and requirements---Environmental considerations and requirements---Quality control requirements, Sampling (statistics), inspections, acceptance criteria---Person, office, or agency responsible for enforcement of the specification.---Completion and delivery.---Provisions for rejection, reinspection, rehearing, corrective measures---References and citations for which any instructions in the content maybe required to fulfill the traceability and clarity of the document---Signatures of approval, if necessary---Change record to summarize the chronological development, revision and completion if the document is to be circulated internally---Annexes and Appendices that are expand details, add clarification, or offer options.--fSpec2Pandoc :: Fspc -> Options -> (Pandoc, [Picture])-fSpec2Pandoc fSpec flags = ( myDoc , concat picturesByChapter )-  where -    myDoc = -      ( (setTitle  -           (case metaValues "title" fSpec of-                [] -> text (case (fsLang fSpec, diagnosisOnly flags) of-                                 (Dutch  , False) -> "Functionele Specificatie van "-                                 (English, False) -> "Functional Specification of "-                                 (Dutch  ,  True) -> "Diagnose van "-                                 (English,  True) -> "Diagnosis of "-                           ) <> (singleQuoted.text.name) fSpec-                titles -> (text.concat.nub) titles --reduce doubles, for when multiple script files are included, this could cause titles to be mentioned several times.-           )-        )-      . (setAuthors (case metaValues "authors" fSpec of-                [] -> case fsLang fSpec of-                        Dutch   -> [text "Specificeer auteurs in ADL met: META \"authors\" \"<auteursnamen>\""]-                        English -> [text "Specify authors in ADL with: META \"authors\" \"<author names>\""]-                xs -> map text (nub xs))  --reduce doubles, for when multiple script files are included, this could cause authors to be mentioned several times.-        )-      . (setDate (text (formatTime (lclForLang (fsLang fSpec)) "%-d %B %Y" (genTime flags))))-      ) -      (doc (foldr (<>) mempty docContents))-    docContents :: [Blocks]-    picturesByChapter :: [[Picture]]-    (docContents, picturesByChapter) = unzip [fspec2Blocks chp | chp<-chaptersInDoc flags]--    fspec2Blocks :: Chapter -> (Blocks, [Picture])-    fspec2Blocks Intro              = (chpIntroduction        fSpec flags, [])-    fspec2Blocks SharedLang         = (chpNatLangReqs       0 fSpec flags, [])-    fspec2Blocks Diagnosis          = chpDiagnosis            fSpec flags-    fspec2Blocks ConceptualAnalysis = chpConceptualAnalysis 0 fSpec flags-    fspec2Blocks ProcessAnalysis    = chpProcessAnalysis    0 fSpec flags-    fspec2Blocks DataAnalysis       = chpDataAnalysis         fSpec flags -    fspec2Blocks SoftwareMetrics    = (fpAnalysis             fSpec flags, [])-    fspec2Blocks EcaRules           = (chpECArules            fSpec flags, [])-    fspec2Blocks Interfaces         = (chpInterfacesBlocks  0 fSpec flags, chpInterfacesPics fSpec flags)-    fspec2Blocks Glossary           = (chpGlossary          0 fSpec flags, [])-    -
− src/lib/DatabaseDesign/Ampersand/Output/PandocAux.hs 
@@ -1,684 +0,0 @@-{-# OPTIONS_GHC -Wall #-}-{-# LANGUAGE OverloadedStrings #-}-module DatabaseDesign.Ampersand.Output.PandocAux-      ( writepandoc-      , labeledThing-      , symDefLabel, symDefRef-      , symReqLabel, symReqRef, symReqPageRef-      , xrefSupported-      , pandocEqnArray-      , pandocEqnArrayOnelabel-      , pandocEquation-      , makeDefinition, uniquecds-      , count-      , ShowMath(..)-      , latexEscShw, escapeNonAlphaNum-      , xrefCitation-      , texOnly_Id-      , texOnly_fun-      , texOnly_rel-      , commaEngPandoc, commaNLPandoc-      , commaEngPandoc', commaNLPandoc'-      )-where-import DatabaseDesign.Ampersand.ADL1-import DatabaseDesign.Ampersand.Fspec-import Data.Char hiding (Space)-import Text.Pandoc-import Text.Pandoc.Builder-import DatabaseDesign.Ampersand.Core.AbstractSyntaxTree-import DatabaseDesign.Ampersand.Basics hiding (hPutStrLn)-import Prelude hiding (writeFile,readFile,getContents,putStr,putStrLn)-import DatabaseDesign.Ampersand.Misc        -import System.Process      (system)-import System.Exit         (ExitCode(ExitSuccess,ExitFailure))-import System.IO              (hPutStrLn, stderr)-import System.FilePath       -- (combine,addExtension,replaceExtension)-import System.Directory-import System.Info (os)-import Data.Monoid-import Data.List              (isInfixOf,intercalate)-import Control.Monad-import Data.Maybe--fatal :: Int -> String -> a-fatal = fatalMsg "Output.PandocAux"----- | Default key-value pairs for use with the Pandoc template-defaultWriterVariables :: Options -> Fspc -> [(String , String)]-defaultWriterVariables flags fSpec-  = [ ("title", (case (fsLang fSpec, diagnosisOnly flags) of-                        (Dutch  , False) -> "Functionele Specificatie van "-                        (English, False) -> "Functional Specification of "-                        (Dutch  ,  True) -> "Diagnose van "-                        (English,  True) -> "Diagnosis of " -                )++name fSpec)- --   , ("mainfont",- --   , ("sansfont",- --   , ("monofont",- --   , ("mathfont",-    , ("fontsize", "10pt,a4paper")   --can be overridden by geometry package (see below)-    , ("lang"    , case fsLang fSpec of-                       Dutch   -> "dutch"-                       English -> "english")-    , ("mainlang", case fsLang fSpec of-                       Dutch   -> "dutch"-                       English -> "english")-    , ("documentclass","report")-    ] ++-    [ ("toc" , "<<TheTableOfContentsShouldGoHere>>") | not (diagnosisOnly flags)]++-    [ ("header-includes", unlines -         [ "% ============Ampersand specific Begin================="-         , "\\usepackage[toc]{glossaries}    % package used to define terms"-         , "\\makeglossaries"-         , "\\usepackage{breqn}"-         , "\\usepackage{colonequals}"-         , "% == [all]{hypcap} after {hyperref} shows the ref'd picture i.o. the caption @ click =="-         , "\\usepackage[all]{hypcap}"-         , "\\def\\id#1{\\mbox{\\em #1\\/}}"-         , "\\newcommand{\\marge}[1]{\\marginpar{\\begin{minipage}[t]{3cm}{\\noindent\\small\\em #1}\\end{minipage}}}"-         , "\\def\\define#1{\\label{dfn:#1}\\index{#1}{\\em #1}}"-         , "\\def\\defmar#1{\\label{dfn:#1}\\index{#1}\\marge{#1}{\\em #1}}"-         , "\\newcommand{\\iden}{\\mathbb{I}}"-         , "\\newcommand{\\ident}[1]{\\mathbb{I}_{#1}}"-         , "\\newcommand{\\full}{\\mathbb{V}}"-         , "\\newcommand{\\fullt}[1]{\\mathbb{V}_{[#1]}}"-         , "\\newcommand{\\flip}[1]{{#1}^\\smallsmile} %formerly:  {#1}^\\backsim"-         , "\\newcommand{\\kleeneplus}[1]{{#1}^{+}}"-         , "\\newcommand{\\kleenestar}[1]{{#1}^{*}}"-         , "\\newcommand{\\asterisk}{*}"-         , "\\newcommand{\\cmpl}[1]{\\overline{#1}}"-         , "\\newcommand{\\subs}{\\vdash}"-         , "\\newcommand{\\rel}{\\times}"-         , "\\newcommand{\\fun}{\\rightarrow}"-         , "\\newcommand{\\isa}{\\sqsubseteq}"-         , "\\newcommand{\\N}{\\mbox{\\msb N}}"-         , "\\newcommand{\\disjn}[1]{\\id{disjoint}(#1)}"-         , "\\newcommand{\\fsignat}[3]{\\id{#1}:\\id{#2}\\fun\\id{#3}}"-         , "\\newcommand{\\signat}[3]{\\id{#1}:\\id{#2}\\rel\\id{#3}}"-         , "\\newcommand{\\signt}[2]{\\mbox{\\({#1}_{[{#2}]}\\)}}"-         , "\\newcommand{\\declare}[3]{\\id{#1}:\\ \\id{#2}\\rel\\id{#3}}"-         , "\\newcommand{\\fdeclare}[3]{\\id{#1}:\\ \\id{#2}\\fun\\id{#3}}"-         , "% ============Ampersand specific End==================="-         ])---    , ("geometry", "margin=2cm, a4paper")-    ]-         -     ---DESCR -> functions to write the pandoc---         String = the name of the outputfile---         The first IO() is a Pandoc output format---         The second IO(): If the output format is latex, then this IO() generates a .pdf from the .tex-writepandoc :: Options -> Fspc -> Pandoc -> (String,IO(),IO())-writepandoc flags fSpec thePandoc = (outputFile,makeOutput,postProcessMonad)-         where-         outputFile = addExtension (combine (dirOutput flags) (baseName flags)) -                                       (case fspecFormat flags of        -                                                 Fasciidoc     -> ".txt"-                                                 Fcontext      -> ".context"-                                                 Fdocbook      -> ".docbook"-                                                 Fman          -> ".man"-                                                 Fmarkdown     -> ".md"-                                                 Fmediawiki    -> ".mediawiki"-                                                 Forg          -> ".org"-                                                 Fplain        -> ".plain"-                                                 Frst          -> ".rst"-                                                 FPandoc       -> ".pandoc"-                                                 Frtf          -> ".rtf"-                                                 FLatex        -> ".tex"-                                                 Fhtml         -> ".html"-                                                 Fopendocument -> ".odt"-                                                 Ftexinfo      -> ".texinfo"-                                                 Ftextile      -> ".textile"-                                       )-         makeOutput-            =  do template <- readDefaultTemplate fSpecFormatString-                  verboseLn flags ("Generating "++fSpecFormatString++" to : "++outputFile)-                  writeFile outputFile (pandocWriter (writerOptions template) thePandoc)-                  verboseLn flags "Variables to set in the template:"-                  verboseLn flags (intercalate "\n   " (map show (writerVariables (writerOptions template))))-                  verboseLn flags "... done."-           where -              pandocWriter :: WriterOptions -> Pandoc -> String-              pandocWriter =-                case fspecFormat flags of-                  Fasciidoc -> fatal 145 "No current support for asciidoc" -                  FPandoc   -> writeNative -                  Fcontext  -> writeConTeXt-                  Fdocbook  -> writeDocbook -                  Fhtml     -> writeHtmlString-                  FLatex    -> writeLaTeX-                  Fman      -> writeMan-                  Fmarkdown -> writeMarkdown -                  Fmediawiki -> writeMediaWiki -                  Fopendocument -> writeOpenDocument-                  Forg -> writeOrg-                  Fplain -> writePlain-                  Frst -> writeRST-                  Frtf -> writeRTF-                  Ftexinfo -> writeTexinfo-                  Ftextile -> writeTextile-              fSpecFormatString :: String-              fSpecFormatString =-                case fspecFormat flags of-                  FPandoc   -> "pandoc"-                  Fasciidoc -> "asciidoc"-                  Fcontext  -> "context"-                  Fdocbook  -> "docbook"-                  Fhtml     -> "html"-                  FLatex    -> "latex"-                  Fman      -> "man"-                  Fmarkdown -> "markdown"-                  Fmediawiki -> "mediawiki"-                  Fopendocument -> "opendocument"-                  Forg -> "org"-                  Fplain -> "plain"-                  Frst -> "rst"-                  Frtf -> "rtf"-                  Ftexinfo -> "texinfo"-                  Ftextile -> "textile"                  -              readDefaultTemplate :: String -> IO(Maybe String)-              readDefaultTemplate  s = -                do { let fp = ampersandDataDir flags </> ".." </> "outputTemplates" </> "default."++s-                   ; exists <- doesFileExist fp-                   ; (if exists -                      then do verboseLn flags $ "Using Template: "++fp-                              contents <- readFile fp-                              return $ Just contents -                      else do verboseLn flags $ "Template file does not exist: "++fp-                              verboseLn flags "...trying without template...(but you might want to reinstall ampersand...)" -                              return Nothing -                     )-                   } -              writerOptions :: Maybe String -> WriterOptions-              writerOptions template = case theme flags of-                          ProofTheme -> ampersandDefaultWriterOptions -                                           { writerTableOfContents=False-                                           , writerNumberSections=False-                                           }-                          _          -> ampersandDefaultWriterOptions-                     where-                       ampersandDefaultWriterOptions =-                         def-                            { writerStandalone=isJust template-                            , writerTableOfContents=True-                            , writerNumberSections=True-                            , writerTemplate=fromMaybe "" template-                            , writerVariables=defaultWriterVariables flags fSpec}-         postProcessMonad :: IO()-         postProcessMonad = -           case fspecFormat flags of   -               FLatex  -> do -                          (ready,nrOfRounds) <- doRestOfPdfLatex (False, 0)  -- initialize with: (<NotReady>, <0 rounds so far>)-                          verboseLn flags ("PdfLatex was called "++-                                          (if nrOfRounds>1 then show nrOfRounds++" times" else "once")++-                                          if ready then "."-                                                   else ", but did not solve all references!")-                             where -                                doRestOfPdfLatex :: (Bool,Int) -> IO (Bool,Int)-                                doRestOfPdfLatex (ready, roundsSoFar)-                                  = if ready || roundsSoFar > 4    -- Make sure we will not hit a loop when something is wrong with call to pdfLatex ...-                                    then return (ready, roundsSoFar)-                                    else do callPdfLatexOnce-                                            let needle = "Rerun to get cross-references right." -- This is the text of the LaTeX Warning telling that label(s) may have changed. -                                            {- The log file should be renamed before reading, because readFile opens the file-                                               for lazy IO. In a next run, pdfLatex will try to write to the log file again. If it-                                               was read using readFile, it will fail because the file is still open. 8-((  -                                            -} -                                            renameFile (replaceExtension outputFile "log") (replaceExtension outputFile ("log"++show roundsSoFar))-                                            haystack <- readFile (replaceExtension outputFile ("log"++show roundsSoFar))  -                                            let notReady =  needle `isInfixOf` haystack-                                            when notReady (verboseLn flags "Another round of pdfLatex is required. Hang on...")-                                          --  when notReady (dump "log")  -- Need to dump the last log file, otherwise pdfLatex cannot write its log.-                                            doRestOfPdfLatex (not notReady, roundsSoFar +1)--                                callPdfLatexOnce :: IO ()-                                callPdfLatexOnce = -                                   do result <- if os `elem` ["mingw32","mingw64","cygwin","windows"] --REMARK: not a clear enum to check for windows OS-                                                then system ( pdfLatexCommand++-                                                              if verboseP flags then "" else "> "++combine (dirOutput flags) "pdflog" ) >>-                                                     system  makeIndexCommand-                                                --REMARK: MikTex is windows; Tex-live does not have the flag -include-directory.-                                                else system ( "cd "++dirOutput flags++-                                                              " && pdflatex "++commonFlags++-                                                              texFilename ++ if verboseP flags then "" else "> "++addExtension(baseName flags) ".pdflog" ) >>-                                                     system makeIndexCommand-                                      case result of -                                         ExitSuccess   -> verboseLn flags "PDF file created."-                                         ExitFailure _ -> hPutStrLn stderr $  if verboseP flags -                                                                              then "" -- in verbose mode, Latex already gave plenty of information-                                                                              else "\nLatex error.\nFor more information, run pdflatex on "++texFilename++-                                                                                    " or rerun ampersand with the --verbose option"-                                      where-                                      pdfLatexCommand = "pdflatex "++commonFlags++pdfflags++ outputFile-                                      --makeIndexCommand = "makeglossaries "++replaceExtension outputFile "glo"-                                      --makeindex uses the error stream for verbose stuff...-                                      makeIndexCommand = "makeindex -s "++replaceExtension outputFile "ist"++" -t "++replaceExtension outputFile "glg"++" -o "++replaceExtension outputFile "gls"++" "++replaceExtension outputFile "glo 2> "++combine (dirOutput flags) "glossaries.log"-                                      pdfflags = (if verboseP flags then "" else " --disable-installer") ++-                                                 " -include-directory="++dirOutput flags++ " -output-directory="++dirOutput flags++" "-                                      texFilename = addExtension (baseName flags) ".tex"-                                      commonFlags = if verboseP flags then "" else "--interaction=nonstopmode " -- MacTex options are normally with one '-', but '--interaction' is accepted -                                      -- when verbose is off, let latex halt on error to prevent waiting for user input without prompting for it-                                      -- on windows, we also do --disable-installer, since otherwise a missing package may cause interaction,-                                      -- even with --interaction=nonstopmode.-               _  -> return()            -------Linguistic goodies----------------------------------------count :: Lang -> Int -> String -> String-count    lang    n      x- = case (lang, n) of-      (Dutch  , 0) -> "geen "++plural Dutch x-      (Dutch  , 1) -> "één "++x-      (Dutch  , 2) -> "twee "++plural Dutch x-      (Dutch  , 3) -> "drie "++plural Dutch x-      (Dutch  , 4) -> "vier "++plural Dutch x-      (Dutch  , 5) -> "vijf "++plural Dutch x-      (Dutch  , 6) -> "zes "++plural Dutch x-      (Dutch  , _) -> show n++" "++plural Dutch x-      (English, 0) -> "no "++plural English x-      (English, 1) -> "one "++x-      (English, 2) -> "two "++plural English x-      (English, 3) -> "three "++plural English x-      (English, 4) -> "four "++plural English x-      (English, 5) -> "five "++plural English x-      (English, 6) -> "six "++plural English x-      (English, _) -> show n++" "++plural English x-    -      ------- Symbolic referencing -----------------------------------class SymRef a where-  symLabel :: a -> String -- unique label for symbolic reference purposes-  symReqLabel :: a -> String  -- labels the requirement of a-  symReqLabel   c = "\\label{Req"++symLabel c++"}"-  symDefLabel :: a -> String  -- labels the definition of a-  symDefLabel   c = "\\label{Def"++symLabel c++"}"-  symReqRef :: a -> String  -- references the requirement of a-  symReqRef     c = "\\ref{Req"++symLabel c++"}"-  symDefRef :: a -> String  -- references the definition of a -  symDefRef     c = "\\ref{Def"++symLabel c++"}"-  symReqPageRef :: a -> String  -- references the requirement of a-  symReqPageRef c = "\\pageref{Req"++symLabel c++"}"-  symDefPageRef :: a -> String  -- references the definition of a -  symDefPageRef c = "\\pageref{Def"++symLabel c++"}"--instance SymRef ConceptDef where-  symLabel cd = "Concept:"++escapeNonAlphaNum (cdcpt cd)--instance SymRef A_Concept where-  symLabel c = "Concept:"++escapeNonAlphaNum (name c)--instance SymRef Declaration where-  symLabel d = "Decl:"++escapeNonAlphaNum (name d++name (source d)++name (target d))--instance SymRef Rule where-  symLabel r = "Rule:"++escapeNonAlphaNum (name r)--instance SymRef PlugInfo where-  symLabel p = "PlugInfo "++escapeNonAlphaNum (name p)----   xrefChptReference :: String -> [Inline]---   xrefChptReference myLabel = [RawInline (Text.Pandoc.Builder.Format "latex") ("\\ref{section:"++myLabel++"}")] --TODO werkt nog niet correct----   xrefTableReference :: String -> [Inline]---   xrefTableReference myLabel = [RawInline (Text.Pandoc.Builder.Format "latex") ("\\ref{tab:"++myLabel++"}")]--- BECAUSE: Why (SJ) does the code of labeledHeader look stupid?---         When Han looked at pandoc code TexInfo.hs blockToTexinfo ln.208,---         he expected chapter,section,sub,subsub respectively.---         However, he got section,sub,subsub,plain text respectively.---         Looks like an error in PanDoc, doesn't it?---         So now he wrote chapters as 0 setting a [Inline] -> [RawInline (Text.Pandoc.Builder.Format "latex") "\\chapter{...}"].---         We do not know yet how this relates to other formats like rtf.---- TODO: Fix the other labeled 'things', to make a neat reference.-labeledThing :: Options -> Int -> String -> String -> Blocks-labeledThing flags lev lbl t =-    header (lev+1) -       ((text t <> xrefLabel flags lbl))  - --- | A label that can be cross referenced to. (only for output formats that support this feature)-xrefLabel :: Options -> String -> Inlines        -- uitbreidbaar voor andere rendering dan LaTeX-xrefLabel flags myLabel-   = if xrefSupported flags-     then rawInline "latex" ("\\label{"++escapeNonAlphaNum myLabel++"}")-     else mempty -- fatal 508 "Illegal use of xrefLabel."-xrefSupported :: Options -> Bool-xrefSupported flags = fspecFormat flags `elem` [FLatex] -xrefCitation :: String -> Inline    -- uitbreidbaar voor andere rendering dan LaTeX-xrefCitation myLabel = RawInline (Text.Pandoc.Builder.Format "latex") ("\\cite{"++escapeNonAlphaNum myLabel++"}")----- Para [Math DisplayMath "\\id{aap}=A\\times B\\\\\n\\id{noot}=A\\times B\n"]-pandocEqnArray :: [(String,String,String)] -> [Block]-pandocEqnArray xs- = [ Para [ RawInline (Text.Pandoc.Builder.Format "latex") ("\\begin{eqnarray}\n   "++-                               intercalate "\\\\\n   " [ a++"&"++b++"&"++c | (a,b,c)<-xs ]++-                               "\n\\end{eqnarray}") ]-   | not (null xs)]-   -pandocEqnArrayOnelabel :: String -> [(String,String,String)] -> [Block]-pandocEqnArrayOnelabel label xs- = case xs of-    []           -> []-    (a,b,c):rest -> [ Para [ RawInline (Text.Pandoc.Builder.Format "latex") ("\\begin{eqnarray}\n   "++a++"&"++b++"&"++c++label++"\\\\\n   "++-                               intercalate "\\nonumber\\\\\n   " [ l++"&"++m++"&"++r | (l,m,r)<-rest ]++-                               "\\nonumber\n\\end{eqnarray}")-                    ]      ]-   -pandocEquation :: String -> [Block]-pandocEquation x- = [ Para [ RawInline (Text.Pandoc.Builder.Format "latex") ("\\begin{equation}\n   "++ x ++"\n\\end{equation}") ]-   | not (null x)]----DESCR -> pandoc print functions for Ampersand data structures------------------------------------------- LaTeX math markup------------------------------------------class ShowMath a where- showMath :: a -> String--instance ShowMath A_Concept where- showMath c = texOnly_Id (name c)--instance ShowMath A_Gen where- showMath g@Isa{} = showMath (genspc g)++"\\ \\le\\ "++showMath (gengen g)- showMath g@IsE{} = showMath (genspc g)++"\\ =\\ "++intercalate "\\cap" (map showMath (genrhs g))--instance ShowMath Rule where- showMath r = showMath (rrexp r)--instance ShowMath Sign where- showMath (Sign s t) = showMath s++"\\rel"++showMath t--instance ShowMath Expression where- showMath = showExpr . insParentheses-   where  showExpr (EEqu (l,r)) = showExpr l++texOnly_equals++showExpr r-          showExpr (EImp (l,r)) = showExpr l++texOnly_subs++showExpr r-          showExpr (EIsc (l,r)) = showExpr l++texOnly_inter++showExpr r-          showExpr (EUni (l,r)) = showExpr l++texOnly_union++showExpr r-          showExpr (EDif (l,r)) = showExpr l++texOnly_bx ++showExpr r-          showExpr (ELrs (l,r)) = showExpr l++texOnly_lRes++showExpr r-          showExpr (ERrs (l,r)) = showExpr l++texOnly_rRes++showExpr r-          showExpr (EDia (l,r)) = showExpr l++texOnly_dia++showExpr r-          showExpr (ECps (EEps i sgn,r)) | i==source sgn||i==target sgn = showExpr  r-                                         | otherwise                    = showExpr (ECps (EDcI i,r))-          showExpr (ECps (l,EEps i sgn)) | i==source sgn||i==target sgn = showExpr  l-                                         | otherwise                    = showExpr (ECps (l,EDcI i))-          showExpr (ECps (l,r)) = showExpr l++texOnly_compose++showExpr r-          showExpr (ERad (l,r)) = showExpr l++texOnly_relAdd++showExpr r-          showExpr (EPrd (l,r)) = showExpr l++texOnly_crtPrd++showExpr r-          showExpr (EKl0 e)     = showExpr (addParensToSuper e)++"^{"++texOnly_star++"}"-          showExpr (EKl1 e)     = showExpr (addParensToSuper e)++"^{"++texOnly_plus++"}"-          showExpr (EFlp e)     = showExpr (addParensToSuper e)++"^{"++texOnly_flip++"}"-          showExpr (ECpl e)     = "\\cmpl{"++showExpr e++"}"-          showExpr (EBrk e)     = "("++showExpr e++")"-          showExpr (EDcD d)     = "\\id{"++name d++"}"-          showExpr (EDcI c)     = "I_{\\id{"++name c++"}}"-          showExpr  EEps{}      = "" -- fatal 417 "EEps may occur only in combination with composition (semicolon)."  -- SJ 2014-03-11: Are we sure about this? Let's see if it ever occurs...-          showExpr (EDcV sgn)   = "V_{\\id{"++show (source sgn)++"}\times\\id{"++show (target sgn)++"}}"-          showExpr (EMp1 a _)   = "'{\tt "++a++"}'"---- add extra parentheses to consecutive superscripts, since latex cannot handle these--- (this is not implemented in insParentheses because it is a latex-specific issue)-addParensToSuper :: Expression -> Expression-addParensToSuper e@EKl0{} = EBrk e-addParensToSuper e@EKl1{} = EBrk e-addParensToSuper e@EFlp{} = EBrk e-addParensToSuper e        = e--instance ShowMath Declaration where- showMath decl@(Sgn{})-  = "\\declare{"++latexEscShw(name decl)++"}{"++latexEscShw(name (source decl))++"}{"++latexEscShw(name (target decl))++"}"- showMath Isn{}-  = "\\mathbb{I}"- showMath Vs{}-  = "\\full"---- | latexEscShw escapes to LaTeX encoding. It is intended to be used in LaTeX text mode.---   For more elaborate info on LaTeX encoding, consult the The Comprehensive LATEX Symbol List---   on:    http://ftp.snt.utwente.nl/pub/software/tex/info/symbols/comprehensive/symbols-a4.pdf-latexEscShw :: String -> String-latexEscShw ""           = ""-latexEscShw ('\"':c:cs) | isAlphaNum c = "``"++latexEscShw (c:cs)-                        | otherwise    = "''"++latexEscShw (c:cs)-latexEscShw "\""        = "''"-latexEscShw (c:cs)      | isAlphaNum c && isAscii c = c:latexEscShw cs-                        | otherwise    = f c++latexEscShw cs- where-  f '"' = "\\textquotedbl "-  f '#' = "\\#"-  f '$' = "\\$"-  f '%' = "\\%"-  f '&' = "\\&"-  f '\\'= "\\textbackslash "-  f '^' = "\\^{}"-  f '_' = "\\_"-  f '{' = "\\{"-  f '|' = "\\textbar "-  f '}' = "\\}"-  f '~' = "\\~{}"-  f '¦' = "\\textbrokenbar "-  f '¨' = "\\textasciidieresis "-  f '¯' = "\\textasciimacron "-  f '´' = "\\textasciiacute "-  f '¢' = "\\textcent "-  f '£' = "\\textpound "-  f '¤' = "\\textcurrency "-  f '¥' = "\\textyen "-  f '€' = "\\texteuro "-  f '<' = "\\textless "-  f '>' = "\\textgreater "-  f '±' = "\\textpm "-  f '«' = "\\guillemotleft "-  f '»' = "\\guillemotright "-  f '×' = "\\texttimes "-  f '÷' = "\\textdiv "-  f '§' = "\\S "-  f '©' = "\\textcopyright "-  f '¬' = "\\textlnot "-  f '®' = "\\textregistered "-  f '°' = "\\textdegree "-  f 'µ' = "\\textmu "-  f '¶' = "\\P "-  f '·' = "\\textperiodcentered "-  f '¼' = "\\textonequarter "-  f '½' = "\\textonehalf "-  f '¾' = "\\textthreequarters "-  f '¹' = "\\textonesuperior "-  f '²' = "\\texttwosuperior "-  f '³' = "\\textthreesuperior "-  f '∞' = "\\hbipropto "-  f 'ä' = "\\\"{a}"        --  umlaut or dieresis-  f 'Ä' = "\\\"{A}"        --  umlaut or dieresis-  f 'â' = "\\^{a}"         --  circumflex-  f 'Â' = "\\^{A}"         --  circumflex-  f 'à' = "\\`{a}"         --  grave accent-  f 'À' = "\\`{A}"         --  grave accent-  f 'á' = "\\'{a}"         --  acute accent-  f 'Á' = "\\'{A}"         --  acute accent-  f 'ã' = "\\~{a}"         --  tilde-  f 'Ã' = "\\~{A}"         --  tilde-  f 'å' = "\\aa "---  f 'å' = "\\r{a}"       --  alternatively: ring over the letter-  f 'Å' = "\\AA "---  f 'Å' = "\\r{A}"       --  alternatively: ring over the letter-  f 'ą' = "\\k{a}"         --  ogonek-  f 'Ą' = "\\k{A}"         --  ogonek-  f 'ª' = "\\textordfeminine "-  f 'æ' = "\\ae "-  f 'Æ' = "\\AE "-  f 'ç' = "\\c{c}"         --  cedilla-  f 'Ç' = "\\c{C}"         --  cedilla-  f 'Ð' = "\\DH "-  f 'ð' = "\\dh "-  f 'ë' = "\\\"{e}"        --  umlaut or dieresis-  f 'Ë' = "\\\"{E}"        --  umlaut or dieresis-  f 'ê' = "\\^{e}"         --  circumflex-  f 'Ê' = "\\^{E}"         --  circumflex-  f 'è' = "\\`{e}"         --  grave accent-  f 'È' = "\\`{E}"         --  grave accent-  f 'é' = "\\'{e}"         --  acute accent-  f 'É' = "\\'{E}"         --  acute accent-  f 'ï' = "\\\"{\\i}"      --  umlaut or dieresis-  f 'Ï' = "\\\"{I}"        --  umlaut or dieresis-  f 'î' = "\\^{\\i}"       --  circumflex-  f 'Î' = "\\^{I}"         --  circumflex-  f 'ì' = "\\`{\\i}"       --  grave accent-  f 'Ì' = "\\`{I}"         --  grave accent-  f 'í' = "\\'{\\i}"       --  acute accent-  f 'Í' = "\\'{I}"         --  acute accent-  f 'ł' = "\\l "           --  l with stroke-  f 'Ł' = "\\L "           --  l with stroke-  f 'n' = "\\~{n}"         --  tilde-  f 'Ñ' = "\\~{N}"         --  tilde-  f 'Ȯ' = "\\.{O}"         --  dot over the letter-  f 'ȯ' = "\\.{o}"         --  dot over the letter -  f 'ö' = "\\\"{o}"        --  umlaut or dieresis-  f 'Ö' = "\\\"{O}"        --  umlaut or dieresis-  f 'ô' = "\\^{o}"         --  circumflex-  f 'Ô' = "\\^{O}"         --  circumflex-  f 'ò' = "\\`{o}"         --  grave accent-  f 'Ò' = "\\`{O}"         --  grave accent-  f 'ó' = "\\'{o}"         --  acute accent-  f 'Ó' = "\\'{O}"         --  acute accent-  f 'õ' = "\\~{o}"         --  tilde-  f 'Õ' = "\\~{O}"         --  tilde-  f 'ō' = "\\={o}"         --  macron accent a bar over the letter)-  f 'Ō' = "\\={O}"         --  macron accent a bar over the letter)-  f 'ő' = "\\H{o}"         --  long Hungarian umlaut double acute)-  f 'Ő' = "\\H{O}"         --  long Hungarian umlaut double acute)-  f 'Ø' = "\\O "-  f 'ø' = "\\o "-  f 'º' = "\\textordmasculine "-  f 'ŏ' = "\\u{o}"         --  breve over the letter-  f 'Ŏ' = "\\u{O}"         --  breve over the letter-  f 'œ' = "\\oe "-  f 'Œ' = "\\OE "-  f 'š' = "\\v{s}"         --  caron/hacek "v") over the letter-  f 'Š' = "\\v{S}"         --  caron/hacek "v") over the letter-  f 'ß' = "\\ss "-  f 'Þ' = "\\TH "-  f 'þ' = "\\th "-  f '™' = "\\texttrademark "-  f 'ü' = "\\\"{u}"        --  umlaut or dieresis-  f 'Ü' = "\\\"{U}"        --  umlaut or dieresis-  f 'û' = "\\^{u}"         --  circumflex-  f 'Û' = "\\^{U}"         --  circumflex-  f 'ù' = "\\`{u}"         --  grave accent-  f 'Ù' = "\\`{U}"         --  grave accent-  f 'ú' = "\\'{u}"         --  acute accent-  f 'Ú' = "\\'{U}"         --  acute accent-  f 'ý' = "\\'{y}"         --  acute accent-  f 'Ý' = "\\'{Y}"         --  acute accent-  f _   = [c] -- let us think if this should be:    fatal 661 ("Symbol "++show x++" (character "++show (ord c)++") is not supported")-             ----posixFilePath :: FilePath -> String--- tex uses posix file notation, however when on a windows machine, we have windows conventions for file paths...--- To set the graphicspath, we want something like: \graphicspath{{"c:/data/ADL/output/"}}---posixFilePath fp = "/"++System.FilePath.Posix.addTrailingPathSeparator (System.FilePath.Posix.joinPath   (tail  (splitDirectories fp)))--uniquecds :: Fspc -> A_Concept -> [(String,ConceptDef)]-uniquecds fSpec c- = [ (if length cDefs==1 then cdcpt cd else cdcpt cd++show i , cd)-   | let cDefs=concDefs fSpec c-   , (i,cd)<-zip [(1::Integer)..] cDefs ]--- was: [(if length(cptdf c)==1 then cdcpt cd else cdcpt cd++show i , cd) | (i,cd)<-zip [(1::Integer)..] (cptdf c)]--makeDefinition :: Options -> Int -> String -> String -> String -> String -> [Block]-makeDefinition flags i nm lbl defin ref =-  case fspecFormat flags of-    FLatex ->  [ Para ( [ RawInline (Text.Pandoc.Builder.Format "latex") $ "\\newglossaryentry{"++escapeNonAlphaNum nm ++"}{name={"++latexEscShw nm ++"}, description={"++latexEscShw defin++"}}\n"] ++-                        [ RawInline (Text.Pandoc.Builder.Format "latex") $ lbl ++ "\n" | i == 0] ++-                        [ RawInline (Text.Pandoc.Builder.Format "latex") $ insertAfterFirstWord refStr defStr] ++-                        [ RawInline (Text.Pandoc.Builder.Format "latex") (latexEscShw (" ["++ref++"]")) | not (null ref) ]-                      )-               ]-    _      ->  [ Para ( Str defin : [ Str (" ["++ref++"]") | not (null ref) ] )-               ]- where refStr = "\\marge{\\gls{"++escapeNonAlphaNum nm++"}}" -       defStr = latexEscShw defin-       -- by putting the ref after the first word of the definition, it aligns nicely with the definition-       insertAfterFirstWord s wordsStr = let (fstWord, rest) = break (==' ') wordsStr-                                         in  fstWord ++ s ++ rest-commaEngPandoc' :: Inlines -> [Inlines] -> Inlines-commaEngPandoc' s [a,b,c]= a <> ", " <> b <> ", " <> s <> space <> c-commaEngPandoc' s [a,b]  = a <> space <> s <> space <> b-commaEngPandoc' _   [a]    = a-commaEngPandoc' s (a:as) = a <> ", " <> commaEngPandoc' s as-commaEngPandoc' _   []     = mempty--commaEngPandoc :: Inline -> [Inline] -> [Inline]-commaEngPandoc s [a,b,c]= [a,Str ", ",b,Str ", ",s, Str " ", c]-commaEngPandoc s [a,b]  = [a,Str " ",s, Str " ", b]-commaEngPandoc _   [a]    = [a]-commaEngPandoc s (a:as) = [a, Str ", "]++commaEngPandoc s as-commaEngPandoc _   []     = []--commaNLPandoc' :: Inlines -> [Inlines] -> Inlines-commaNLPandoc' s [a,b]  = a <> space <> s <> space <> b-commaNLPandoc'  _  [a]    = a-commaNLPandoc' s (a:as) = a <> ", " <> commaNLPandoc' s as-commaNLPandoc'  _  []     = mempty-commaNLPandoc :: Inline -> [Inline] -> [Inline]-commaNLPandoc s [a,b]  = [a,Str " ",s, Str " ", b]-commaNLPandoc  _  [a]    = [a]-commaNLPandoc s (a:as) = [a, Str ", "]++commaNLPandoc s as-commaNLPandoc  _  []     = []--------------------------------- LaTeX related stuff ---------------------------------texOnly_Id :: String -> String-texOnly_Id s = "\\id{"++latexEscShw s++"} "--texOnly_fun :: String-texOnly_fun = "\\rightarrow "--texOnly_rel :: String-texOnly_rel = "\\times "--texOnly_compose :: String-texOnly_compose = ";"--texOnly_relAdd :: String-texOnly_relAdd = "\\dagger "--texOnly_crtPrd :: String-texOnly_crtPrd = "\\asterisk "--texOnly_inter :: String-texOnly_inter = "\\cap "--texOnly_union :: String-texOnly_union = "\\cup "--texOnly_subs :: String-texOnly_subs = "\\vdash "--texOnly_equals :: String-texOnly_equals = "="--texOnly_star :: String-texOnly_star = "^* "--texOnly_plus :: String-texOnly_plus = "^+ "--texOnly_bx :: String-texOnly_bx = " - "--texOnly_lRes :: String-texOnly_lRes = " / "--texOnly_rRes :: String-texOnly_rRes = " \\backslash "--texOnly_dia :: String-texOnly_dia = " \\Diamond "--texOnly_flip :: String-texOnly_flip = "\\smallsmile "
− src/lib/DatabaseDesign/Ampersand/Output/PredLogic.hs 
@@ -1,481 +0,0 @@-{-# OPTIONS_GHC -Wall #-} --TODO verder opschonen van deze module
-module DatabaseDesign.Ampersand.Output.PredLogic
-           ( PredLogicShow(..), showLatex, mkVar
-           ) 
-   where
-
-   import Data.List
-   import DatabaseDesign.Ampersand.Basics
-   import DatabaseDesign.Ampersand.ADL1
-   import DatabaseDesign.Ampersand.Classes
-   import DatabaseDesign.Ampersand.Misc
-   import DatabaseDesign.Ampersand.Fspec.ShowADL
-   import Data.Char (toLower)
-   import DatabaseDesign.Ampersand.Output.PandocAux (latexEscShw,texOnly_Id)
-
-   fatal :: Int -> String -> a
-   fatal = fatalMsg "Output.PredLogic"
-
- --  data PredVar = PV String     -- TODO Bedoeld om predicaten inzichtelijk te maken. Er bestaan namelijk nu verschillende manieren om hier mee om te gaan (zie ook Motivations. HJO. 
-   data PredLogic       
-    = Forall [Var] PredLogic            |
-      Exists [Var] PredLogic            |
-      Implies PredLogic PredLogic       |
-      Equiv PredLogic PredLogic         |
-      Conj [PredLogic]                  |
-      Disj [PredLogic]                  |
-      Not PredLogic                     |
-      Pred String String                |  -- Pred nm v, with v::type   is equiv. to Rel nm Nowhere [] (type,type) True (Sgn (showADL e) type type [] "" "" "" [Asy,Sym] Nowhere 0 False)
-      PlK0 PredLogic                    |
-      PlK1 PredLogic                    |
-      R PredLogic Declaration PredLogic |
-      Atom String                       |
-      Funs String [Declaration]         |
-      Dom Expression Var                |
-      Cod Expression Var                deriving Eq
-
-   data Notation = Flr | Frl | Rn | Wrap deriving Eq   -- yields notations y=r(x)  |  x=r(y)  |  x r y  | exists ... respectively.
-
---   predKeyWords l = 
---     case l of
---        English  -> 
-
-   class PredLogicShow a where
-     showPredLogic :: Lang -> a -> String
-     showPredLogic l r =  
-       predLshow (natLangOps l) (toPredLogic r) -- predLshow produces raw LaTeX
-     toPredLogic :: a -> PredLogic
-
-   instance PredLogicShow Rule where
-     toPredLogic ru = assemble (rrexp ru)
-
-   instance PredLogicShow Expression where
-     toPredLogic = assemble
-
-
--- showLatex ought to produce PandDoc mathematics instead of LaTeX source code.
--- PanDoc, however, does not support mathematics sufficiently, as to date. For this reason we have showLatex.
--- It circumvents the PanDoc structure and goes straight to LaTeX source code.
--- TODO when PanDoc is up to the job.
-   showLatex :: PredLogic -> [(String,String,String)]
-   showLatex x
-    = chop (predLshow ("\\forall", "\\exists", implies, "\\Leftrightarrow", "\\vee", "\\ \\wedge\t", "^{\\asterisk}", "^{+}", "\\neg", rel, fun, mathVars, "", " ", apply, "\\in") x)
-      where rel r lhs rhs  -- TODO: the stuff below is very sloppy. This ought to be derived from the stucture, instead of by this naming convention.
-              = if isIdent r then lhs++"\\ =\\ "++rhs else
-                case name r of
-                 "lt"     -> lhs++"\\ <\\ "++rhs
-                 "gt"     -> lhs++"\\ >\\ "++rhs
-                 "le"     -> lhs++"\\ \\leq\\ "++rhs
-                 "leq"    -> lhs++"\\ \\leq\\ "++rhs
-                 "ge"     -> lhs++"\\ \\geq\\ "++rhs
-                 "geq"    -> lhs++"\\ \\geq\\ "++rhs
-                 _        -> lhs++"\\ \\id{"++latexEscShw (name r)++"}\\ "++rhs
-            fun r e = "\\id{"++latexEscShw (name r)++"}("++e++")"
-            implies antc cons = antc++" \\Rightarrow "++cons
-            apply :: Declaration -> String -> String -> String    --TODO language afhankelijk maken. 
-            apply decl d c =
-               case decl of
-                 Sgn{}     -> d++"\\ \\id{"++latexEscShw (name decl)++"}\\ "++c
-                 Isn{}     -> d++"\\ =\\ "++c
-                 Vs{}      -> "V"
-            mathVars :: String -> [Var] -> String
-            mathVars q vs
-             = if null vs then "" else
-               q++" "++intercalate "; " [intercalate ", " var++"\\coloncolon\\id{"++latexEscShw dType++"}" | (var,dType)<-vss]++":\n"
-               where
-                vss = [(map fst varCl,show(snd (head varCl))) |varCl<-eqCl snd vs]
-            chop :: String -> [(String,String,String)]
-            chop str = (map chops.lins) str
-             where
-               lins ""        = []
-               lins ('\n':cs) = "": lins cs
-               lins (c:cs)    = (c:r):rs where r:rs = case lins cs of  [] -> [""] ; e -> e
-               chops cs = let [a,b,c] = take 3 (tabs cs) in (a,b,c)
-               tabs "" = ["","","",""]
-               tabs ('\t':cs) = "": tabs cs
-               tabs (c:cs) = (c:r):rs where r:rs = tabs cs
-
--- natLangOps exists for the purpose of translating a predicate logic expression to natural language.
--- It yields a vector of mostly strings, which are used to assemble a natural language text in one of the natural languages supported by Ampersand.
-   natLangOps :: Identified a => Lang -> (String,
-                                          String,
-                                          String -> String -> String,
-                                          String,
-                                          String,
-                                          String,
-                                          String,
-                                          String,
-                                          String,
-                                          Declaration -> String -> String -> String,
-                                          a -> String -> String,
-                                          String -> [(String, A_Concept)] -> String,
-                                          String,
-                                          String,
-                                          Declaration -> String -> String -> String,
-                                          String)
-   natLangOps l
-            = case l of
--- parameternamen:         (forallP,     existsP,        impliesP, equivP,             orP,  andP,  k0P, k1P, notP,  relP, funP, showVarsP, breakP, spaceP)
-                English -> ("For each",  "There exists", implies, "is equivalent to",  "or", "and", "*", "+", "not",  rel, fun,  langVars , "\n  ", " ", apply, "is element of")
-                Dutch   -> ("Voor elke", "Er is een",    implies, "is equivalent met", "of", "en",  "*", "+", "niet", rel, fun,  langVars , "\n  ", " ", apply, "is element van")
-               where
-                  rel r = apply r
-                  fun r x' = texOnly_Id(name r)++"("++x'++")"
-                  implies antc cons = case l of 
-                                        English  -> "If "++antc++", then "++cons
-                                        Dutch    -> "Als "++antc++", dan "++cons
-                  apply decl d c =
-                     case decl of
-                       Sgn{}     -> if null (prL++prM++prR) 
-                                      then "$"++d++"$ "++decnm decl++" $"++c++"$"
-                                      else prL++" $"++d++"$ "++prM++" $"++c++"$ "++prR
-                          where prL = decprL decl
-                                prM = decprM decl
-                                prR = decprR decl
-                       Isn{}     -> case l of 
-                                        English  -> "$"++d++"$ equals $"++c++"$"
-                                        Dutch    -> "$"++d++"$ is gelijk aan $"++c++"$"
-                       Vs{}      -> case l of 
-                                        English  -> show True
-                                        Dutch    -> "Waar"
-                  langVars :: String -> [(String, A_Concept)] -> String
-                  langVars q vs
-                      = case l of
-                         English | null vs     -> ""
-                                 | q=="Exists" -> 
-                                     intercalate " and " 
-                                     ["there exist"
-                                      ++(if length vs'==1 then "s a "++dType else ' ':plural English dType)
-                                      ++" called "
-                                      ++intercalate ", " ['$':v'++"$" | v'<-vs'] | (vs',dType)<-vss]
-                                 | otherwise   -> "If "++langVars "Exists" vs++", "
-                         Dutch   | null vs     -> ""
-                                 | q=="Er is"  -> 
-                                     intercalate " en "
-                                     ["er "
-                                       ++(if length vs'==1 then "is een "++dType else "zijn "++plural Dutch dType)
-                                       ++" genaamd "
-                                       ++intercalate ", " ['$':v'++"$" | v'<-vs'] | (vs',dType)<-vss]
-                                 | otherwise   -> "Als "++langVars "Er is" vs++", "
-                       where
-                        vss = [(map fst vs',show(snd (head vs'))) |vs'<-eqCl snd vs]
-
--- predLshow exists for the purpose of translating a predicate logic expression to natural language.
--- It uses a vector of operators (mostly strings) in order to produce text. This vector can be produced by, for example, natLangOps.
--- example:  'predLshow (natLangOps l) e' translates expression 'e'
--- into a string that contains a natural language representation of 'e'.
-   predLshow :: ( String                                    -- forallP
-                , String                                    -- existsP
-                , String -> String -> String                -- impliesP
-                , String                                    -- equivP
-                , String                                    -- orP
-                , String                                    -- andP
-                , String                                    -- kleene *
-                , String                                    -- kleene +
-                , String                                    -- notP
-                , Declaration -> String -> String -> String    -- relP
-                , Declaration -> String -> String              -- funP
-                , String -> [(String, A_Concept)] -> String -- showVarsP
-                , String                                    -- breakP
-                , String                                    -- spaceP
-                , Declaration -> String -> String -> String -- apply
-                , String                                    -- set element
-                ) -> PredLogic -> String
-   predLshow (forallP, existsP, impliesP, equivP, orP, andP, k0P, k1P, notP, relP, funP, showVarsP, breakP, spaceP, apply, el)
-    = charshow 0
-        where
-         wrap i j str = if i<=j then str else "("++str++")"
-         charshow :: Integer -> PredLogic -> String
-         charshow i predexpr
-          = case predexpr of
-                  Forall vars restr   -> wrap i 1 (showVarsP forallP vars ++ charshow 1 restr)
-                  Exists vars restr   -> wrap i 1 (showVarsP existsP vars  ++ charshow 1 restr)
-                  Implies antc conseq -> wrap i 2 (breakP++impliesP (charshow 2 antc) (charshow 2 conseq))
-                  Equiv lhs rhs       -> wrap i 2 (breakP++charshow 2 lhs++spaceP++equivP++spaceP++ charshow 2 rhs)
-                  Disj rs             -> if null rs 
-                                         then "" 
-                                         else wrap i 3 (intercalate (spaceP++orP ++spaceP) (map (charshow 3) rs))
-                  Conj rs             -> if null rs 
-                                         then "" 
-                                         else wrap i 4 (intercalate (spaceP++andP++spaceP) (map (charshow 4) rs))
-                  Funs x ls           -> case ls of
-                                            []    -> x
-                                            r:ms  -> if isIdent r then charshow i (Funs x ms) else charshow i (Funs (funP r x) ms)
-                  Dom expr (x,_)      -> x++el++funP (makeRel "dom") (showADL expr)
-                  Cod expr (x,_)      -> x++el++funP (makeRel "cod") (showADL expr)
-                  R pexpr dec pexpr'  -> case (pexpr,pexpr') of
-                                            (Funs l [] , Funs r [])  -> wrap i 5 (apply dec l r)
-{-
-                                            (Funs l [f], Funs r [])  -> wrap i 5 (if isIdent rel
-                                                                                  then apply (makeDeclaration f) l r
-                                                                                  else apply (makeDeclaration rel) (funP f l) r)
-                                            (Funs l [] , Funs r [f]) -> wrap i 5 (if isIdent rel
-                                                                                  then apply (makeDeclaration f) l r
-                                                                                  else apply (makeDeclaration rel) l (funP f r))
--}
-                                            (lhs,rhs)                -> wrap i 5 (relP dec (charshow 5 lhs) (charshow 5 rhs))
-                  Atom atom           -> "'"++atom++"'"
-                  PlK0 rs             -> wrap i 6 (charshow 6 rs++k0P)
-                  PlK1 rs             -> wrap i 7 (charshow 7 rs++k1P)
-                  Not rs              -> wrap i 8 (spaceP++notP++charshow 8 rs)
-                  Pred nm v'          -> nm++"{"++v'++"}"
-         makeRel :: String -> Declaration -- This function exists solely for the purpose of dom and cod
-         makeRel str
-             =    Sgn { decnm   = str
-                      , decsgn  = fatal 217 "Do not refer to decsgn of this dummy relation"
-                      , decprps = [Uni,Tot]
-                      , decprps_calc = Nothing
-                      , decprL  = ""
-                      , decprM  = ""
-                      , decprR  = ""
-                      , decMean = fatal 223 "Do not refer to decMean of this dummy relation"
-                      , decfpos = OriginUnknown
-                      , deciss  = fatal 226 "Do not refer to deciss of this dummy relation"
-                      , decusr  = False
-                      , decpat  = fatal 228 "Do not refer to decpat of this dummy relation"
-                      , decplug = fatal 229 "Do not refer to decplug of this dummy relation"
-                      }
-
---objOrShow :: Lang -> PredLogic -> String
---objOrShow l = predLshow ("For all", "Exists", implies, " = ", " = ", "<>", "OR", "AND", "*", "+", "NOT", rel, fun, langVars l, "\n", " ")
---               where rel r lhs rhs = applyM (makeDeclaration r) lhs rhs
---                     fun r x = x++"."++name r
---                     implies antc cons = "IF "++antc++" THEN "++cons
-
--- The function 'assemble' translates a rule to predicate logic.
--- In order to remain independent of any representation, it transforms the Haskell data structure Rule
--- into the data structure PredLogic, rather than manipulate with texts.
-   type Var = (String,A_Concept)
-   assemble :: Expression -> PredLogic
-   assemble expr
-    = case (source expr, target expr) of
-           (ONE, ONE) -> rc
-           (_  , ONE) -> Forall [s] rc
-           (ONE, _)   -> Forall [t] rc
-           (_  , _)   -> Forall [s,t] rc
-     where
-      [s,t] = mkVar [] [source expr, target expr]
-      rc = f [s,t] expr (s,t)
-      f :: [Var] -> Expression -> (Var,Var) -> PredLogic
-      f exclVars (EEqu (l,r)) (a,b)  = Equiv (f exclVars l (a,b)) (f exclVars r (a,b))
-      f exclVars (EImp (l,r)) (a,b)  = Implies (f exclVars l (a,b)) (f exclVars r (a,b))
-      f exclVars e@EIsc{}     (a,b)  = Conj [f exclVars e' (a,b) | e'<-exprIsc2list e]
-      f exclVars e@EUni{}     (a,b)  = Disj [f exclVars e' (a,b) | e'<-exprUni2list e]
-      f exclVars (EDif (l,r)) (a,b)  = Conj [f exclVars l (a,b), Not (f exclVars r (a,b))]
-      f exclVars (ELrs (l,r)) (a,b)  = Forall [c] (Implies (f eVars r (b,c)) (f eVars l (a,c)))
-                                       where [c]   = mkVar exclVars [target l]
-                                             eVars = exclVars++[c]
-      f exclVars (ERrs (l,r)) (a,b)  = Forall [c] (Implies (f eVars l (c,a)) (f eVars r (c,b)))
-                                       where [c]   = mkVar exclVars [source l]
-                                             eVars = exclVars++[c]
-      f exclVars (EDia (l,r)) (a,b)  = Forall [c] (Equiv (f eVars r (b,c)) (f eVars l (a,c)))
-                                       where [c]   = mkVar exclVars [target l]
-                                             eVars = exclVars++[c]
-      f exclVars e@ECps{}     (a,b)  = fECps exclVars e (a,b)  -- special treatment, see below
-      f exclVars e@ERad{}     (a,b)  = fERad exclVars e (a,b)  -- special treatment, see below
-      f _        (EPrd (l,r)) (a,b)  = Conj [Dom l a, Cod r b]
-      f exclVars (EKl0 e)     (a,b)  = PlK0 (f exclVars e (a,b))
-      f exclVars (EKl1 e)     (a,b)  = PlK1 (f exclVars e (a,b))
-      f exclVars (ECpl e)     (a,b)  = Not (f exclVars e (a,b))
-      f exclVars (EBrk e)     (a,b)  = f exclVars e (a,b)
-      f _ e@(EDcD dcl) ((a,sv),(b,tv)) = res
-       where
-        res = case denote e of
-               Flr  -> R (Funs a [dcl]) (Isn tv) (Funs b [])
-               Frl  -> R (Funs a []) (Isn sv) (Funs b [dcl])
-               Rn   -> R (Funs a []) (dcl) (Funs b [])
-               Wrap -> fatal 246 "function res not defined when denote e == Wrap. "
-      f _ e@(EFlp (EDcD dcl)) ((a,sv),(b,tv)) = res
-       where
-        res = case denote e of
-               Flr  -> R (Funs a [dcl]) (Isn tv) (Funs b [])
-               Frl  -> R (Funs a []) (Isn sv) (Funs b [dcl])
-               Rn   -> R (Funs b []) (dcl) (Funs a [])
-               Wrap -> fatal 253 "function res not defined when denote e == Wrap. "
-      f exclVars (EFlp e)       (a,b) = f exclVars e (b,a)
-      f _ (EMp1 atom _) _             = Atom atom
-      f _ (EDcI _) ((a,_),(b,tv))     = R (Funs a []) (Isn tv) (Funs b [])
-      f _ (EDcV _) _                  = Atom "True"
-      f _ e _ = fatal 298 ("Non-exhaustive pattern in subexpression "++showADL e++" of assemble (<"++showADL expr++">)")
-
--- fECps treats the case of a composition.  It works as follows:
---       An expression, e.g. r;s;t , is translated to Exists (zip ivs ics) (Conj (frels s t)),
---       in which ivs is a list of variables that are used inside the resulting expression,
---       ics contains their types, and frels s t the subexpressions that
---       are used in the resulting conjuct (at the right of the quantifier).
-      fECps :: [Var] -> Expression -> (Var,Var) -> PredLogic
-      fECps exclVars    e             (a,b)
-                               --   f :: [Var] -> Expression -> (Var,Var) -> PredLogic
-        | and [isCpl e' | e'<-es] = f exclVars (deMorganECps e) (a,b)
-        | otherwise               = Exists ivs (Conj (frels a b))
-        where
-         es :: [Expression]
-         es   = [ x | x<-exprCps2list e, not (isEpsilon x) ]
-        -- Step 1: split in fragments at those points where an exists-quantifier is needed.
-        --         Each fragment represents a subexpression with variables
-        --         at the outside only. Fragments will be reconstructed in a conjunct.
-         res :: [(Var -> Var -> PredLogic, A_Concept, A_Concept)]
-         res = pars3 (exclVars++ivs) (split es)  -- yields triples (r,s,t): the fragment, its source and target.
-        -- Step 2: assemble the intermediate variables from at the right spot in each fragment.
-         frels :: Var -> Var -> [PredLogic]
-         frels src trg = [r v w | ((r,_,_),v,w)<-zip3 res' (src: ivs) (ivs++[trg]) ]
-        -- Step 3: compute the intermediate variables and their types
-         res' :: [(Var -> Var -> PredLogic, A_Concept, A_Concept)]
-         res' = [triple | triple<-res, not (atomic triple)]
-         ivs ::  [Var]
-         ivs  = mkvar exclVars ics
-         ics ::  [ Either PredLogic A_Concept ] -- each element is either an atom or a concept
-         ics  = concat
-                [ case (v',w) of
-                    (Left _,    Left _   ) -> []
-                    (Left atom, Right  _ ) -> [ Left atom ]
-                    (Right  _ , Left atom) -> [ Left atom ]
-                    (Right trg, Right  _ ) -> [ Right trg ] -- SJ 20131117, was: (if trg==src then [ Right trg ] else [ Right (trg `meet` src) ])
-                                                            -- This code assumes no ISA's in the A-structure. This works due to the introduction of EEps expressions.
-                | (v',w)<-zip [ case l ("",src) ("",trg) of
-                                 atom@Atom{} -> Left atom
-                                 _           -> Right trg
-                              | (l,src,trg)<-init res]
-                              [ case r ("",src) ("",trg) of
-                                 atom@Atom{} -> Left atom
-                                 _           -> Right src
-                              | (r,src,trg)<-tail res]
-                ]
-      atomic :: (Var -> Var -> PredLogic, A_Concept, A_Concept) -> Bool
-      atomic (r,a,b) = case r ("",a) ("",b) of
-                        Atom{} -> True
-                        _      -> False
-      mkvar :: [Var] -> [ Either PredLogic A_Concept ] -> [Var]
-      mkvar exclVars (Right z: ics) = let vz = head (mkVar exclVars [z]) in vz: mkvar (exclVars++[vz]) ics
-      mkvar exclVars (Left  _: ics) = mkvar exclVars ics
-      mkvar _ [] = []
-
-      fERad :: [Var] -> Expression -> (Var,Var) -> PredLogic
-      fERad exclVars e (a,b) 
-        | and[isCpl e' |e'<-es] = f exclVars (deMorganERad e) (a,b)                      -- e.g.  -r!-s!-t
-        | isCpl (head es)       = f exclVars (foldr1 (.:.) antr .\. foldr1 (.!.) conr) (a,b)  -- e.g.  -r!-s! t  antr cannot be empty, because isCpl (head es) is True; conr cannot be empty, because es has an element that is not isCpl.
-        | isCpl (last es)       = f exclVars (foldr1 (.!.) conl ./. foldr1 (.:.) antl) (a,b)  -- e.g.   r!-s!-t  antl cannot be empty, because isCpl (head es) is True; conl cannot be empty, because es has an element that is not isCpl.
-        | otherwise             = Forall ivs (Disj (frels a b))                               -- e.g.   r!-s! t  the condition or [isCpl e' |e'<-es] is true.
-{- was:
-        | otherwise             = Forall ivs (Disj alls)
-                                  where alls = [f (exclVars++ivs) e' (sv,tv) | (e',(sv,tv))<-zip es (zip (a:ivs) (ivs++[b]))]
--}
-        where
-         es   = [ x | x<-exprRad2list e, not (isEpsilon x) ] -- The definition of exprRad2list guarantees that length es>=2
-         res  = pars3 (exclVars++ivs) (split es)  -- yields triples (r,s,t): the fragment, its source and target.
-         conr = dropWhile isCpl es -- There is at least one positive term, because conr is used in the second alternative (and the first alternative deals with absence of positive terms).
-                                   -- So conr is not empty.
-         antr = let x = (map notCpl.map flp.reverse.takeWhile isCpl) es in
-                if null x then fatal 367 ("Entering in an empty foldr1") else x
-         conl = let x = (reverse.dropWhile isCpl.reverse) es in
-                if null x then fatal 369 ("Entering in an empty foldr1") else x
-         antl = let x = (map notCpl.map flp.takeWhile isCpl.reverse) es in
-                if null x then fatal 371 ("Entering in an empty foldr1") else x
-        -- Step 2: assemble the intermediate variables from at the right spot in each fragment.
-         frels :: Var -> Var -> [PredLogic]
-         frels src trg = [r v w | ((r,_,_),v,w)<-zip3 res' (src: ivs) (ivs++[trg]) ]
-        -- Step 3: compute the intermediate variables and their types
-         res' :: [(Var -> Var -> PredLogic, A_Concept, A_Concept)]
-         res' = [triple | triple<-res, not (atomic triple)]
-         ivs ::  [Var]
-         ivs  = mkvar exclVars ics
-         ics ::  [ Either PredLogic A_Concept ] -- each element is either an atom or a concept
-         ics  = concat
-                [ case (v',w) of
-                    (Left _,    Left _   ) -> []
-                    (Left atom, Right  _ ) -> [ Left atom ]
-                    (Right  _ , Left atom) -> [ Left atom ]
-                    (Right trg, Right  _ ) -> [ Right trg ] -- SJ 20131117, was: (if trg==src then [ Right trg ] else [ Right (trg `meet` src) ])
-                                                            -- This code assumes no ISA's in the A-structure. This works due to the introduction of EEps expressions.
-                | (v',w)<-zip [ case l ("",src) ("",trg) of
-                                 atom@Atom{} -> Left atom
-                                 _           -> Right trg
-                              | (l,src,trg)<-init res]
-                              [ case r ("",src) ("",trg) of
-                                 atom@Atom{} -> Left atom
-                                 _           -> Right src
-                              | (r,src,trg)<-tail res]
-                ]
-
-      relFun :: [Var] -> [Expression] -> Expression -> [Expression] -> Var->Var->PredLogic
-      relFun exclVars lhs e rhs
-        = case e of
-            EDcD dcl        -> \sv tv->R (Funs (fst sv) [r | t'<-        lhs, r<-relsMentionedIn t']) dcl (Funs (fst tv) [r | t'<-reverse rhs, r<-relsMentionedIn t'])
-            EFlp (EDcD dcl) -> \sv tv->R (Funs (fst tv) [r | t'<-reverse rhs, r<-relsMentionedIn t']) dcl (Funs (fst sv) [r | t'<-        lhs, r<-relsMentionedIn t'])
-            EMp1 atom _     -> \_ _->Atom atom
-            EFlp EMp1{}     -> relFun exclVars lhs e rhs
-            _               -> \sv tv->f (exclVars++[sv,tv]) e (sv,tv)       
-
-      pars3 :: [Var] -> [[Expression]] -> [(Var -> Var -> PredLogic, A_Concept, A_Concept)] 
-      pars3 exclVars (lhs: [e]: rhs: ts)
-       | denotes lhs==Flr && denote e==Rn && denotes rhs==Frl
-          = ( relFun exclVars lhs e rhs, source (head lhs), target (last rhs)): pars3 exclVars ts
-       | otherwise = pars2 exclVars (lhs:[e]:rhs:ts)
-      pars3 exclVars ts = pars2 exclVars ts -- for lists shorter than 3
-
-      pars2 :: [Var] -> [[Expression]]-> [(Var -> Var -> PredLogic, A_Concept, A_Concept)]
-      pars2 exclVars (lhs: [e]: ts)
-       | denotes lhs==Flr && denote e==Rn
-                   = (relFun exclVars lhs e [], source (head lhs), target e): pars3 exclVars ts
-       | denotes lhs==Flr && denote e==Frl
-                   = (relFun exclVars lhs (EDcI (source e)) [e], source (head lhs), target e): pars3 exclVars ts
-       | otherwise = pars1 exclVars (lhs:[e]:ts)
-      pars2 exclVars ([e]: rhs: ts)
-       | denotes rhs==Frl && denote e==Rn
-                   = (relFun exclVars [] e rhs, source e, target (last rhs)): pars3 exclVars ts
-       | denote e==Flr && denotes rhs==Frl
-                   = (relFun exclVars [e] (EDcI (source e)) rhs, source e, target (last rhs)): pars3 exclVars ts
-       | otherwise = pars1 exclVars ([e]:rhs:ts)
-      pars2 exclVars (lhs: rhs: ts)
-       | denotes lhs==Flr && denotes rhs==Frl
-                   = (relFun exclVars lhs (EDcI (source (head rhs))) rhs, source (head lhs), target (last rhs)): pars3 exclVars ts
-       | otherwise = pars1 exclVars (lhs:rhs:ts)
-      pars2 exclVars ts = pars1 exclVars ts -- for lists shorter than 2
-
-      pars1 :: [Var] -> [[Expression]] -> [(Var -> Var -> PredLogic, A_Concept, A_Concept)]
-      pars1 exclVars expressions
-        = case expressions of
-            []        -> []
-            (lhs: ts) -> (pars0 exclVars lhs, source (head lhs), target (last lhs)): pars3 exclVars ts
-
-      pars0 :: [Var] -> [Expression] -> Var -> Var -> PredLogic
-      pars0 exclVars lhs
-       | denotes lhs==Flr = relFun exclVars lhs (EDcI (source (last lhs))) []
-       | denotes lhs==Frl = relFun exclVars []  (EDcI (target (last lhs))) lhs
-       | otherwise        = relFun exclVars [] (let [r]=lhs in r) []
-
-      denote :: Expression -> Notation
-      denote e = case e of
-         (EDcD d)
-           | null([Uni,Inj,Tot,Sur] >- multiplicities d)  -> Rn
-           | isUni d && isTot d                           -> Flr
-           | isInj d && isSur d                           -> Frl
-           | otherwise                                    -> Rn 
-         _                                                -> Rn
-      denotes :: [Expression] -> Notation
-      denotes = denote . head
-
-      split :: [Expression] -> [[Expression]]
-      split []  = []
-      split [e] = [[e]]
-      split (e:e':es)
-       = --if denote e `eq` Wrap      then (e:spl):spls else
-         if denote e `eq` denote e' then (e:spl):spls else
-                                         [e]:spl:spls
-         where 
-           spl:spls = split (e':es)
-           Flr `eq` Flr = True
-           Frl `eq` Frl = True
-           _ `eq` _     = False
-
-        
--- mkVar is bedoeld om nieuwe variabelen te genereren, gegeven een set (ex) van reeds vergeven variabelen.
--- mkVar garandeert dat het resultaat niet in ex voorkomt, dus postconditie:   not (mkVar ex cs `elem` ex)
--- Dat gebeurt door het toevoegen van apostrofes.
-   mkVar :: [Var] -> [A_Concept] -> [Var]  
-   mkVar ex cs = mknew (map fst ex) [([(toLower.head.(++"x").name) c],c) |c<-cs]
-    where
-     mknew _ [] = []
-     mknew ex' ((x,c):xs) = if x `elem` ex'
-                            then mknew ex' ((x++"'",c):xs)
-                            else (x,c): mknew (ex'++[x]) xs

− src/lib/DatabaseDesign/Ampersand/Output/Statistics.hs 
@@ -1,57 +0,0 @@-{-# OPTIONS_GHC -Wall #-}
-module DatabaseDesign.Ampersand.Output.Statistics (Statistics(..)) where
-
-   import DatabaseDesign.Ampersand.Core.AbstractSyntaxTree
-   import DatabaseDesign.Ampersand.Classes
-   import DatabaseDesign.Ampersand.Fspec.Fspec
-   import DatabaseDesign.Ampersand.Fspec.FPA
-   import DatabaseDesign.Ampersand.Fspec.Plug ()
-   import DatabaseDesign.Ampersand.Basics (fatalMsg)
-
-   fatal :: Int -> String -> a
-   fatal = fatalMsg "Output.Statistics"
-
- -- TODO Deze module moet nog verder worden ingekleurd...
- 
-   class Statistics a where
-    nInterfaces :: a -> Int      -- ^ The number of interfaces in a
-    nPatterns :: a -> Int      -- ^ The number of patterns in a
-    nFpoints :: a -> Int      -- ^ The number of function points in a
-    
-    
-   instance Statistics a => Statistics [a] where
-    nInterfaces xs = sum (map nInterfaces xs)
-    nPatterns   xs = sum (map nPatterns xs)
-    nFpoints    xs = sum (map nFpoints xs)
-
-
-   instance Statistics Fspc where
-    nInterfaces fSpec = length (fActivities fSpec) --TODO -> check correctness
-    nPatterns   fSpec = nPatterns (patterns fSpec)
-    nFpoints    fSpec = sum [nFpoints ifc | ifc <- (interfaceS fSpec++interfaceG fSpec)] 
-                --       + sum [fPoints (fpa plug) | InternalPlug plug <- plugInfos fSpec]
--- TODO Deze module moet nog verder worden ingekleurd...
-   
-   instance Statistics Pattern where
-    nInterfaces _ = 0 --TODO -> check correctness
-    nPatterns   _ = 1
-    nFpoints   _  = fatal 43 "function points are not defined for patterns at all."
-
---   instance Statistics Activity where
---    nInterfaces _ = 1
---    nPatterns   _ = 0
---    nFpoints act  = fPoints (actFPA act) --TODO -> implement correct FPA qualification
-
--- \***********************************************************************
--- \*** Properties with respect to: Dataset                       ***
--- \*** TODO: both datasets and interfaces are represented as ObjectDef. This does actually make a difference for the function point count, so we have work....
-   instance Statistics Interface where
-    nInterfaces _ = 1
-    nPatterns   _ = 0
-    nFpoints ifc  = fPoints ifc
-
---   instance Statistics ObjectDef where
---    nInterfaces (Obj{objmsub=Nothing}) = 2 -- this is an association, i.e. a binary relation --TODO -> check correctness
---    nInterfaces _ = 4 -- this is an entity with one or more attributes. --TODO -> check correctness
---    nPatterns   _ = 0
---    nFpoints    _ = fatal 60 "function points are not defined for ObjectDefs at all."

− src/lib/DatabaseDesign/Ampersand/Output/ToPandoc/ChapterConceptualAnalysis.hs 
@@ -1,184 +0,0 @@-{-# OPTIONS_GHC -Wall #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE OverloadedStrings #-}
-module DatabaseDesign.Ampersand.Output.ToPandoc.ChapterConceptualAnalysis
-where
-import DatabaseDesign.Ampersand.Output.ToPandoc.SharedAmongChapters
-import DatabaseDesign.Ampersand.ADL1 (Prop(..)) 
-import DatabaseDesign.Ampersand.Output.PredLogic        (PredLogicShow(..), showLatex)
-import DatabaseDesign.Ampersand.Classes
-import DatabaseDesign.Ampersand.Output.PandocAux
-import Data.List (intercalate)
-
-fatal :: Int -> String -> a
-fatal = fatalMsg "Output.ToPandoc.ChapterConceptualAnalysis"
-
-chpConceptualAnalysis :: Int -> Fspc -> Options -> (Blocks,[Picture])
-chpConceptualAnalysis lev fSpec flags = (
-      --  *** Header ***
-   chptHeader (fsLang fSpec) ConceptualAnalysis
-   <> --  *** Intro  ***
-   caIntro
-   <> --  *** For all themes, a section containing the conceptual analysis for that theme  ***
-   caBlocks, pictures)
-  where
-  caIntro :: Blocks
-  caIntro
-   = (case fsLang fSpec of
-        Dutch   -> para
-                    (  "Dit hoofdstuk beschrijft een formele taal, waarin functionele eisen ten behoeve van "
-                    <> (singleQuoted.str.name) fSpec
-                    <> " kunnen worden besproken en uitgedrukt. "
-                    <> "De formalisering dient om een bouwbare specificatie te verkrijgen. "
-                    <> "Een derde met voldoende deskundigheid kan op basis van dit hoofdstuk toetsen of de gemaakte afspraken "
-                    <> "overeenkomen met de formele regels en definities. "
-                    )
-        English -> para
-                    (  "This chapter defines the formal language, in which functional requirements of "
-                    <> (singleQuoted.str.name) fSpec
-                    <> " can be analysed and expressed."
-                    <> "The purpose of this formalisation is to obtain a buildable specification. "
-                    <> "This chapter allows an independent professional with sufficient background to check whether the agreements made "
-                    <> "correspond to the formal rules and definitions. "
-                    )
-     )<> purposes2Blocks flags (purposesDefinedIn fSpec (fsLang fSpec) fSpec) -- This explains the purpose of this context.
-     
-  caBlocks = fromList $ concat(map caSection (patterns fSpec))
-  pictures = concatMap patPicts (patterns fSpec)
-  -----------------------------------------------------
-  -- the Picture that represents this pattern's conceptual graph
-  patPicts :: Pattern -> [Picture] 
-  patPicts pat = pictOfPat pat :
-                (map pictOfRule (invariants pat `isc` udefrules pat))
-  pictOfPat  :: Pattern ->  Picture
-  pictOfPat  = makePicture flags fSpec . PTRelsUsedInPat 
-  pictOfRule :: Rule -> Picture
-  pictOfRule = makePicture flags fSpec . PTSingleRule
-  caSection :: Pattern -> [Block]
-  caSection pat
-   =    -- new section to explain this pattern  
-        toList ( labeledThing flags (lev+1) (xLabel ConceptualAnalysis++"_"++name pat) (name pat))
-        -- The section starts with the reason why this pattern exists 
-     ++ toList (purposes2Blocks flags (purposesDefinedIn fSpec (fsLang fSpec) pat))
-        -- followed by a conceptual model for this pattern
-     ++ ( case (genGraphics flags, fsLang fSpec) of
-               (True,Dutch  ) -> -- announce the conceptual diagram
-                                 [Para [Str "Figuur ", xrefReference (pictOfPat pat), Str " geeft een conceptueel diagram van dit pattern."]
-                                 -- draw the conceptual diagram
-                                 ,Plain ((toList . showImage flags) (pictOfPat pat))]          
-               (True,English) -> [Para [Str "Figure ", xrefReference (pictOfPat pat), Str " shows a conceptual diagram of this pattern."]
-                                 ,Plain ((toList . showImage flags) (pictOfPat pat))]
-               _              -> [])
-        -- now provide the text of this pattern.
-     ++ (case fsLang fSpec of
-           Dutch   -> [Para [Str "De definities van concepten zijn te vinden in de index."]
-                      ]++
-                      toList (labeledThing flags (lev+2) (xLabel ConceptualAnalysis++"_relationsOf_"++name pat) "Gedeclareerde relaties")
-                      ++
-                      [Para [Str "Deze paragraaf geeft een opsomming van de gedeclareerde relaties met eigenschappen en betekenis."]]
-           English -> [Para [Str "The definitions of concepts can be found in the glossary."]
-                      ]++
-                      toList (labeledThing flags (lev+2) (xLabel ConceptualAnalysis++"_relationsOf_"++name pat) "Declared relations")
-                      ++
-                      [Para [Str "This section itemizes the declared relations with properties and purpose."]])
-     ++ [DefinitionList blocks | let blocks = map caRelation [d | d@Sgn{}<-relsDefdIn pat `uni` relsMentionedIn pat], not(null blocks)]
-     ++ (case fsLang fSpec of
-           Dutch   -> toList (labeledThing flags (lev+2) (xLabel ConceptualAnalysis++"_rulesOf_"++name pat) "Formele regels")
-                      ++
-                      [Plain [Str "Deze paragraaf geeft een opsomming van de formele regels met een verwijzing naar de gemeenschappelijke taal van de belanghebbenden ten behoeve van de traceerbaarheid."]]
-           English -> toList (labeledThing flags (lev+2) (xLabel ConceptualAnalysis++"_rulesOf_"++name pat) "Formal rules")
-                      ++
-                      [Plain [Str "This section itemizes the formal rules with a reference to the shared language of stakeholders for the sake of traceability."]])
-     ++ [DefinitionList blocks | let blocks = map caRule (invariants pat `isc` udefrules pat), not(null blocks)]
-
-  caRelation :: Declaration -> ([Inline], [[Block]])
-  caRelation d 
-        = let purp = toList (purposes2Blocks flags [p | p<-purposesDefinedIn fSpec (fsLang fSpec) d])
-          in ([]
-             ,[   -- First the reason why the relation exists, if any, with its properties as fundamental parts of its being..
-                ( if null purp
-                  then [ Plain$[ Str ("De volgende "++nladjs d++" is gedefinieerd ")      | fsLang fSpec==Dutch]
-                            ++ [ Str ("The following "++ukadjs d++" has been defined ") | fsLang fSpec==English] ]
-                  else purp++
-                       [ Plain$[ Str ("Voor dat doel is de volgende "++nladjs d++" gedefinieerd ")      | fsLang fSpec==Dutch]
-                            ++ [ Str ("For this purpose, the following "++ukadjs d++" has been defined ") | fsLang fSpec==English] ] )
-                  -- Then the declaration of the relation with its properties and its intended meaning 
-               ++ pandocEqnArray 
-                     [ ( texOnly_Id(name d)
-                       , ":"
-                       , texOnly_Id(name (source d))++(if isFunction d then texOnly_fun else texOnly_rel)++texOnly_Id(name(target d))++symDefLabel d
-                       )  ]
-               ++ [Plain$[Str $ let langs=commaNL "en" [ show (amLang markup) | markup<-ameaMrk (decMean d), amLang markup/=Dutch] in
-                                if null langs then "(Geen betekenis gespecificeerd)" else "(Geen betekenis gespecificeerd, maar wel in het "++langs++")"| fsLang fSpec==Dutch]++
-                         [Str $ let langs=commaEng "and" [ show (amLang markup) | markup<-ameaMrk (decMean d), amLang markup/=Dutch] in
-                                if null langs then "(No meaning has been specified)" else "(No meaning has been specified, except in "++langs++")"| fsLang fSpec==English]
-                  | null (meaning2Blocks (fsLang fSpec) d)]
-               ++ meaning2Blocks (fsLang fSpec) d
-              ])
-  ukadjs d  = case [Uni,Tot]>-multiplicities d of
-               [] -> commaEng "and" (map ukadj (multiplicities d>-[Uni,Tot]))++" function"
-               _  -> commaEng "and" (map ukadj (multiplicities d))++" relation"
-   where
-    ukadj Uni = "univalent"
-    ukadj Inj = "injective"
-    ukadj Sur = "surjective"
-    ukadj Tot = "total"
-    ukadj Sym = "symmetric"
-    ukadj Asy = "antisymmetric"
-    ukadj Trn = "transitive"
-    ukadj Rfx = "reflexive"
-    ukadj Irf = "irreflexive"
-  nladjs d = case [Uni,Tot]>-multiplicities d of
-               [] -> commaNL "en" (map nladj (multiplicities d>-[Uni,Tot]))++" functie"
-               _  -> commaNL "en" (map nladj (multiplicities d))++" relatie"
-   where
-    nladj Uni = "univalente"
-    nladj Inj = "injectieve"
-    nladj Sur = "surjectieve"
-    nladj Tot = "totale"
-    nladj Sym = "symmetrische"
-    nladj Asy = "antisymmetrische"
-    nladj Trn = "transitieve"
-    nladj Rfx = "reflexieve"
-    nladj Irf = "irreflexieve"
-  caRule :: Rule -> ([Inline], [[Block]])
-  caRule r 
-        = let purp = toList (purposes2Blocks flags (purposesDefinedIn fSpec (fsLang fSpec) r))
-              
-          in ( []
-             , [  -- First the reason why the rule exists, if any..
-                  purp  
-                  -- Then the rule as a requirement
-               ++ [Plain$[if null purp then Str "De volgende afspraak is gesteld in paragraaf " 
-                                       else Str "Daarom is als afspraak gesteld in paragraaf " | fsLang fSpec==Dutch]
-                      ++ [if null purp then Str "The following requirement has been defined in section " 
-                                       else Str "Therefore the following requirement has been defined in section " | fsLang fSpec==English]
-                      ++ [RawInline (Format "latex") "~"
-                         ,RawInline (Format "latex") $ symReqRef r
-                         ,Str " p."
-                         ,RawInline (Format "latex") "~"
-                         ,RawInline (Format "latex") $ symReqPageRef r
-                         ,Str ": "]]
-               ++ meaning2Blocks (fsLang fSpec) r
-                  -- then the formal rule
-               ++ [Plain$[Str "Dit is geformaliseerd - gebruikmakend van relaties " | fsLang fSpec==Dutch]
-                      ++ [Str "This is formalized - using relations "     | fsLang fSpec==English]
-                      ++ intercalate [Str ", "] [[RawInline (Format "latex") $ symDefRef d] | d@Sgn{}<-relsMentionedIn r]
-                      ++ [Str " - als " | fsLang fSpec==Dutch]
-                      ++ [Str " - as "     | fsLang fSpec==English]]
-               ++ (if showPredExpr flags
-                   then pandocEqnArrayOnelabel (symDefLabel r) ((showLatex.toPredLogic) r)
-                   else pandocEquation (showMath r++symDefLabel r)
-                  )
-               -- followed by a conceptual model for this rule
-               ++ toList
-               ( case (genGraphics flags, fsLang fSpec) of
-                  (True,Dutch  ) -> 
-                        para ("Figuur " <> xRefReference flags (pictOfRule r) <> " geeft een conceptueel diagram van deze regel.")
-                     <> plain (showImage flags (pictOfRule r))          
-                  (True,English) -> 
-                        para ("Figure " <> xRefReference flags (pictOfRule r) <> " shows a conceptual diagram of this rule.")
-                     <> plain (showImage flags (pictOfRule r))
-                  _              -> mempty)
-               
-               ])

− src/lib/DatabaseDesign/Ampersand/Output/ToPandoc/ChapterDataAnalysis.hs 
@@ -1,758 +0,0 @@-{-# OPTIONS_GHC -Wall #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE OverloadedStrings #-}
-module DatabaseDesign.Ampersand.Output.ToPandoc.ChapterDataAnalysis (chpDataAnalysis)
-where 
-import DatabaseDesign.Ampersand.Output.ToPandoc.SharedAmongChapters 
-import DatabaseDesign.Ampersand.ADL1
-import DatabaseDesign.Ampersand.Classes
-import DatabaseDesign.Ampersand.Fspec.Fspec
-import DatabaseDesign.Ampersand.Output.PredLogic        (PredLogicShow(..), showLatex)
-import DatabaseDesign.Ampersand.Output.PandocAux
-import DatabaseDesign.Ampersand.Fspec.Graphic.ClassDiagram --(Class(..),CdAttribute(..))
-import Data.List (sortBy)
-import Data.Function (on)
-
-fatal :: Int -> String -> a
-fatal = fatalMsg "Output.ToPandoc.ChapterDataAnalysis"
-
-------------------------------------------------------------
---DESCR -> the data analysis contains a section for each class diagram in the fSpec
---         the class diagram and multiplicity rules are printed
-chpDataAnalysis :: Fspc -> Options -> (Blocks,[Picture])
-chpDataAnalysis fSpec flags = (theBlocks, thePictures)
- where 
- 
-  theBlocks 
-    =  chptHeader (fsLang fSpec) DataAnalysis  -- The header
-    <> (case fsLang fSpec of 
-             Dutch   -> para ( "Dit hoofdstuk bevat het resultaat van de gegevensanalyse. "
-                            <> "De opbouw is als volgt:"
-                             )
-                     <> para ( if summaryOnly
-                               then  "We beginnen met "
-                               else  "We beginnen met het classificatiemodel, gevolgd door "
-                            <>  "een overzicht van alle relaties, die samen de basis vormen van de rest van deze analyse. "
-                            <>  "tenslotte volgen achtereenvolgend het logische- en technische gegevensmodel."
-                             )   
-             English -> para (  "This chapter contains the result of the data analisys. "
-                            <>  "It is structured as follows:"
-                             )
-                     <> para ( if summaryOnly
-                               then  "We start with "
-                               else  "We start with the classification model, followed by "
-                            <>  "a list of all relations, that are the foundation of the rest of the analisys. "
-                            <>  "Finally, the logical and technical data model are discussed."
-                             )   
-       )
-    <> if summaryOnly then mempty else classificationBlocks
-    <> daBasicBlocks
-    <> logicalDataModelBlocks
-    <> technicalDataModelBlocks
-  thePictures
-    =  [classificationPicture | not summaryOnly]
-    ++ logicalDataModelPictures ++ technicalDataModelPictures
-
-  daBasicBlocks                                          = daBasicsSection           sectionLevel fSpec flags
-  (classificationBlocks    , classificationPicture     ) = classificationSection     sectionLevel fSpec flags
-  (logicalDataModelBlocks  , logicalDataModelPictures  ) = logicalDataModelSection   sectionLevel fSpec flags
-  (technicalDataModelBlocks, technicalDataModelPictures) = technicalDataModelSection sectionLevel fSpec flags
-  sectionLevel = 2
-
-  -- | In some cases, only a summary of the data analysis is required as output.
-  summaryOnly :: Bool
-  summaryOnly = theme flags `elem` [StudentTheme]
-  
-
-classificationSection :: Int -> Fspc -> Options -> (Blocks,Picture)
-classificationSection lev fSpec flags = (theBlocks,pict)
- where 
-  theBlocks =
-       header lev (case fsLang fSpec of
-                    Dutch   ->  "Classificaties"
-                    English ->  "Classifications"
-                  )
-    <> content
-  content = 
-    if null (classes classificationModel)
-    then para (case fsLang fSpec of 
-              Dutch   ->  "Er zijn geen classificaties gedefinieerd."
-              English ->  "No classifications have been defined"
-              )
-    else para (case fsLang fSpec of 
-              Dutch   ->  "Een aantal concepten zit in een classificatiestructuur. "
-                       <> (if canXRefer flags 
-                           then  "Deze is in figuur " <> xRefReference flags pict <> "weergegeven."
-                           else "Deze is in onderstaand figuur weergegeven."
-                          )
-              English -> "A number of concepts is organized in a classification structure. "
-                       <> (if canXRefer flags 
-                           then "This is shown in figure " <> xRefReference flags pict <> "."
-                           else "This is shown in the figure below."
-                          )
-            )
-         <> para (showImage flags pict)
-     
-   where
-  classificationModel :: ClassDiag
-  classificationModel = clAnalysis fSpec flags
-
-  pict :: Picture
-  pict = makePicture flags fSpec PTClassDiagram
-          
-
-
-logicalDataModelSection :: Int -> Fspc -> Options -> (Blocks,[Picture])
-logicalDataModelSection lev fSpec flags = (theBlocks, [pict])
- where
-  theBlocks =
-       header lev (case fsLang fSpec of
-                    Dutch   -> text "Logisch gegevensmodel"
-                    English -> text "Logical datamodel"
-                )
-    <> para (case fsLang fSpec of
-               Dutch   -> (text "De afspraken zijn vertaald naar een gegevensmodel. "
-                         <> ( if canXRefer flags
-                              then text "Dit gegevensmodel is in figuur " <> xRefReference flags pict <> text " weergegeven."
-                              else text "Dit gegevensmodel is in onderstaand figuur weergegeven. "
-                          ) )
-               English -> (text "The functional requirements have been translated into a data model. "
-                         <> ( if canXRefer flags
-                              then text "This model is shown by figure " <> xRefReference flags pict <> text "."
-                              else text "This model is shown by the figure below. "
-                          ) )
-            )
-     <> para (showImage flags pict)
-     <> let nrOfClasses = length (classes oocd)
-        in case fsLang fSpec of
-             Dutch   -> para (case nrOfClasses of
-                                0 -> text "Er zijn geen gegevensverzamelingen."
-                                1 -> text "Er is één gegevensverzameling, die in de volgende paragraaf in detail is beschreven:"
-                                _ -> text ("Er zijn "++count Dutch nrOfClasses "gegevensverzameling"++". ") 
-                                  <> text "De details van elk van deze gegevensverzameling worden, op alfabetische volgorde, in de nu volgende paragrafen beschreven:"
-                             )
-             English -> para (case nrOfClasses of
-                                0 -> text "There are no entity types."
-                                1 -> text "There is only one entity type:"
-                                _ -> text ("There are "++count English nrOfClasses "entity type" ++".")
-                                  <> text "The details of each entity type are described (in alfabetical order) in the following paragraphs:"
-                             )
-     <> mconcat (map detailsOfClass (sortBy (compare `on` name) (classes oocd)))
-
-  pict :: Picture
-  pict = makePicture flags fSpec PTLogicalDM
-
-  oocd :: ClassDiag
-  oocd = cdAnalysis fSpec flags
-  
-  detailsOfClass :: Class -> Blocks
-  detailsOfClass cl = 
-           header (lev+1) ((case fsLang fSpec of
-                       Dutch   -> text "Gegevensverzameling: "
-                       English -> text "Entity type: "
-                     )
-                     <> (emph.strong.text.name) cl)
-        <> case fsLang fSpec of 
-             Dutch   -> para $ text "Deze gegevensverzameling bevat de volgende attributen: "
-             English -> para $ text "This entity type has the following attributes: "
-        <> simpleTable (case fsLang fSpec of
-                          Dutch   -> [(plain.text) "Attribuut"
-                                     ,(plain.text) "Type"
-                                     ,mempty
-                                     ]
-                          English -> [(plain.text) "Attribute"
-                                     ,(plain.text) "Type"
-                                     ,mempty
-                                     ]
-                       )
-                       ( [[ (plain.text) "Id"
-                          , (plain.text.name) cl
-                          , (plain.text) (case fsLang fSpec of
-                                            Dutch -> "Sleutel"
-                                            English -> "Primary key"
-                                         )
-                         ]]
-                    <> [ [ (plain.text.name) attr
-                         , (plain.text.attTyp) attr
-                         , (plain.text) $ case (fsLang fSpec,attOptional attr) of
-                                            (Dutch  ,True ) -> "Optioneel"
-                                            (English,True ) -> "Optional"
-                                            (Dutch  ,False) -> "Verplicht"
-                                            (English,False) -> "Mandatory"
-                         ]
-                         | attr <- clAtts cl]
-                       )  
-        <> case fsLang fSpec of 
-             Dutch   -> para ( text (name cl) <> text " heeft de volgende associaties: ")
-             English -> para ( text (name cl) <> text " has the following associations: ")
-        <> orderedList [assocToRow assoc | assoc <- assocs oocd
-                         , assSrc assoc == root || assTgt assoc == root]
-                       
-    where
-     root = case clcpt cl of
-       Nothing -> fatal 193 "A class in the logical data model should have a root concept."
-       Just c  -> Left c
-     assocToRow :: DatabaseDesign.Ampersand.Fspec.Graphic.ClassDiagram.Association -> Blocks
-     assocToRow assoc  =                 
-        -- showDummy assoc <>
-        if (null.assrhr) assoc
-        then fatal 192 "Shouldn't happen: flip the relation for the right direction!"
-        else case fsLang fSpec of
-           Dutch   -> para (   text "Ieder(e) "
-                            <> (emph.text.nm.assSrc) assoc
-                            <> let rel = (singleQuoted.text.assrhr) assoc
-                                   rel' = ""
-                               in (case assrhm assoc of
-                                     Mult MinZero MaxOne  -> " " <> rel <> " maximaal één " 
-                                     Mult MinZero MaxMany -> " " <> rel <> " geen tot meerdere "
-                                     Mult MinOne  MaxOne  -> " moet " <> rel <> " precies één "
-                                     Mult MinOne  MaxMany -> " moet " <> rel <> " ten minste één "
-                                  ) 
-                            <> (emph.text.nm.assTgt) assoc 
-                            <>  ". Over deze relatie geldt omgekeerd dat "
-                            <>  "ieder(e) "
-                            <> (emph.text.nm.assTgt) assoc
-                            <> (case asslhm assoc of
-                                     Mult MinZero MaxOne  -> " "  <> rel' <> " maximaal één " 
-                                     Mult MinZero MaxMany -> " "  <> rel' <> " geen tot meerdere "
-                                     Mult MinOne  MaxOne  -> " moet " <> rel' <> " precies één "
-                                     Mult MinOne  MaxMany -> " moet " <> rel' <> " ten minste één "
-                                  )
-                            <> (emph.text.nm.assSrc) assoc
-                            <> " kan hebben."
-                           )
-           English -> para (   "Every "
-                            <> (emph.text.nm.assSrc) assoc
-                            <> let rel = (singleQuoted.text.assrhr) assoc
-                                   rel' = ""
-                               in (case assrhm assoc of
-                                     Mult MinZero MaxOne  -> " "  <> rel <> " at most one " 
-                                     Mult MinZero MaxMany -> " "  <> rel <> " zero or more "
-                                     Mult MinOne  MaxOne  -> " must " <> rel <> " exactly one "
-                                     Mult MinOne  MaxMany -> " must " <> rel <> " at least one "
-                                  ) 
-                            <> (emph.text.nm.assTgt) assoc 
-                            <> ". For the other way round, for this relation holds that "
-                            <> "each "
-                            <> (emph.text.nm.assTgt) assoc
-                            <> (case asslhm assoc of
-                                     Mult MinZero MaxOne  -> " "  <> rel' <> " at most one " 
-                                     Mult MinZero MaxMany -> " "  <> rel' <> " zero or more "
-                                     Mult MinOne  MaxOne  -> " must " <> rel' <> " exactly one "
-                                     Mult MinOne  MaxMany -> " must " <> rel' <> " at least one "
-                                  )
-                            <> (emph.text.nm.assSrc) assoc
-                            <> "."
-                           )
-             
-
-     nm :: Identified a => Either a String -> String
-     nm x = case x of 
-              Left c  -> name c
-              Right s -> s
-
-technicalDataModelSection :: Int -> Fspc -> Options -> (Blocks,[Picture])
-technicalDataModelSection lev fSpec flags = (theBlocks,[pict])
- where 
-   theBlocks =
-       header lev (case fsLang fSpec of
-                    Dutch   ->  "Technisch datamodel"
-                    English ->  "Technical datamodel"
-                      )
-    <> para (case fsLang fSpec of
-               Dutch   -> ( "De afspraken zijn vertaald naar een technisch datamodel. "
-                         <> ( if canXRefer flags
-                              then "Dit model is in figuur " <> xRefReference flags pict <> " weergegeven."
-                              else "Dit model is in onderstaand figuur weergegeven. "
-                          ) )
-               English -> ( "The functional requirements have been translated into a technical data model. "
-                         <> ( if canXRefer flags
-                              then "This model is shown by figure " <> xRefReference flags pict <> "."
-                              else "This model is shown by the figure below. "
-                          ) )
-            )
-    <> para (showImage flags pict)
-    <> para (let nrOfTables = length (filter isTable (plugInfos fSpec)) 
-             in
-             case fsLang fSpec of
-        Dutch   -> text ("Het technisch datamodel bestaat uit de volgende "++show nrOfTables++" tabellen:")
-        English -> text ("The technical datamodel consists of the following "++show nrOfTables++"tables:")
-            )
-    <> mconcat [detailsOfplug p | p <- sortBy (compare `on` name) (plugInfos fSpec), isTable p]
-    where
-      isTable :: PlugInfo -> Bool
-      isTable (InternalPlug TblSQL{}) = True
-      isTable (InternalPlug BinSQL{}) = True
-      isTable (InternalPlug ScalarSQL{}) = False
-      isTable ExternalPlug{} = False
-      detailsOfplug :: PlugInfo -> Blocks
-      detailsOfplug p = 
-           header 3 (   case (fsLang fSpec, p) of
-                          (Dutch  , InternalPlug{}) ->  "Tabel: "
-                          (Dutch  , ExternalPlug{}) ->  "Dataservice: "
-                          (English, InternalPlug{}) ->  "Table: "
-                          (English, ExternalPlug{}) ->  "Data service: "
-                     <> text (name p)
-                    ) 
-        <> case p of
-             InternalPlug tbl@TblSQL{} 
-               -> (case fsLang fSpec of
-                Dutch 
-                   -> para (text $ "Deze tabel heeft de volgende "++(show.length.fields) tbl++" velden:")
-                English 
-                   -> para (text $ "This table has the following "++(show.length.fields) tbl++" fields:")
-                  )
-               <> showFields (plugFields tbl)
-             InternalPlug bin@BinSQL{} 
-               -> para 
-                       (case fsLang fSpec of
-                         Dutch
-                           ->  "Dit is een koppeltabel, die "
-                            <> primExpr2pandocMath (fsLang fSpec) (mLkp bin)
-                            <> " implementeert. De tabel bestaat uit de volgende kolommen:"      
-                           
-                         English
-                           ->  "This is a link-table, implementing "
-                            <> primExpr2pandocMath (fsLang fSpec) (mLkp bin)
-                            <> ". It contains the following columns:"  
-                       )
-                     <> showFields (plugFields bin)
-                   
-                  
-             InternalPlug ScalarSQL{} 
-                -> mempty
-             ExternalPlug _
-               -> case fsLang fSpec of
-                    Dutch   -> para "De details van deze service zijn in dit document (nog) niet verder uitgewerkt."
-                    English -> para "The details of this dataservice are not available in this document."
-      showFields :: [SqlField] -> Blocks
-      showFields flds = bulletList (map showField flds)
-        where 
-          showField fld =
---FIXME 20140525: Onderstaande code vervangen door afl te leiden van `flduse`. Daar zit deze info al in verwerkt!
-             let isPrimaryKey = case fldexpr fld of
-                                  e@EDcI{} -> e==fldexpr (head flds) -- The first field represents the most general concept
-                                  _        -> False 
-                 mForeignKey  = case fldexpr fld of
-                                  EIsc (EDcI c,_) -> Just c
-                                  _               -> Nothing  
-             in para (  (strong.text.fldname) fld
-                      <> linebreak
-                      <> (if isPrimaryKey 
-                          then case fsLang fSpec of
-                                Dutch   -> "Dit attribuut is de primaire sleutel. "
-                                English -> "This attribute is the primary key. "
-                          else 
-                          case mForeignKey of 
-                           Just c ->  case fsLang fSpec of
-                                         Dutch   -> "Dit attribuut verwijst naar een voorkomen in de tabel "
-                                         English -> "This attribute is a foreign key to "
-                                     <> (text.name) c
-                           Nothing -- (no foreign key...)
-                             -> --if isBool
-                                --then 
-                                --else
-                                  (case fsLang fSpec of
-                                     Dutch   -> "Dit attribuut implementeert "
-                                     English -> "This attribute implements "
-                                  <> primExpr2pandocMath (fsLang fSpec) (fldexpr fld)
-                                  <> "."
-                                  )
-                         )
-                      <> linebreak 
-                      <> (code.show.fldtype) fld
-                      <> ", "
-                      <> (case fsLang fSpec of
-                            Dutch 
-                              ->  (if fldnull fld then "Optioneel" else "Verplicht")
-                               <> (if flduniq fld then ", Uniek" else "")
-                               <> "."
-                            English 
-                              ->  (if fldnull fld then "Optional" else "Mandatory")
-                               <> (if flduniq fld then ", Unique" else "")
-                               <> "."
-                         )
-                     )
-   pict :: Picture
-   pict = makePicture flags fSpec PTTechnicalDM
-
-                   
-             
-daBasicsSection :: Int -> Fspc -> Options -> Blocks
--- | The function daBasicsSection lists the basic sentences that have been used in assembling the data model.
-daBasicsSection lev fSpec flags = theBlocks
- where 
-  theBlocks =
-       header lev (case fsLang fSpec of
-                    Dutch   -> "Basiszinnen"
-                    English -> "Fact types"
-                  )
-   <> case fsLang fSpec of 
-        Dutch   -> para ( "In deze paragraaf worden de basiszinnen opgesomd, die een rol spelen bij het ontwerp van de gegevensstructuur. "
-                       <> "Per basiszin wordt de naam en het bron- en doelconcept gegeven, alsook de eigenschappen van deze relatie."
-                        )
-        English -> para ( "This section enumerates the fact types, that have been used in the design of the datastructure. "
-                       <> "For each fact type its name, the source and target concept and the properties are documented."
-                        )       
-   <> definitionList (map toDef (relsInThemes fSpec))
-    where
-      toDef :: Declaration -> (Inlines, [Blocks])
-      toDef d
-        = ( (math.showMath) d
-          , [   para linebreak
-             <> fromList (meaning2Blocks (fsLang fSpec) d)
-                   
-          <> para (   ((strong.text) (case fsLang fSpec of
-                                       Dutch   -> "Eigenschappen"
-                                       English -> "Properties"
-                                    ))
-                   <> text ": "
-                   <> if null (multiplicities d) 
-                      then text "--"
-                      else inlineIntercalate (str ", ") [ text (showADL m) | m <-multiplicities d]
-                  )
-          <> para linebreak
-            ]
-            
-          )
-
--- The properties of various relations are documented in different tables.
--- First, we document the heterogeneous properties of all relations
--- Then, the endo-poperties are given, and finally
--- the signals are documented.
-{-
-  daAssociations :: [Relation] -> [Block]
-  daAssociations rs = heteroMultiplicities ++ endoProperties ++ identityDocumentation ++ viewDocumentation
-   where
-    heteroMultiplicities
-     = case [r | r@Rel{}<-rs, not (isProp r), not (isAttribute r)] of
-        []  -> []
-        [r] -> [ case fsLang fSpec of
-                   Dutch   ->
-                      Para [ Str $ upCap (name fSpec)++" heeft één associatie: "++showADL r++". Deze associatie "++ 
-                                   case (isTot r, isSur r) of
-                                    (False, False) -> "heeft geen beperkingen ten aanzien van multipliciteit."
-                                    (True,  False) -> "is totaal."
-                                    (False, True ) -> "is surjectief."
-                                    (True,  True ) -> "is totaal en surjectief."
-                           ]
-                   English ->
-                      Para [ Str $ upCap (name fSpec)++" has one association: "++showADL r++". This association "++ 
-                                   case (isTot r, isSur r) of
-                                    (False, False) -> "has no restrictions with respect to multiplicities. "
-                                    (True,  False) -> "is total."
-                                    (False, True ) -> "is surjective."
-                                    (True,  True ) -> "is total and surjective."
-                           ]]
-        rs' -> case [r | r<-rs', (not.null) ([Tot,Sur] `isc` multiplicities r) ] of
-               []  -> []
-               [r] -> [ case fsLang fSpec of
-                          Dutch   ->
-                             Para [ Str $ upCap (name fSpec)++" heeft "++count Dutch (length rs) "associatie"++". "
-                                  , Str $ " Daarvan is "++showADL r++if isTot r then "totaal" else "surjectief"
-                                  ]
-                          English   ->
-                            Para [ Str $ upCap (name fSpec)++" has "++count English (length rs) "association"++". "
-                                  , Str $ " Association "++showADL r++" is "++if isTot r then "total" else "surjective"
-                                  ]
-                      ]
-               _   -> [ case fsLang fSpec of
-                          Dutch   ->
-                             Para [ Str $ upCap (name fSpec)++" heeft de volgende associaties en multipliciteitsrestricties. "
-                                  ]
-                          English   ->
-                             Para [ Str $ upCap (name fSpec)++" has the following associations and multiplicity constraints. "
-                                  ]
-                      , Table [] [AlignLeft,AlignCenter,AlignCenter] [0.0,0.0,0.0]
-                        ( case fsLang fSpec of
-                          Dutch   ->
-                               [ [Plain [Str "relatie"]]
-                               , [Plain [Str "totaal"]]
-                               , [Plain [Str "surjectief"]]]
-                          English   ->
-                               [ [Plain [Str "relation"]]
-                               , [Plain [Str "total"]]
-                               , [Plain [Str "surjective"]]]
-                        )
-                        [[[Plain [Math InlineMath (showMath r)]] -- r is a relation.
-                         ,[Plain [Math InlineMath "\\surd" | isTot r]]
-                         ,[Plain [Math InlineMath "\\surd" | isSur r]]]
-                        | r<-rs', not (isAttribute r)
-                        ]
-                      ]
-    isAttribute r = (not.null) ([Uni,Inj] `isc` multiplicities r)
-    endoProperties
-     = if null [ m | r<-hMults, m<-multiplicities r, m `elem` [Rfx,Irf,Trn,Sym,Asy]]
-       then []
-       else [ Para (case fsLang fSpec of
-                          Dutch   ->
-                            [Str "Er is één endorelatie, ", Math InlineMath (showMath d), Str " met de volgende eigenschappen: "]
-                          English   ->
-                            [Str "There is one endorelation, ", Math InlineMath (showMath d), Str " with the following properties: "] )
-            | length hMults==1, d<-hMults ]++
-            [ Para [ case fsLang fSpec of
-                          Dutch   ->
-                            Str "In aanvulling daarop hebben de endorelaties de volgende eigenschappen: "
-                          English   ->
-                            Str "Additionally, the endorelations come with the following properties: "]
-            | length hMults>1 ]++
-            [Table [] [AlignLeft,AlignCenter,AlignCenter,AlignCenter,AlignCenter,AlignCenter,AlignCenter] [0.0,0.0,0.0,0.0,0.0,0.0,0.0]
-             [[case fsLang fSpec of
-                          Dutch   -> Plain [Str "relatie"] 
-                          English -> Plain [Str "relation"]  ]
-             ,[Plain [Str "Rfx"]]
-             ,[Plain [Str "Irf"]]
-             ,[Plain [Str "Trn"]]
-             ,[Plain [Str "Sym"]]
-             ,[Plain [Str "Asy"]]
-             ,[Plain [Str "Prop"]]]
-             [[[Plain [Math InlineMath (showMath d)]] -- d is a declaration, and therefore typeable. So  showMath d  exists.
-              ,[Plain [Math InlineMath "\\surd" | isRfx d ]]
-              ,[Plain [Math InlineMath "\\surd" | isIrf d ]]
-              ,[Plain [Math InlineMath "\\surd" | isTrn d ]]
-              ,[Plain [Math InlineMath "\\surd" | isSym d ]]
-              ,[Plain [Math InlineMath "\\surd" | isAsy d ]]
-              ,[Plain [Math InlineMath "\\surd" | isAsy d && isSym d ]]]
-             | d<-hMults]
-            | length hMults>0 ]
-       where
-        hMults :: [Declaration]
-        hMults  = [decl | decl@Sgn{}<- relsUsedIn fSpec, isEndo decl
-                        , null (themes fSpec) || decpat decl `elem` themes fSpec]
-    identityDocumentation
-     = case (identities fSpec, fsLang fSpec) of
-        ([], _)              -> []
-        ([k], Dutch)         -> [ Para  [Str "Er is één identiteit: ",Str (name k),Str "."]]
-        ([k], English)       -> [ Para  [Str "There is but one identity: ",Str (name k),Str "." ]]
-        (identities, Dutch)  -> [ Para $ Str "De volgende identiteiten bestaan: ": commaNLPandoc (Str "en") [Str (name i) | i<-identities]]
-        (identities, English)-> [ Para $ Str "The following identities exist: ": commaEngPandoc (Str "and") [Str (name i) | i<-identities]]
-
-    viewDocumentation
-     = case (viewDefs fSpec, fsLang fSpec) of
-        ([], _) -> []
-        ([v], Dutch)   -> [ Para  [Str "Er is één view: ",Str (name v),Str "."]]
-        ([v], English) -> [ Para  [Str "There is but one view: ",Str (name v),Str "." ]]
-        (viewds, Dutch) -> [ Para $ Str "De volgende views bestaan: ": commaNLPandoc (Str "en") [Str (name v) | v<-viewds]]
-        (viewds, English)->[ Para $ Str "The following views exist: ": commaEngPandoc (Str "and") [Str (name v) | v<-viewds]]
-
--}
--- The properties of various declations are documented in different tables.
--- First, we document the heterogeneous properties of all relations
--- Then, the endo-poperties are given, and finally
--- the process rules are documented.
-
-  daAttributes :: PlugSQL -> [Block]
-  daAttributes p
-   = if length (plugFields p)<=1 then [] else
-     [ case fsLang fSpec of
-               Dutch   ->
-                 Para [ Str $ "De attributen van "++name p++" hebben de volgende multipliciteitsrestricties. "
-                 ]
-               English ->
-                 Para [ Str $ "The attributes in "++name p++" have the following multiplicity constraints. "
-                 ]
-     ,Table [] [AlignLeft,AlignLeft,AlignCenter,AlignCenter] [0.0,0.0,0.0,0.0]
-      ( case fsLang fSpec of
-          Dutch   ->
-             [[Plain [Str "attribuut"]]
-             ,[Plain [Str "type"]]
-             ,[Plain [Str "verplicht"]]
-             ,[Plain [Str "uniek"]]]
-          English ->
-             [[Plain [Str "attribute"]]
-             ,[Plain [Str "type"]]
-             ,[Plain [Str "mandatory"]]
-             ,[Plain [Str "unique"]]] )
-      [ if isProp (fldexpr fld) && fld/=head (plugFields p)
-        then [ [Plain [Str (fldname fld)]]
-             , [Plain [ Str "Bool"]]
-             , [Plain [Math InlineMath "\\surd"]]
-             , []
-             ]
-        else [ [Plain [if fld==head (plugFields p) || null ([Uni,Inj,Sur]>-multiplicities (fldexpr fld))
-                       then Str  "key "
-                       else Str (fldname fld)]]
-             , [Plain [ (Str . latexEscShw.name.target.fldexpr) fld]]
-             , [Plain [Math InlineMath "\\surd" | not (fldnull fld)]]
-             , [Plain [Math InlineMath "\\surd" | flduniq fld]]
-             ]
-      | fld<-plugFields p  -- tail haalt het eerste veld, zijnde I[c], eruit omdat die niet in deze tabel thuishoort.
-      ]
-      
-     ]
--- the endo-properties have already been reported in the general section of this chapter.
-{-     where
---  voorgestelde multipliciteitenanalyse....
-      clauses = nub [clause | Quad _ ccrs<-vquads fSpec, (_,dnfClauses)<-cl_conjNF ccrs, clause<-dnfClauses]
-      is = nub [r | EUni fus<-clauses
-                  , isIdent (EIsc [notCpl f | f<-fus, isPos f] sgn)
-                  , f<-filter isNeg fus
-                  , s<-strands f
-                  , e<-[head s, flp (last s)]
-                  , r<-relsUsedIn e
-                ]
-      ts = nub [r | EUni fus<-clauses
-                  , isIdent (EIsc [notCpl f | f<-fus, isNeg f] sgn)
-                  , f<-filter isPos fus
-                  , s<-strands f
-                  , e<-[head s, flp (last s)]
-                  , r<-relsUsedIn e
-                  ]
-      strands (ECps fs) = [fs]
-      strands _      = []    -- <--  we could maybe do better than this...
-      tots = [d | t<-ts, inline t, d<-map makeDeclaration (relsUsedIn t)]
-      unis = [d | t<-is, inline t, d<-map makeDeclaration (relsUsedIn t)]
-      surs = [d | t<-ts, not (inline t), d<-map makeDeclaration (relsUsedIn t)]
-      injs = [d | t<-is, not (inline t), d<-map makeDeclaration (relsUsedIn t)]
--}
-
-  -- daPlugs describes data sets.
-  -- These can be recognized by:
-  --    1. the first field has the "unique" attribute on (otherwise it is a binary association)
-  --    2. there is more than one field (otherwise it is a scalar).
-  -- The text gives all rules that are maintained internally within the data structure,
-  -- because they might very well be implemented as database integrity rules.
-  -- Multiplicity rules are not reported separately, because they are already taken care of in the multiplicity tables.
-  -- Plugs that are associations between data sets and scalars are ignored.
-
-  daPlug :: PlugSQL -> [Block]
-  daPlug p
-   = if null content then [] else plugHeader ++ content
-     where
-       thing2block r = pandocEqnArrayOnelabel (symDefLabel r) ((showLatex.toPredLogic) r)
-       plugHeader = toList $ labeledThing flags (lev+1) ("sct:Plug "++escapeNonAlphaNum (name p)) (name p)
-       content = daAttributes p ++ plugRules ++ plugSignals ++ plugIdentities ++ iRules
-       plugRules
-        = case fsLang fSpec of
-           English -> case [r | r<-invariants fSpec, null [d | d@Sgn{} <- relsMentionedIn r, d `notElem` relsUsedIn p]] of
-                       []  -> []
-                       [r] -> [ Para [ Str "Within this data set, the following integrity rule shall be true at all times. " ]]++
-                              if showPredExpr flags
-                              then pandocEqnArrayOnelabel (symDefLabel r) ((showLatex.toPredLogic) r)
-                              else [ Para [ Math DisplayMath $ showMath r]]
-                       rs  -> [ Para [ Str "Within this data set, the following integrity rules shall be true at all times. " ]
-                              , if showPredExpr flags
-                                then BulletList [(pandocEqnArrayOnelabel (symDefLabel r) . showLatex . toPredLogic) r | r<-rs ]
-                                else BulletList [ [Para [Math DisplayMath $ showMath r]] | r<-rs ]
-                              ]
-           Dutch   -> case [r | r<-invariants fSpec, null [d | d@Sgn{} <- relsMentionedIn r, d `notElem` relsUsedIn p]] of
-                       []  -> []
-                       [r] -> [ Para [ Str "Binnen deze gegevensverzameling dient de volgende integriteitsregel te allen tijde waar te zijn. " ]]++
-                              if showPredExpr flags
-                              then pandocEqnArrayOnelabel (symDefLabel r) ((showLatex.toPredLogic) r)
-                              else [ Para [ Math DisplayMath $ showMath r]]
-                       rs  -> [ Para [ Str "Binnen deze gegevensverzameling dienen de volgende integriteitsregels te allen tijde waar te zijn. " ]
-                              , if showPredExpr flags
-                                then BulletList [(pandocEqnArrayOnelabel (symDefLabel r) . showLatex . toPredLogic) r | r<-rs ]
-                                else BulletList [ [Para [Math DisplayMath $ showMath r]] | r<-rs ]
-                              ]
-       plugIdentities
-        = case fsLang fSpec of
-           English -> case [k | k<-identityRules fSpec, null [d | d@Sgn{} <- relsMentionedIn k, d `notElem` relsUsedIn p]] of
-                       []  -> []
-                       [s] -> [ Para [ Str "This data set contains one key. " ]]++
-                              if showPredExpr flags
-                              then pandocEqnArrayOnelabel (symDefLabel s) ((showLatex.toPredLogic) s)
-                              else [ Para [ Math DisplayMath $ showMath s]]
-                       ss  -> [ Para [ Str "This data set contains the following keys. " ]
-                              , if showPredExpr flags
-                                then BulletList [(pandocEqnArrayOnelabel (symDefLabel s) . showLatex . toPredLogic) s | s<-ss ]
-                                else BulletList [ [Para [Math DisplayMath $ showMath s]]
-                                                | s<-ss ]
-                              ]
-           Dutch   -> case [k | k<-identityRules fSpec, null [d | d@Sgn{} <- relsMentionedIn k, d `notElem` relsUsedIn p]] of
-                       []  -> []
-                       [s] -> [ Para [ Str ("Deze gegevensverzameling genereert één key. ") ]]++
-                              if showPredExpr flags
-                              then pandocEqnArrayOnelabel (symDefLabel s) ((showLatex.toPredLogic) s)
-                              else [ Para [ Math DisplayMath $ showMath s]]
-                       ss  -> [ Para [ Str "Deze gegevensverzameling genereert de volgende keys. " ]
-                              , if showPredExpr flags
-                                then BulletList [(pandocEqnArrayOnelabel (symDefLabel s) . showLatex . toPredLogic) s | s<-ss ]
-                                else BulletList [ [Para [Math DisplayMath $ showMath s]] | s<-ss ]
-                              ]
-       plugSignals
-        = case (fsLang fSpec, [r | r<-vrules fSpec, isSignal r , null [d | d@Sgn{} <- relsMentionedIn r, d `notElem` relsUsedIn p]]) of
-    --       English -> case [r | r<-vrules fSpec, isSignal r , null [d | d@Sgn{} <- relsMentionedIn r, d `notElem` relsUsedIn p]] of
-            (_      , [])  -> []
-            (English, [s]) -> [ Para [ Str "This data set generates one process rule. " ]]++
-                              if showPredExpr flags
-                              then pandocEqnArrayOnelabel (symDefLabel s) ((showLatex.toPredLogic) s)
-                              else [ Para [ Math DisplayMath $ showMath s]]
-            (English, ss)  -> [  Para [ Str "This data set generates the following process rules. " ]
-                              , if showPredExpr flags
-                                then BulletList [(pandocEqnArrayOnelabel (symDefLabel s) . showLatex . toPredLogic) s | s<-ss ]
-                                else BulletList [ [Para [Math DisplayMath $ showMath s]] | s<-ss ]
-                              ]
-            (Dutch  , [s]) -> [ Para [ Str ("Deze gegevensverzameling genereert één procesregel. ") ]]++
-                              if showPredExpr flags
-                              then pandocEqnArrayOnelabel (symDefLabel s) ((showLatex.toPredLogic) s)
-                              else [ Para [ Math DisplayMath $ showMath s]]
-            (Dutch  , ss ) -> [ Para [ Str "Deze gegevensverzameling genereert de volgende procesregels. " ]
-                              , if showPredExpr flags
-                                then BulletList [(pandocEqnArrayOnelabel (symDefLabel s) . showLatex . toPredLogic) s | s<-ss ]
-                                else BulletList [ [Para [Math DisplayMath $ showMath s]] | s<-ss ]
-                              ]
-       iRules
-        = case fsLang fSpec of
-           English -> case irs of
-                       []  -> []
-                       [e] -> [ Para [ Str "The following rule defines the integrity of data within this data set. It must remain true at all times. " ]]++
-                              if showPredExpr flags
-                              then pandocEqnArrayOnelabel "" ((showLatex.toPredLogic) e)
-                              else [ Para [ Math DisplayMath $ showMath e]]
-                       es  -> [ Para [ Str "The following rules define the integrity of data within this data set. They must remain true at all times. " ]
-                              , if showPredExpr flags
-                                then BulletList [(pandocEqnArrayOnelabel "" . showLatex . toPredLogic) e | e<-es ]
-                                else BulletList [ [Para [Math DisplayMath $ showMath e]] | e<-es ]
-                              ]
-           Dutch   -> case irs of
-                       []  -> []
-                       [e] -> [ Para [ Str "De volgende regel definieert de integriteit van gegevens binnen deze gegevensverzameling. Hij moet te allen tijde blijven gelden. "]]++
-                              if showPredExpr flags
-                              then pandocEqnArrayOnelabel "" ((showLatex.toPredLogic) e)
-                              else [ Para [ Math DisplayMath $ showMath e]]
-                       es  -> [ Para [ Str "De volgende regels definiëren de integriteit van gegevens binnen deze gegevensverzameling. Zij moeten te allen tijde blijven gelden. " ]
-                              , if showPredExpr flags
-                                then BulletList [(pandocEqnArrayOnelabel "" . showLatex . toPredLogic) e | e<-es ]
-                                else BulletList [ [Para [Math DisplayMath $ showMath e]] | e<-es ]
-                              ]
-          where irs = [ dnf2expr dc
-                      | Quad r ccrs<-vquads fSpec
-                      , r_usr (cl_rule ccrs)==UserDefined, isIdent r, source r `elem` pcpts
-                      , x<-cl_conjNF ccrs
-                      , dc@(Dnf [EDcD nega] _)<-rc_dnfClauses x
-                      , r==nega
-                      ]
-                pcpts = case p of
-                  ScalarSQL{} -> [cLkp p]
-                  _           -> map fst (cLkpTbl p)
-
-primExpr2pandocMath :: Lang -> Expression -> Inlines
-primExpr2pandocMath lang e =
- case e of
-  (EDcD d ) ->  
-           case lang of
-             Dutch -> text "de relatie " 
-             English -> text "the relation "
-        <> math ((name.source) d++ " \\xrightarrow {"++name d++"} "++(name.target) d)
-  (EFlp (EDcD d)) -> 
-           case lang of
-             Dutch -> text "de relatie " 
-             English -> text "the relation "
-        <> math ((name.source) d++ " \\xleftarrow  {"++name d++"} "++(name.target) d)
-  (EIsc (r1,_)) -> 
-           let srcTable = case r1 of
-                            EDcI c -> c
-                            _      -> fatal 767 ("Unexpected expression: "++show r1)
-           in 
-           case lang of
-             Dutch -> text "de identiteitsrelatie van " 
-             English -> text "the identityrelation of "
-        <> math (name srcTable)
-  (EDcI c) ->
-            case lang of
-             Dutch -> text "de identiteitsrelatie van " 
-             English -> text "the identityrelation of "
-        <> math (name c)
-  _   -> fatal 223 ("Have a look at the generated Haskell to see what is going on..\n"++show e) 

− src/lib/DatabaseDesign/Ampersand/Output/ToPandoc/ChapterDiagnosis.hs 
@@ -1,816 +0,0 @@-{-# OPTIONS_GHC -Wall #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-module DatabaseDesign.Ampersand.Output.ToPandoc.ChapterDiagnosis 
-where
-import DatabaseDesign.Ampersand.Output.ToPandoc.SharedAmongChapters 
-import DatabaseDesign.Ampersand.ADL1
-import DatabaseDesign.Ampersand.Classes
-import Data.List
-import DatabaseDesign.Ampersand.Output.PandocAux
-
-fatal :: Int -> String -> a
-fatal = fatalMsg "Output.ToPandoc.ChapterDiagnosis"
-
-chpDiagnosis :: Fspc -> Options -> (Blocks,[Picture])
-chpDiagnosis fSpec flags
- = ( (chptHeader (fsLang fSpec) Diagnosis) <> 
-     fromList 
-     (
-     diagIntro ++             -- an introductory text
-     roleomissions ++         -- tells which role-rule, role-interface, and role-relation assignments are missing
-     roleRuleTable ++         -- gives an overview of rule-rule assignments
-     missingConceptDefs ++    -- tells which concept definitions have been declared without a purpose
-     missingRels ++           -- tells which relations have been declared without a purpose
-     unusedConceptDefs ++     -- tells which concept definitions are not used in any relation
-     relsNotUsed ++           -- tells which relations are not used in any rule
-     missingRules ++          -- tells which rule definitions are missing
-     ruleRelationRefTable ++  -- table that shows percentages of relations and rules that have references
-     invariantsInProcesses ++ -- 
-     processrulesInPatterns++ -- 
--- TODO: Needs rework.     populationReport++       -- says which relations are populated.
-     wipReport++              -- sums up the work items (i.e. the violations of process rules)
-     toList violationReport          -- sums up the violations caused by the population of this script.
-     )   
-   , pics )
-  where
-  diagIntro :: [Block]
-  diagIntro = 
-    case fsLang fSpec of
-      Dutch   -> [Para
-                  [ Str "Dit hoofdstuk geeft een analyse van het Ampersand-script van ", Quoted  SingleQuote [Str (name fSpec)], Str ". "
-                  , Str "Deze analyse is bedoeld voor de auteurs van dit script. "
-                  , Str "Op basis hiervan kunnen zij het script completeren en mogelijke tekortkomingen verbeteren. "
-                  ]]
-      English -> [Para
-                  [ Str "This chapter provides an analysis of the Ampersand script of ", Quoted  SingleQuote [Str (name fSpec)], Str ". "
-                  , Str "This analysis is intended for the authors of this script. "
-                  , Str "It can be used to complete the script or to improve possible flaws. "
-                  ]]
-   
-
-  roleRuleTable :: [Block]
-  roleRuleTable
-    | null ruls = []
-    | null (fRoles fSpec) = 
-        case fsLang fSpec of
-          Dutch    -> [Para [ Str $ upCap (name fSpec)++" specificeert geen rollen. " ]]
-          English  -> [Para [ Str $ upCap (name fSpec)++" does not define any roles. " ]]
-    | null [r | r<-vrules fSpec, isSignal r ] =
-        case fsLang fSpec of
-          Dutch    -> [Para [ Str $ upCap (name fSpec)++" kent geen procesregels. " ]]
-          English  -> [Para [ Str $ upCap (name fSpec)++" does not define any process rules. " ]]
-    | otherwise =
-        (case fsLang fSpec of
-          Dutch    -> Para [ Str $ upCap (name fSpec)++" kent regels aan rollen toe. "
-                            , Str "De volgende tabel toont welke regels door een bepaalde rol kunnen worden gehandhaafd."]
-          English  -> Para [ Str $ upCap (name fSpec)++" assigns rules to roles. "
-                            , Str "The following table shows the rules that are being maintained by a given role."]
-        ) :
-        [Table []  -- the table containing the role-rule assignments
-        (AlignLeft:[AlignCenter |_<-fRoles fSpec])
-        (0.0:[0.0 |_<-fRoles fSpec])
-        (( case fsLang fSpec of
-          Dutch   -> [Plain [Str "regel"]] 
-          English -> [Plain [Str "rule" ]] 
-        ) :    [ [Plain [Str r]] | r <- fRoles fSpec ]
-        )
-        [ [Plain [Str (name rul)]]:[f r rul | r<-fRoles fSpec] | rul<-ruls ] 
-        ]
-     where
-      ruls = if null (themes fSpec)
-             then [r | r<-vrules fSpec, isSignal r ]
-             else [r | pat<-patterns   fSpec, name pat `elem` themes fSpec, r<-udefrules pat,         isSignal r ] ++
-                  [r | prc<-vprocesses fSpec, name prc `elem` themes fSpec, r<-udefrules (fpProc prc) , isSignal r ]
-      f r rul | (r,rul) `elem` maintained      = [Plain [Math InlineMath "\\surd"]]
-              | (r,rul) `elem` dead            = [Plain [Math InlineMath "\\times"]]
-              | (r,rul) `elem` fRoleRuls fSpec = [Plain [Math InlineMath "\\odot"]]
-              | otherwise                      = []
-      maintained  -- (r,rul) `elem` maintained means that r can maintain rul without restrictions.
-        = [ (role,rul)
-          | (role,rul)<-fRoleRuls fSpec
-          , and (map (mayEdit role) (relsUsedIn rul))
-          ]
-      mayEdit :: String -> Declaration -> Bool
-      mayEdit role decl = decl `elem` ((snd.unzip) (filter (\x -> role == fst x) (fRoleRels fSpec))) 
-      dead -- (r,rul) `elem` dead means that r cannot maintain rul without restrictions.
-       = [ (role,rul)
-         | (role,rul)<-fRoleRuls fSpec
-         , (not.or) (map (mayEdit role) (relsUsedIn rul))
-         ]
-
-  roleomissions :: [Block]
-  roleomissions
-   = if      null  (themes fSpec) && (not.null) (vprocesses fSpec) ||
-        (not.null) (themes fSpec) && (not.null) (themes fSpec `isc` [name prc | prc<-vprocesses fSpec])
-     then [ case fsLang fSpec of
-              Dutch   ->
-                Plain [ Str $ upCap (name fSpec)++" kent geen regels aan rollen toe. "
-                       , Str "Een generieke rol, User, zal worden gedefinieerd om al het werk te doen wat in het bedrijfsproces moet worden uitgevoerd."
-                       ]
-              English ->
-                Plain [ Str $ upCap (name fSpec)++" does not assign rules to roles. "
-                       , Str "A generic role, User, will be defined to do all the work that is necessary in the business process."
-                       ]
-          | (null.fRoleRuls) fSpec && (not.null.udefrules) fSpec] ++
-          [ case fsLang fSpec of
-              Dutch   ->
-                Plain [ Str $ upCap (name fSpec)++" specificeert niet welke rollen de inhoud van welke relaties mogen wijzigen. "
-                       , Str ""
-                       ]
-              English ->
-                Plain [ Str $ upCap (name fSpec)++" does not specify which roles may change the contents of which relations. "
-                       , Str ""
-                       ]
-          | null (fRoleRels fSpec), (not.null.fRoleRuls) fSpec ||(not.null.fRoleRels) fSpec]
-     else []
-  missingConceptDefs :: [Block]
-  missingConceptDefs
-   = case (fsLang fSpec, missing) of
-      (Dutch,[])  -> [Para
-                       [Str "Alle concepten in dit document zijn voorzien van een bestaansreden."]
-                     | (not.null.concs) fSpec]
-      (Dutch,[c]) -> [Para
-                       [Str "De bestaansreden van concept ", Quoted SingleQuote [Str (name c)], Str " is niet gedocumenteerd."]
-                     ]
-      (Dutch,xs)  -> [Para $
-                       [Str "De bestaansreden van de concepten: "]++commaNLPandoc (Str "en") (map (Str . name) xs)++[Str " is niet gedocumenteerd."]
-                     ]
-      (English,[])  -> [Para 
-                        [Str "All concepts in this document have been provided with a purpose."]
-                     | (not.null.concs) fSpec]
-      (English,[c]) -> [Para 
-                         [Str "The concept ", Quoted SingleQuote [Str (name c)], Str " remains without a purpose."]
-                     ]
-      (English,xs)  -> [Para $
-                       [Str "Concepts "]++commaEngPandoc (Str "and") (map (Str . name) xs)++[Str " remain without a purpose."]
-                     ]
-   where missing = [c | c <-ccs
-                      , cd <- concDefs fSpec c
-                      , null (purposesDefinedIn fSpec (fsLang fSpec) cd)
-                   ]++
-                   [c | c <-ccs, null (concDefs fSpec c)]
-         ccs = concs [ d | d<-relsDefdIn fSpec, null (themes fSpec)||decpat d `elem` themes fSpec]  -- restrict if the documentation is partial.
-  unusedConceptDefs :: [Block]
-  unusedConceptDefs
-   = case (fsLang fSpec, unused) of
-      (Dutch,[])  -> [Para
-                       [Str "Alle conceptdefinities in dit document worden gebruikt in relaties."]
-                     | (not.null.cDefsInScope) fSpec]
-      (Dutch,[c]) -> [Para
-                       [Str "Het concept ", Quoted SingleQuote [Str (name c)], Str " is gedefinieerd, maar wordt niet gebruikt."]
-                     ]
-      (Dutch,xs)  -> [Para $
-                       [Str "De concepten: "]++commaNLPandoc (Str "en") (map (Str . name) xs)++[Str " zijn gedefinieerd, maar worden niet gebruikt."]
-                     ]
-      (English,[])  -> [Para 
-                        [Str "All concept definitions in this document are used in relations."]
-                     | (not.null.cDefsInScope) fSpec]
-      (English,[c]) -> [Para 
-                         [Str "The concept ", Quoted SingleQuote [Str (name c)], Str " is defined, but isn't used."]
-                     ]
-      (English,xs)  -> [Para $
-                       [Str "Concepts "]++commaEngPandoc (Str "and") (map (Str . name) xs)++[Str " are defined, but not used."]
-                     ]
-   where unused = [cd | cd <-cDefsInScope fSpec, name cd `notElem` map name (allConcepts fSpec)]
-         
-    
-  
-  missingRels :: [Block]
-  missingRels
-   = case (fsLang fSpec, missing) of
-      (Dutch,[])  -> [Para 
-                       [Str "Alle relaties in dit document zijn voorzien van een reden van bestaan (purpose)."]
-                     | (not.null.relsMentionedIn.udefrules) fSpec]
-      (Dutch,[r]) -> [Para 
-                       [ Str "De reden waarom relatie ", r
-                       , Str " bestaat wordt niet uitgelegd."
-                     ] ]
-      (Dutch,rs)  -> [Para $
-                       [ Str "Relaties "]++commaNLPandoc (Str "en") rs++
-                       [ Str " zijn niet voorzien van een reden van bestaan (purpose)."
-                     ] ]
-      (English,[])  -> [Para 
-                         [Str "All relations in this document have been provided with a purpose."]
-                       | (not.null.relsMentionedIn.udefrules) fSpec]
-      (English,[r]) -> [Para 
-                         [ Str "The purpose of relation ", r
-                         , Str " remains unexplained."
-                       ] ]
-      (English,rs)  -> [Para $
-                         [ Str "The purpose of relations "]++commaEngPandoc (Str "and") rs++
-                         [ Str " is not documented."
-                       ] ]
-     where missing = [(Math InlineMath . showMath) (EDcD d) 
-                     | d@Sgn{} <- relsInThemes fSpec
-                     , null (purposesDefinedIn fSpec (fsLang fSpec) d)
-                     ]
-
-  relsNotUsed :: [Block]
-  pics :: [Picture]
-  (relsNotUsed,pics)
-   = ( ( case (fsLang fSpec, notUsed) of
-          (Dutch,[])  -> [Para 
-                           [Str "Alle relaties in dit document worden in één of meer regels gebruikt."]
-                         | (not.null.relsMentionedIn.udefrules) fSpec]
-          (Dutch,[r]) -> [Para 
-                           [ Str "De relatie ", r
-                           , Str " wordt in geen enkele regel gebruikt. "
-                         ] ]
-          (Dutch,rs)  -> [Para $
-                           [ Str "Relaties "]++commaNLPandoc (Str "en") rs++
-                           [ Str " worden niet gebruikt in regels. "
-                         ] ]
-          (English,[])  -> [Para 
-                             [Str "All relations in this document are being used in one or more rules."]
-                           | (not.null.relsMentionedIn.udefrules) fSpec]
-          (English,[r]) -> [Para 
-                             [ Str "Relation ", r
-                             , Str " is not being used in any rule. "
-                           ] ]
-          (English,rs)  -> [Para $
-                             [ Str "Relations "]++commaEngPandoc (Str "and") rs++
-                             [ Str " are not used in any rule. "
-                           ] ] ) ++
-       ( case (fsLang fSpec, pictsWithUnusedRels) of
-          (Dutch,[pict])     -> [ Para [ Str "Figuur "
-                                       , xrefReference pict
-                                       , Str " geeft een conceptueel diagram met alle relaties."
-                                       ] 
-                                , Plain ((toList . showImage flags) pict)
-                                ]
-          (English,[pict])   -> [ Para [ Str "Figure "
-                                       , xrefReference pict
-                                       , Str " shows a conceptual diagram with all relations."
-                                       ]
-                                , Plain ((toList . showImage flags) pict)
-                                ]
-          (Dutch,picts)   -> concat
-                                  [ Para [ Str "Figuur "
-                                         , xrefReference pict
-                                         , Str " geeft een conceptueel diagram met alle relaties die gedeclareerd zijn in "
-                                         , Quoted SingleQuote [Str (name pat)]
-                                         , Str "."
-                                         ] 
-                                    : [Plain ((toList . showImage flags) pict)]
-                                  | (pict,pat)<-zip picts pats ]
-          (English,picts) -> concat
-                                  [ Para [ Str "Figure "
-                                         , xrefReference pict
-                                         , Str " shows a conceptual diagram with all relations declared in "
-                                         , Quoted SingleQuote [Str (name pat)]
-                                         , Str "."
-                                         ]
-                                    : [Plain ((toList . showImage flags) pict)]
-                                  | (pict,pat)<-zip picts pats ] )
-       , pictsWithUnusedRels           -- draw the conceptual diagram
-     )
-     where notUsed = nub [(Math InlineMath . showMath) (EDcD d)
-                         | d@Sgn{} <- relsInThemes fSpec -- only signal relations that are used or defined in the selected themes
-                         , decusr d
-                         , d `notElem` (relsMentionedIn . udefrules) fSpec
-                         ]
-           pats  = [ pat | pat<-patterns fSpec
-                         , null (themes fSpec) || name pat `elem` themes fSpec  -- restrict if the documentation is partial.
-                         , (not.null) (relsDefdIn pat>-relsUsedIn pat) ]
-           pictsWithUnusedRels = [makePicture flags fSpec (PTDeclaredInPat pat) | pat<-pats ]
-
-  missingRules :: [Block]
-  missingRules
-   = case (fsLang fSpec, missingPurp, missingMeaning) of
-      (Dutch,[],[])    -> [ Para [Str "Alle regels in dit document zijn voorzien van een uitleg."]
-                          | (length.udefrules) fSpec>1]
-      (Dutch,rs,rs')   -> [Para 
-                           (case rs>-rs' of
-                              []  -> []
-                              [r] -> [ Str "De bestaansreden van regel ", Emph [Str (name r)]
-                                     , Str (" op regelnummer "++ln r++" van bestand "++fn r)
-                                     , Str " wordt niet uitgelegd. "
-                                     ]
-                              rls -> (upC . commaNLPandoc (Str "en")  )
-                                        [let nrs = [(Str . show . linenr) l | l<-cl] in
-                                         strconcat ([Str ("op regelnummer"++(if length nrs>1 then "s" else "")++" ")]++
-                                                    commaNLPandoc (Str "en") nrs++
-                                                    [Str " van bestand "]++[(Str . locnm . head) cl])
-                                        | cl<-eqCl locnm (map origin rls)] ++
-                                       [ Str " worden regels gedefinieerd, waarvan de bestaansreden niet wordt uitgelegd. " ]
-                            ++
-                            case rs'>-rs of
-                              []  -> []
-                              [r] -> [ Str "De betekenis van regel ", Emph [Str (name r)]
-                                     , Str (" op regelnummer "++ln r++" van bestand "++fn r)
-                                     , Str " wordt uitgelegd in taal die door de computer is gegenereerd. "
-                                     ]
-                              rls -> (upC . commaNLPandoc (Str "en")  )
-                                        [let nrs = [(Str . show . linenr) l | l<-cl] in
-                                         strconcat ([Str ("op regelnummer"++(if length nrs>1 then "s" else "")++" ")]++
-                                                    commaNLPandoc (Str "en") nrs++
-                                                    [Str " van bestand "]++[(Str . locnm . head) cl])
-                                        | cl<-eqCl locnm (map origin rls)] ++
-                                       [ Str " staan regels, waarvan de betekenis wordt uitgelegd in taal die door de computer is gegenereerd. " ]
-                            ++
-                            case rs `isc` rs' of
-                              []  -> []
-                              [r] -> [ Str "Regel ", Emph [Str (name r)]
-                                     , Str (" op regelnummer "++ln r++" van bestand "++fn r++" wordt niet uitgelegd. ")
-                                     ]
-                              rls -> (upC . commaNLPandoc (Str "en")  )
-                                        [let nrs = [(Str . show . linenr) l | l<-cl] in
-                                         strconcat ([Str ("op regelnummer"++(if length nrs>1 then "s" else "")++" ")]++
-                                                    commaNLPandoc (Str "en") nrs++
-                                                    [Str " van bestand "]++[(Str . locnm . head) cl])
-                                        | cl<-eqCl locnm (map origin rls)] ++
-                                       [ Str " worden regels gedefinieerd, zonder verdere uitleg. " ]
-                           )
-                          ]
-      (English,[],[])  -> [ Para [Str "All rules in this document have been provided with a meaning and a purpose."]
-                          | (length.udefrules) fSpec>1]
-      (English,rs,rs') -> [Para $
-                           ( case rs>-rs' of
-                              []  -> []
-                              [r] -> [ Str "The purpose of rule ", Emph [Str (name r)]
-                                     , Str (" on line "++ln r++" of file "++fn r)
-                                     , Str " is not documented. "
-                                     ]
-                              rls -> (upC . commaEngPandoc (Str "and") )
-                                        [let nrs = [(Str . show . linenr) l | l<-cl] in
-                                         strconcat ([ Str ("on line number"++(if length nrs>1 then "s" else "")++" ")]++
-                                                    commaEngPandoc (Str "and") nrs ++
-                                                    [Str " of file "]++[(Str . locnm . head) cl])
-                                        | cl<-eqCl locnm (map origin rls)] ++
-                                       [ Str " rules are defined without documenting their purpose. " ]
-                           ) ++
-                           ( case rs'>-rs of
-                              []  -> []
-                              [r] -> [ Str "The meaning of rule ", Emph [Str (name r)]
-                                     , Str (" on line "++ln r++" of file "++fn r)
-                                     , Str " is documented by means of computer generated language. "
-                                     ]
-                              rls -> (upC . commaEngPandoc (Str "and") )
-                                        [let nrs = [(Str . show . linenr) l | l<-cl] in
-                                         strconcat ([ Str ("on line number"++(if length nrs>1 then "s" else "")++" ")]++
-                                                    commaEngPandoc (Str "and") nrs ++
-                                                    [Str " of file "]++[(Str . locnm . head) cl])
-                                        | cl<-eqCl locnm (map origin rls)] ++
-                                       [ Str " rules are defined, the meaning of which is documented by means of computer generated language. " ]
-                           ) ++
-                           ( case rs `isc` rs' of
-                              []  -> []
-                              [r] -> [ Str "Rule ", Emph [Str (name r)]
-                                     , Str (" on line "++ln r++" of file "++fn r++" is not documented. ")
-                                     ]
-                              rls -> (upC . commaEngPandoc (Str "and") )
-                                        [let nrs = [(Str . show . linenr) l | l<-cl] in
-                                         strconcat ([ Str ("on line number"++(if length nrs>1 then "s" else "")++" ")]++
-                                                    commaEngPandoc (Str "and") nrs ++
-                                                    [Str " of file "]++[(Str . locnm . head) cl])
-                                        | cl<-eqCl locnm (map origin rls)] ++
-                                       [ Str " rules are defined without any explanation. " ]
-                           )
-                          ]
-     where missingPurp
-            = nub [ r
-                  | r<-ruls
-                  , null (purposesDefinedIn fSpec (fsLang fSpec) r)
-                  ]
-           missingMeaning
-            = nub [ r
-                  | r<-ruls
-                  , null [m | m <- ameaMrk (rrmean r), amLang m == fsLang fSpec]
-                  ]
-           ruls = if null (themes fSpec)
-                  then udefrules fSpec
-                  else concat [udefrules pat | pat<-patterns fSpec, name pat `elem` themes fSpec]++
-                       concat [udefrules (fpProc prc) | prc<-vprocesses fSpec, name prc `elem` themes fSpec]
-           upC (Str str':strs) = Str (upCap str'):strs
-           upC str' = str'
-           fn r = locnm (origin r)
-           ln r = locln (origin r)
-           strconcat :: [Inline] -> Inline
-           strconcat strs = (Str . concat) [ str' | Str str'<-strs]
-
-  ruleRelationRefTable =
-    [ Para [ Str descriptionStr ]
-    , Table [] (AlignLeft : replicate 6 AlignCenter) [0.0,0.0,0.0,0.0,0.0,0.0,0.0] 
-            (map strCell [ themeStr, relationsStr, withRefStr, "%", rulesStr, withRefStr, "%"])
-            (map mkTableRowPat (vpatterns fSpec) ++ map mkTableRowProc (vprocesses fSpec) ++ 
-            [[]] ++ -- empty row
-            [mkTableRow contextStr (filter decusr $ vrels fSpec) (vrules fSpec)])
-    ]
-    where mkTableRowPat p = mkTableRow (name p) (ptdcs p) (ptrls p)
-          mkTableRowProc (FProc p _) = mkTableRow (name p) (prcDcls p) (prcRules p) 
-          mkTableRow nm decls ruls = 
-            let nrOfRels = length decls
-                nrOfRefRels = length $ filter hasRef decls
-                nrOfRules = length ruls
-                nrOfRefRules = length $ filter hasRef ruls
-            in  map strCell [ nm
-                            , show nrOfRels, show nrOfRefRels, showPercentage nrOfRels nrOfRefRels
-                            , show nrOfRules, show nrOfRefRules, showPercentage nrOfRules nrOfRefRules 
-                            ]
-        
-          hasRef x = maybe False (any  ((/=[]).explRefIds)) (purposeOf fSpec (fsLang fSpec) x)
-          
-          showPercentage x y = if x == 0 then "-" else show (y*100 `div` x)++"%" 
-          
-          strCell strng = [Plain [Str strng]]
-          
-          (descriptionStr, themeStr, relationsStr, withRefStr, rulesStr, contextStr) = 
-            case fsLang fSpec of Dutch -> ( "Onderstaande tabel bevat per thema (dwz. proces of patroon) tellingen van het aantal relaties en regels, " ++
-                                            "gevolgd door het aantal en het percentage daarvan dat een referentie bevat. Relaties die in meerdere thema's " ++
-                                            "gedeclareerd worden, worden ook meerdere keren geteld."
-                                          , "Thema", "Relaties",  "Met referentie", "Regels", "Gehele context")
-                                 _     -> ( "The table below shows for each theme (i.e. process or pattern) the number of relations and rules, followed " ++
-                                            " by the number and percentage that have a reference. Relations declared in multiple themes are counted multiple " ++
-                                            " times."
-                                          , "Theme", "Relations", "With reference", "Rules", "Entire context")
-
-  locnm (FileLoc(FilePos(filename,_,_))) = filename
-  locnm (DBLoc str') = str'
-  locnm _ = "NO FILENAME"
-  locln (FileLoc(FilePos(_,Pos l _,_))) = show l
-  locln (DBLoc str') = str'
-  locln p = fatal 875 ("funny position "++show p++" in function 'locln'")
-
--- TODO: give richer feedback...
-  invariantsInProcesses :: [Block]
-  invariantsInProcesses
-   = (case (fsLang fSpec, prs, procs) of
-      (_,      [],[] )  -> []
-      (Dutch,  [],[p])  -> [ Para [ Str $ "Alle regels in proces "++name p++" zijn gekoppeld aan rollen." ]]
-      (English,[],[p])  -> [ Para [ Str $ "All rules in process "++name p++" are linked to roles." ]]
-      (Dutch,  [], _ )  -> [ Para [ Str "Alle regels in alle processen zijn gekoppeld aan rollen." ]]
-      (English,[], _ )  -> [ Para [ Str "All rules in all processes are linked to roles." ]]
-      (Dutch,  _ , _ )  -> [ Para [ Str "De volgende tabel toont welke regels in welke processen niet aan een rol gekoppeld zijn. "
-                                  , Str "Dit heeft als consequentie dat de computer de betreffende regel(s) zal handhaven."
-                                  ]]
-      (English,_ , _ )  -> [ Para [ Str "The following table shows which rules are not linked to a role within a particular process. "
-                                  , Str "This has as consequence that these rule(s) will be maintained by the computer."
-                                  ]]
-     )++
--- the table containing the role-rule assignments
-     [ Table [] [AlignLeft,AlignLeft] [0.0,0.0]
-       ( case fsLang fSpec of
-          Dutch   -> [ [Plain [Str "proces" ]] , [Plain [Str "regel"]] ]
-          English -> [ [Plain [Str "process"]] , [Plain [Str "rule" ]] ]
-       )
-       [ [[Plain [Str (name p)]], [Plain (intercalate [Str ", "] [[Str (name r)] | r<-rs])]]
-       | (p,rs)<-prs
-       ]
-     | not (null prs)]
-     where prs = [(fp,rs) | fp<-procs
-                          , let rs=invariants (fpProc fp), not (null rs) ]
-           procs = if null (themes fSpec) then vprocesses fSpec else [prc | prc<-vprocesses fSpec, name prc `elem` themes fSpec ]
-
-  processrulesInPatterns :: [Block]
-  processrulesInPatterns
-   = [ case (fsLang fSpec, procs,prs) of
-        (Dutch,  [p],[])  -> Para [ Str "Alle rol-regel-koppelingen gaan over regels die binnen proces ", Quoted SingleQuote [Str (name p)], Str " gedefinieerd zijn. " ]
-        (English,[p],[])  -> Para [ Str "All role-rule assigments involve rules that are defined in process ", Quoted SingleQuote [Str (name p)], Str ". " ]
-        (Dutch,  _,[])    -> Para [ Str "Voor elk proces geldt dat alle rol-regel-koppelingen gaan over regels die binnen dat proces zijn gedefinieerd." ]
-        (English,_,[])    -> Para [ Str "The role-rule assignments in any of the described processes have been assigned to rules within that same process." ]
-        (Dutch,  _,[(p,rol,rul)])
-                          -> Para [ Str "Er is één koppeling tussen een rol en een regel van buiten het proces: "
-                                  , Str "Rol ", Quoted SingleQuote [Str rol], Str " uit proces ", Quoted SingleQuote [Str (name p)], Str " is gebonden aan regel ", Quoted SingleQuote [Str (name rul)], Str " uit ", Quoted SingleQuote [Str (r_env rul)], Str "."
-                                  ]
-        (English,_,[(p,rol,rul)])
-                          -> Para [ Str "There is one role that is assigned to a rule outside the process: "
-                                  , Str "Role ", Quoted SingleQuote [Str rol], Str ", defined in process ", Quoted SingleQuote [Str (name p)], Str ", is assigned to rule ", Quoted SingleQuote [Str (name rul)], Str " from ", Quoted SingleQuote [Str (r_env rul)], Str "."
-                                  ]
-        (Dutch,  [p],_)   -> Para [ Str "De volgende tabel toont welke regels in welke patterns aan een rol gekoppeld zijn. "
-                                  , Str "Dit heeft als consequentie dat de computer de betreffende regel(s) in proces ", Quoted SingleQuote [Str (name p)], Str " zal handhaven. "
-                                  ]
-        (English,[p],_)   -> Para [ Str "The following table shows which rules from outside the process are linked to a role in the process. "
-                                  , Str "This has as consequence that these rule(s) will be maintained in the corresponding process ", Quoted SingleQuote [Str (name p)], Str ". "
-                                  ]
-        (Dutch,  _,_)     -> Para [ Str "Er zijn koppelingen tussen rollen en regels, die buiten de grenzen van het proces reiken. "
-                                  , Str "De volgende tabel toont welke regels in welke patterns aan een rol gekoppeld zijn. "
-                                  , Str "Dit heeft als consequentie dat de computer de betreffende regel(s) in de bijbehorende processen zal handhaven."
-                                  ]
-        (English,_,_)     -> Para [ Str "There are roles assigned to rules outside the bounds of the process. "
-                                  , Str "The following table shows which rules that are defined in a pattern are linked to a role within a process."
-                                  , Str "This has as consequence that these rule(s) will be maintained in the corresponding process(es)."
-                                  ]
-     | (not.null.vprocesses) fSpec && (not.null) [rra | prc<-procs, rra<-maintains prc]
-     ]        ++          
--- the table containing the role-rule assignments
-     [ Table []
-       ([AlignLeft]++[AlignLeft | multProcs]++[AlignLeft,AlignLeft])
-       ([0.0]++[0.0 | multProcs]++[0.0,0.0])
-       ( case fsLang fSpec of
-          Dutch   ->
-              [[Plain [Str "rol"]] ]++[[Plain [Str "in proces" ]] | multProcs]++[[Plain [Str "regel"]], [Plain [Str "uit"  ]] ]
-          English ->
-              [[Plain [Str "role"]]]++[[Plain [Str "in process"]] | multProcs]++[[Plain [Str "rule" ]], [Plain [Str "from" ]] ]
-       )
-       [ [[Plain [Str rol]]]++[[Plain [Str (name p)]] | multProcs]++[[Plain [Str (name rul)]], [Plain [Str (r_env rul)]]]
-       | (p,rol,rul)<-prs
-       ] 
-     | length prs>1]
-     where prs = [(p,rol,rul) | p<-procs, (rol,rul)<-maintains p, name rul `notElem` map name (udefrules p) ]
-           multProcs = length procs>1
-           procs = [fpProc fp | fp<-vprocesses fSpec
-                            , null (themes fSpec) || name fp `elem` themes fSpec]  -- restrict if this is partial documentation.
-
---  populationReport :: [Block]
---  populationReport
---   = [ Para (case (fsLang fSpec, ps, relsDefdIn fSpec) of
---        (Dutch,  [], [] ) -> [ Str "Dit script is leeg. " ]
---        (English,[], [] ) -> [ Str "This script is empty. " ]
---        (Dutch,  [],  _ ) -> [ Str "Geen relatie bevat enige populatie. " ]
---        (English,[],  _ ) -> [ Str "No relation contains any population. " ]
---        (Dutch,  [p],[_]) -> [ Str "Relatie ", Math InlineMath ((showMath.popdcl) p), Str " heeft een populatie van ", Str (count Dutch (length (popps p)) "paar"), Str ". " ]  -- Every d is typeable, so showMathDamb may be used.
---        (English,[p],[_]) -> [ Str "Relation ", Math InlineMath ((showMath.popdcl) p), Str " has ", Str (count English (length (popps p)) "pair"), Str " in its population. " ]
---        (Dutch,  [p], _ ) -> [ Str "Alleen relatie ", Math InlineMath ((showMath.popdcl) p), Str " heeft een populatie. Deze bevat ", Str (count Dutch (length (popps p)) "paar"), Str ". " ]
---        (English,[p], _ ) -> [ Str "Only relation ", Math InlineMath ((showMath.popdcl) p), Str " is populated. It contains ", Str (count English (length (popps p)) "pair"), Str ". " ]
---        (Dutch,   _ , _ ) -> [ Str "De onderstaande tabel geeft de populatie van de verschillende relaties weer. " ]
---        (English, _ , _ ) -> [ Str "The following table represents the population of various relations. " ])
---     ] ++
---     [ Table []
---        [AlignLeft,AlignRight]
---        [0.0,0.0]
---        (case fsLang fSpec of
---          Dutch   -> [[Plain [Str "Concept"]], [Plain [Str "Populatie"]  ]]
---          English -> [[Plain [Str "Concept"]], [Plain [Str "Population"] ]]
---        )
---        [ [[Plain [Str (name c)]], [Plain [(Str . show . length . atomsOf) c]]]
---        | c<-cs
---        ]
---     | length cs>=1 ] ++
---     [ Table []
---        [AlignLeft,AlignRight]
---        [0.0,0.0]
---        (case fsLang fSpec of
---          Dutch   -> [[Plain [Str "Relatie"]],  [Plain [Str "Populatie"]  ]]
---          English -> [[Plain [Str "Relation"]], [Plain [Str "Population"] ]]
---        )
---        [ [[Plain [Math InlineMath ((showMath .popdcl) p)]], [Plain [(Str . show . length . popps) p]]]  -- Every d is typeable, so showMathDamb may be used.
---        | p<-ps
---        ]
---     | length ps>1 ]
---     where
---      ps  = [p | p<-initialPops fSpec
---               , null (themes fSpec) || (decpat.popdcl) p `elem` themes fSpec  -- restrict if the documentation is partial.
---               , (not.null.popps) p]
---      cs  = [c | c@C{}<-ccs, (not.null.atomsOf) c]
---      ccs = concs [ d | d<-relsDefdIn fSpec, null (themes fSpec)||decpat d `elem` themes fSpec]  -- restrict if the documentation is partial.
-
-  wipReport :: [Block]
-  wipReport
-   = [ Para (case (fsLang fSpec, concat popwork,popwork) of
-              (Dutch,  [],_)       -> [ Str "De populatie in dit script beschrijft geen onderhanden werk. "
-                                      | (not.null.initialPops) fSpec ]  -- SJ 20131212 Is dit correct? Waarom?
-              (English,[],_)       -> [ Str "The population in this script does not specify any work in progress. "
-                                      | (not.null.initialPops) fSpec ]  -- SJ 20131212 Is this correct? Why
-              (Dutch,  [(r,ps)],_) -> [ Str "Regel ", quoterule r, Str (" laat "++count Dutch   (length ps) "taak"++" zien.") ]
-              (English,[(r,ps)],_) -> [ Str "Rule ", quoterule r, Str (" shows "++count English (length ps) "task"++".") ]
-              (Dutch,  _,[_])      -> [ Str "Dit script bevat onderhanden werk. De volgende tabel bevat details met regelnummers in het oorspronkelijk script-bestand." ]
-              (English,_,[_])      -> [ Str "This script contains work in progress. The following table provides details with line numbers from the original script file." ]
-              (Dutch,  _,_)        -> [ Str "Dit script bevat onderhanden werk. De volgende tabellen geven details met regelnummers in de oorspronkelijk script-bestanden." ]
-              (English,_,_)        -> [ Str "This script contains work in progress. The following tables provide details with line numbers from the original script files." ]
-            )
-     ]        ++          
--- the following table actually belongs to the intro
-     [ Table []
-       [AlignLeft,AlignRight,AlignRight]
-       [0.0,0.0,0.0]
-       ( case fsLang fSpec of
-          Dutch   ->
-              [[Plain [Str "regel"]], [Plain $[Str ((locnm . origin . fst . head) cl++" ") |length popwork>1]++[Str "script",LineBreak,Str "regel#"]], [Plain [Str "#signalen"] ]]
-          English ->
-              [[Plain [Str "rule" ]], [Plain $[Str ((locnm . origin . fst . head) cl++" ") |length popwork>1]++[Str "line#"]], [Plain [Str "#signals"] ]]
-       )
-       [ [[Plain [Str (name r)]], [Plain [(Str . locln . origin) r]], [Plain [(Str . show . length) ps]]]
-       | (r,ps)<-cl, length ps>0
-       ]
-     | (length.concat) popwork>1, cl<-popwork ]        ++          
--- the tables containing the actual work in progress population
-     concat
-     [ [ Para ( (case fsLang fSpec of
-                  Dutch   -> Str "Regel"
-                  English -> Str "Rule"):
-                [Space,quoterule r,Space]++
-                if xrefSupported flags then [ Str "(", RawInline (Format "latex") $ symReqRef r, Str ") "] else []++
-                (case fsLang fSpec of
-                  Dutch   -> [ Str "luidt: " ]
-                  English -> [ Str "says: "  ]
-                )  
-              )]  ++meaning2Blocks (fsLang fSpec) r++
-       [Plain ( case fsLang fSpec of
-                  Dutch  ->
-                     [ Str "Deze regel bevat nog werk (voor "]++
-                     commaNLPandoc (Str "of") (nub [Str rol | (rol, rul)<-fRoleRuls fSpec, r==rul])++[Str ")"]++
-                     (if length ps == 1 then [Str ", te weten "]++oneviol r ps++[Str ". "] else
-                      [ Str (". De volgende tabel laat de "++(if length ps>10 then "eerste tien " else "")++"items zien die aandacht vragen.")]
-                     )
-                  English ->
-                     [ Str "This rule contains work"]++
-                     commaEngPandoc (Str "or") (nub [Str rol | (rol, rul)<-fRoleRuls fSpec, r==rul])++[Str ")"]++
-                     if length ps == 1 then [Str " by "]++oneviol r ps++[Str ". "] else
-                      [ Str ("The following table shows the "++(if length ps>10 then "first ten " else "")++"items that require attention.")]
-                     
-              ) ]++
-       [ violtable r ps | length ps>1]
-     | (r,ps)<-concat popwork ]
-     where
---      text r
---       = if null expls
---         then explains2Blocks (autoMeaning (fsLang fSpec) r) 
---         else expls 
---         where expls = [Plain (block++[Space]) | Means l econt<-rrxpl r, l==Just (fsLang fSpec) || l==Nothing, Para block<-econt]
-      quoterule r
-       = if name r==""
-         then case fsLang fSpec of
-               English -> Str ("on "++show (origin r))
-               Dutch   -> Str ("op "++show (origin r))
-         else Quoted SingleQuote [Str (name r)]
-      oneviol :: Rule -> Pairs -> [Inline]
-      oneviol r [p]
-       = if source r==target r && srcPaire p==trgPaire p
-         then [Quoted  SingleQuote [Str (name (source r)),Space,Str (srcPaire p)]]
-         else [Str "(",Str (name (source r)),Space,Str (srcPaire p),Str ", ",Str (name (target r)),Space,Str (trgPaire p),Str ")"]
-      oneviol _ _ = fatal 810 "oneviol must have a singleton list as argument."
-      popwork :: [[(Rule,Pairs)]];
-      popwork = eqCl (locnm.origin.fst) [(r,ps) | (r,ps) <- allViolations fSpec, isSignal r, partofThemes r]
-  partofThemes r = 
-        or [ null (themes fSpec) 
-           , r `elem` concat [udefrules pat | pat<-patterns fSpec, name pat `elem` themes fSpec]
-           , r `elem` concat [udefrules (fpProc prc) | prc<-vprocesses fSpec, name prc `elem` themes fSpec]
-           ]
-
-  violationReport :: Blocks    
-  violationReport
-   = let (processViolations,invariantViolations) = partition (isSignal.fst) (allViolations fSpec)
-         showViolatedRule :: (Rule,Pairs) -> Blocks
-         showViolatedRule (r,ps) 
-             = let capt = case (fsLang fSpec,isSignal r) of
-                               (Dutch  , False) -> text "Overtredingen van regel "<>  text (name r)
-                               (English, False) -> text "Violations of rule "<>  text (name r)
-                               (Dutch  , True ) -> text "Openstaande taken voor " <> text (commaNL  "of" (nub [rol | (rol, rul)<-fRoleRuls fSpec, r==rul]))
-                               (English, True ) -> text "Tasks yet to be performed by "  <> text (commaEng "or" (nub [rol | (rol, rul)<-fRoleRuls fSpec, r==rul]))
-                         
-                   showRow :: Paire -> [Blocks]
-                   showRow p = [(para.text.srcPaire) p,(para.text.trgPaire) p]
-               in para ( case fsLang fSpec of
-                            Dutch   -> text "Regel "
-                            English -> text "Rule "
-                         <>  text (name r)
-                       )
-               <> para (text (case (fsLang fSpec,isSignal r) of
-                               (Dutch  , False) -> "Totaal aantal overtredingen: "++show (length ps)
-                               (English, False) -> "Total number of violations: " ++show (length ps)
-                               (Dutch  , True ) -> "Totaal aantal taken: "        ++show (length ps)
-                               (English, True ) -> "Total number of work items: " ++show (length ps)
-                             )
-                       )
-               <> table capt 
-                   [(AlignLeft,0)                          ,(AlignLeft,0)          ]
-                   [(para.strong.text.name.source.rrexp) r,(para.strong.text.name.target.rrexp) r]
-                   (map showRow ps)
-            
-     in (para (case (fsLang fSpec, invariantViolations, processViolations) of
-                (Dutch  ,[] , [] ) -> text "De populatie in dit script overtreedt geen regels. "
-                (English,[] , [] ) -> text "The population in this script violates no rule. "
-                (Dutch  ,iVs, pVs) 
-                   -> text ("De populatie in dit script overtreedt "
-                             ++show(length iVs)++" invariant"++(if length iVs == 1 then "" else "en")++" en "
-                             ++show(length pVs)++" procesregel"++if length pVs == 1 then "" else "s"++"."
-                           )
-                (English,iVs, pVs) 
-                   -> text ("The population in this script violates "
-                             ++show(length iVs)++" invariant"++(if length iVs == 1 then "" else "s")++" and "
-                             ++show(length pVs)++" process rule"++if length pVs == 1 then "" else "s"++"."
-                           )
-              )
-        )
-     <> bulletList  [showViolatedRule vs | vs<- invariantViolations]
-     <> bulletList  [showViolatedRule vs | vs<- processViolations]
-        
-             
----- the table containing the rule violation counts
---     [ Table []
---       [AlignLeft,AlignRight,AlignRight]
---       [0.0,0.0,0.0]
---       ( case fsLang fSpec of
---          Dutch   ->
---             [[Plain [Str "regel"]], [Plain $[Str ((locnm . origin . fst . head) cl++" ") |length popviol>1]++[Str "regel#"]], [Plain [Str "#overtredingen"] ]]
---          English ->
---             [[Plain [Str "rule" ]], [Plain $[Str ((locnm . origin . fst . head) cl++" ") |length popviol>1]++[Str "line#"]], [Plain [Str "#violations"] ]]
---       )
---       [ [[Plain [Str (name r)]], [Plain [(Str . locln . origin) r]], [Plain [(Str . show . length) ps]]]
---       | (r,ps)<-cl, length ps>0
---       ]
---     | (length.concat) popviol>1, cl<-popviol, not (null cl) ]        ++          
----- the table containing the multiplicity counts
---     [ Table []
---       [AlignLeft,AlignRight,AlignRight]
---       [0.0,0.0,0.0]
---       ( case fsLang fSpec of
---           Dutch   ->
---              [[Plain [Str "regel"]], [Plain $[Str ((locnm . origin . fst . head) cl++" ") |length multviol>1]++[Str "regel#"]], [Plain [Str "#overtredingen"] ]]
---           English ->
---              [[Plain [Str "rule" ]], [Plain $[Str ((locnm . origin . fst . head) cl++" ") |length multviol>1]++[Str "line#"]], [Plain [Str "#violations"] ]]
---       )
---       [ [[Plain [Str (name r)]], [Plain [(Str . locln . origin) r]], [Plain [(Str . show . length) ps]]]
---       | (r,ps)<-cl, length ps>0
---       ]
---     | (length.concat) multviol>1, cl<-multviol, not (null cl) ]        ++          
--- the tables containing the actual violations of user defined rules
---     concat
---     [ [ Para ( (case fsLang fSpec of
---                   Dutch   -> Str "Regel"
---                   English -> Str "Rule"):
---                [Space,quoterule r,Space]++
---                if fspecFormat flags==FLatex then [ Str "(", RawInline (Text.Pandoc.Builder.Format "latex") $ symReqRef r, Str ") "] else []++
---                (case fsLang fSpec of
---                    Dutch   -> [ Str "luidt: " ]
---                    English -> [ Str "says: "])
---              )]  ++meaning2Blocks (fsLang fSpec) r++
---       [Plain ( case fsLang fSpec of
---                  Dutch   ->
---                     Str "Deze regel wordt overtreden":
---                     (if length ps == 1 then [Str " door "]++oneviol r ps++[Str ". "] else
---                      [ Str (". De volgende tabel laat de "++if length ps>10 then "eerste tien " else ""++"overtredingen zien.")]
---                     )
---                  English ->
---                     Str "This rule is violated":
---                     (if length ps == 1 then [Str " by "]++oneviol r ps++[Str ". "] else
---                      [ Str ("The following table shows the "++if length ps>10 then "first ten " else ""++"violations.")]
---                     )
---              )]++
---       [ violtable r ps | length ps>1]
---     | (r,ps)<-popviols, length popviols>1 ]++
----- the tables containing the actual violations of multiplicity rules
---     [ BulletList
---       [ textMult r++
---         [Plain ( case fsLang fSpec of
---                   Dutch   ->
---                     if length ps == 1 then [Str "Deze regel wordt overtreden door "]++oneviol r ps++[Str ". "] else
---                      [ Str ("De volgende tabel laat de "++(if length ps>10 then "eerste tien overtredingen zien." else count Dutch (length ps) ((unCap.name.source)r)++" zien die deze regel overtreden."))]
---                     
---                   English ->
---                     if length ps == 1 then [Str "This rule is violated by "]++oneviol r ps++[Str ". "] else
---                      [ Str ("The following table shows the "++(if length ps>10 then "first ten violations." else count English (length ps) ((unCap.name.source)r)++" that violate this rule."))]
---                     
---                )]++
---         [ violtable r ps | length ps>1]
---       | (r,ps)<-multviols, length multviols>1 ]
---     | not (null multviols) ]
---     where
---     textMult r
---       = concat [    [Plain [Str "De relatie ",Space]]
---                  ++ amPandoc mrkup
---                  ++ [Plain [Str ".",Space]]
---                  
---                 | mrkup <- (ameaMrk . rrmean) r, amLang mrkup==fsLang fSpec]
---     quoterule r = if name r==""
---                   then Str ("on "++show (origin r))
---                   else Quoted SingleQuote [Str (name r)]
---     oneviol r [(a,b)]
---      = if source r==target r && a==b
---        then [Quoted  SingleQuote [Str (name (source r)),Space,Str a]]
---        else [Str "(",Str (name (source r)),Space,Str a,Str ", ",Str (name (target r)),Space,Str b,Str ")"]
---     oneviol _ _ = fatal 810 "oneviol must have a singleton list as argument."
---     popviols  = [(r,ps) | (r,ps) <- allViolations fSpec, partofThemes r,      r_usr r == UserDefined ]
---     multviols = [(r,ps) | (r,ps) <- allViolations fSpec, partofThemes r, not (r_usr r == UserDefined)]
-     
-
---     popviols = [(r,ps) | r<-invs++identityRs
---                        , let ps=ruleviolations r, not (null ps)]
---     multviols = [(r,ps) | r<-mults
---                         , let ps=ruleviolations r, not (null ps)]
---     popviol :: [[(Rule,[(String, String)])]]
---     popviol  = eqCl (locnm.origin.fst) [(r,ps) | r<-invs, let ps=ruleviolations r, not (null ps)]
---     multviol :: [[(Rule,[(String, String)])]]
---     multviol  = eqCl (locnm.origin.fst) [(r,ps) | r<-mults, let ps=ruleviolations r, not (null ps)]
---     invs  = if null (themes fSpec)
---             then invariants fSpec
---             else concat [invariants pat | pat<-patterns fSpec, name pat `elem` themes fSpec]++
---                  concat [invariants (fpProc prc) | prc<-vprocesses fSpec, name prc `elem` themes fSpec]
---     mults = if null (themes fSpec)
---             then multrules fSpec
---             else concat [multrules pat | pat<-patterns fSpec, name pat `elem` themes fSpec]++
---                  concat [multrules (fpProc prc) | prc<-vprocesses fSpec, name prc `elem` themes fSpec]
---     identityRs = if null (themes fSpec)
---                  then identityRules fSpec
---                  else concat [identityRules pat | pat<-patterns fSpec, name pat `elem` themes fSpec]++
---                       concat [identityRules (fpProc prc) | prc<-vprocesses fSpec, name prc `elem` themes fSpec]
-
-  violtable :: Rule -> Pairs -> Block
-  violtable r ps
-      = if hasantecedent r && isIdent (antecedent r)  -- note: treat 'isIdent (consequent r) as binary table.
-        then Table []
-             [AlignLeft]
-             [0.0]
-             [[Plain [(Str . name . source) r]]]
-             [ [[Plain [Str (srcPaire p)]]]
-             | p <-take 10 ps
-             ]
-        else Table []
-             [AlignLeft,AlignLeft]
-             [0.0,0.0]
-             [[Plain [(Str . name . source) r]], [Plain [(Str . name . target) r] ]]
-             [ [[Plain [Str (srcPaire p)]], [Plain [Str (trgPaire p)]]]
-             | p <-take 10 ps
-             ]
-        
-

− src/lib/DatabaseDesign/Ampersand/Output/ToPandoc/ChapterECArules.hs 
@@ -1,56 +0,0 @@-{-# OPTIONS_GHC -Wall #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE OverloadedStrings #-}
-module DatabaseDesign.Ampersand.Output.ToPandoc.ChapterECArules
-where
-import DatabaseDesign.Ampersand.Output.ToPandoc.SharedAmongChapters 
-import DatabaseDesign.Ampersand.Fspec.ToFspec.NormalForms (proofPA)
-import DatabaseDesign.Ampersand.ADL1
-
-chpECArules :: Fspc -> Options ->  Blocks
-chpECArules fSpec flags =
-  if genEcaDoc flags 
-  then chpECArules' fSpec 
-  else mempty
-  
-chpECArules' :: Fspc -> Blocks
-chpECArules' fSpec 
- =   chptHeader (fsLang fSpec) EcaRules
-  <> ecaIntro
-  <> ifcECA
- where
-  ecaIntro :: Blocks
-  ecaIntro
-   = case fsLang fSpec of
-       Dutch   -> plain "Dit hoofdstuk bevat de ECA regels."
-       English -> plain "This chapter lists the ECA rules."
-     
-  ifcECA :: Blocks
-  ifcECA
-   = case fsLang fSpec of
-      Dutch   -> para ( "ECA regels:" <> linebreak 
-                     <> "   tijdelijk ongedocumenteerd")
-                     <> mconcat 
-                         [   (blockQuote . codeBlock . ("\n     "++) . showECA "\n     ") eca
-                          <> para ( linebreak <>
-                                    "------ Afleiding ----->"   -- Dit in- en uitschakelbaar maken
-                                  )
-                          <> (showProof (codeBlock . ("\n     "++) . showECA "\n     ") . proofPA . ecaAction) eca   --  voor het bewijs
-                          <> para ( linebreak <>
-                                    "<------Einde afleiding --"   -- Dit in- en uitschakelbaar maken
-                                  )
-                         | eca<-vEcas fSpec, (not.isNop.ecaAction) eca
-                         ]
-      English -> para ( "ECA rules:" <> linebreak 
-                     <> "   temporarily not documented")
-                     <> mconcat 
-                         [   (blockQuote . codeBlock . ("\n     "++) . showECA "\n     ") eca
-                          <> para ( linebreak <>
-                                    "------ Derivation ----->"   -- Dit in- en uitschakelbaar maken
-                                  )
-                          <> (showProof (codeBlock . ("\n     "++) . showECA "\n     ") . proofPA . ecaAction) eca   --  voor het bewijs
-                          <> para ( linebreak <>
-                                    "<------End Derivation --"   -- Dit in- en uitschakelbaar maken
-                                  )
-                         | eca<-vEcas fSpec, (not.isNop.ecaAction) eca
-                         ]

− src/lib/DatabaseDesign/Ampersand/Output/ToPandoc/ChapterGlossary.hs 
@@ -1,25 +0,0 @@-{-# OPTIONS_GHC -Wall #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-module DatabaseDesign.Ampersand.Output.ToPandoc.ChapterGlossary
-  (chpGlossary)
-where
-import DatabaseDesign.Ampersand.Output.ToPandoc.SharedAmongChapters 
-import DatabaseDesign.Ampersand.ADL1
-import DatabaseDesign.Ampersand.Classes
-
-
-chpGlossary :: Int -> Fspc -> Options ->  Blocks
-chpGlossary _ fSpec flags
- = fromList $
-   if fspecFormat flags==FLatex
-   then [ Para [RawInline (Format "latex") "\\printglossaries"] ]
-   else [ Table [] [AlignLeft,AlignLeft,AlignLeft] [0.0,0.0,0.0]
-          ( case fsLang fSpec of
-               Dutch   ->
-                 [ [Plain [Str "term"]] , [Plain [Str "definitie"]] , [Plain [Str "bron"]]]
-               English ->
-                 [ [Plain [Str "term"]] , [Plain [Str "definition"]], [Plain [Str "source"]]]
-          )
-          [ [ [Plain [(Str . name)  c]], [Plain [(Str . cddef) cd]], [Plain [(Str . cdref) cd]]]
-          | c<-concs fSpec, cd<-concDefs fSpec c
-          ]]

− src/lib/DatabaseDesign/Ampersand/Output/ToPandoc/ChapterInterfaces.hs 
@@ -1,237 +0,0 @@-{-# OPTIONS_GHC -Wall #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-module DatabaseDesign.Ampersand.Output.ToPandoc.ChapterInterfaces
-  ( chpInterfacesPics
-  , chpInterfacesBlocks
-  )
-where
-import DatabaseDesign.Ampersand.Output.ToPandoc.SharedAmongChapters 
-import DatabaseDesign.Ampersand.ADL1
-import Data.List
-import DatabaseDesign.Ampersand.Fspec.Fspec
-import DatabaseDesign.Ampersand.Output.PandocAux
-
-chpInterfacesPics :: Fspc -> Options -> [Picture]
-chpInterfacesPics fSpec flags =
-   concat [picKnowledgeGraph flags fSpec act : [picSwitchboard flags fSpec act | graphic flags] | act <- fActivities fSpec ]
-chpInterfacesBlocks :: Int -> Fspc -> Options -> Blocks
-chpInterfacesBlocks lev fSpec flags =
-   foldr (<>) mempty (map interfaceChap (fActivities fSpec))  
- where 
-   interfaceChap :: Activity -> Blocks
-   interfaceChap act
-   -- TODO: This should be one chapter for all interfaces.
-    =  (labeledThing flags lev ("chpIfc"++name act) (name act)) <>
-       ifcIntro act <>
-       fromList 
-       ( 
-         
-          (if genGraphics flags then txtKnowledgeGraph act else [])
-         -- ifcFieldTables
-         ++ (if graphic flags then txtSwitchboard act else [])
-       )
-   ifcIntro :: Activity -> Blocks
-   ifcIntro act
-    =   purposes2Blocks flags purps
-      <> fromList (ifcAutoRules act)
-      <> fromList (if genEcaDoc flags then ifcEcaRules act else [])
-      where purps = purposesDefinedIn fSpec (fsLang fSpec) fSpec
-
-{-
-  ifcInsDelConcepts :: [Block]
-  ifcInsDelConcepts
-   = let ics = fsv_creating act>-fsv_deleting act
-         dcs = fsv_deleting act>-fsv_creating act
-         ucs = fsv_deleting act `isc` fsv_creating act
-     in case fsLang fSpec of
-      Dutch -> [Plain [Space]]++
-          if null ics && null dcs && null ucs then [Plain $ [Str "Deze interface maakt of verwijdert geen objecten langs geautomatiseerde weg."]] else
-          if null ics && null dcs             then [Plain $ [Str "Om regels te handhaven, mogen instanties van "]++commaNLPandoc (Str "en") (map (Str . name) ucs)++[Str " door deze interface geautomatiseerd worden aangemaakt en verwijderd."]] else
-          if null ics       &&       null ucs then [Plain $ [Str "Om regels te handhaven, mag deze interface instanties van "]++commaNLPandoc (Str "en") (map (Str . name) ucs)++[Str " geautomatiseerd verwijderen."]] else
-          if             null dcs && null ucs then [Plain $ [Str "Om regels te handhaven, mogen instanties van "]++commaNLPandoc (Str "en") (map (Str . name) ucs)++[Str " geautomatiseerd worden aangemaakt door deze interface."]] else
-          if                         null ucs then [Plain $ [Str "Instanties van "]++commaNLPandoc (Str "en") (map (Str . name) ucs)++[Str " mogen worden toegevoegd en instanties van "]++f dcs++[Str " mogen worden verwijderd door deze interface. Dat gebeurt geautomatiseerd en uitsluitend waar nodig om regels te handhaven."]] else
-          if             null dcs             then [Plain $ [Str "Deze interface mag instanties van "]++commaNLPandoc (Str "en") (map (Str . name) ics)++[Str " creeren, terwijl instanties van "]++commaNLPandoc (Str "en") (map (Str . name) ucs)++[Str " ook verwijderd mogen worden. Alleen waar nodig mag dit plaatsvinden om regels te handhaven."]] else
-          if null ics                         then [Plain $ [Str "Deze interface mag instanties van "]++commaNLPandoc (Str "en") (map (Str . name) ucs)++[Str " wijzigen, maar instanties van "]++commaNLPandoc (Str "en") (map (Str . name) dcs)++[Str " mogen alleen worden verwijderd. Dat mag slechts dan gebeuren wanneer dat nodig is voor het handhaven van regels."]] else
-          [Plain $ [Str "Deze interface maakt nieuwe instanties van concept"]++f ics++[Str ". Hij mag instanties van concept"]++f dcs++[Str " verwijderen, terwijl instanties van "]++commaNLPandoc (Str "en") (map (Str . name) ucs)++[Str " zowel gemaakt als vernietigd mogen worden."]]
-          where f [x] = [Space, Str (name x), Space]
-                f xs  = [Str "en "]++commaNLPandoc (Str "en") (map (Str . name) xs)
-      English -> [Plain [Space]]++
-          if null ics && null dcs && null ucs then [Plain $ [Str "In this interface, no objects are made or removed automatically."]] else
-          if null ics && null dcs             then [Plain $ [Str "In order to maintain rules, instances of "]++f ucs++[Str " may be created or deleted by this interface automatically."]] else
-          if null ics       &&       null ucs then [Plain $ [Str "In order to maintain rules, instances of "]++f dcs++[Str " may be deleted automatically by this interface."]] else
-          if             null dcs && null ucs then [Plain $ [Str "In order to maintain rules, instances of "]++f ics++[Str " may be automatically inserted by this interface."]] else
-          if                         null ucs then [Plain $ [Str "Concept"]++f ics++[Str " may be inserted, and concept"]++f dcs++[Str " may be deleted by this interface. This happens only if necessary for maintaining rules."]] else
-          if             null dcs             then [Plain $ [Str "By this interface, concept"]++f ucs++[Str " may be changed, but"]++f ics++[Str " may be created but not deleted. This happens only if necessary for maintaining rules."]] else
-          if null ics                         then [Plain $ [Str "By this interface, concept"]++f ucs++[Str " may be changed, but"]++f dcs++[Str " may only be deleted. This happens only if necessary for maintaining rules."]] else
-          [Plain $ [Str "This interface can create new instances of concept"]++f ics++[Str ". It may delete instances of concept"]++f dcs++[Str ", and instances of concept"]++f ucs++[Str " may be either created and removed. Such actions will take place only in order to maintain rules."]]
-          where f [x] = [Space, Str (name x)]
-                f xs  = [Str "s "]++commaEngPandoc (Str "and") (map (Str . name) xs)
--}
-
-   ifcAutoRules :: Activity -> [Block]
-   ifcAutoRules act
-    = case fsLang fSpec of
-       Dutch ->   [Plain ([Str "Activiteit",Space, Quoted SingleQuote [(Str . name . actRule) act], Space,Str "moet door een gebruiker met rol "]++commaNLPandoc (Str "of") rols++[Str" worden uitgevoerd."] ++
-                          case length auts of
-                           0 -> []
-                           1 -> [Space,Str "Daarbij wordt regel",Space]++auts++[Space,Str "gehandhaafd zonder interventie van de gebruiker."]
-                           _ -> [Space,Str "Daarbij worden regels",Space]++commaNLPandoc (Str "en") auts++[Space,Str "gehandhaafd zonder interventie van de gebruiker."]
-                  )]
-       English -> [Plain ([Str "Activity",Space, Quoted SingleQuote [(Str . name . actRule) act], Space,Str "must be performed by a user with role "]++commaEngPandoc (Str "or") rols++[Str"."] ++
-                          case length auts of
-                           0 -> []
-                           1 -> [Space,Str "During that activity, rule",Space]++auts++[Space,Str "will be maintained without intervention of a user."]
-                           _ -> [Space,Str "During that activity, rules",Space]++commaEngPandoc (Str "and") auts++[Space,Str "will be maintained without intervention of a user."]
-                  )]
-      where
-         auts = nub [ Quoted  SingleQuote [Str (name r)] | q<-actQuads act, let r=(cl_rule.qClauses) q, r_usr r == UserDefined]
-         rols = nub [Str r | (r,rul)<-fRoleRuls fSpec, rul==actRule act] 
-
-   ifcEcaRules :: Activity -> [Block]
-   ifcEcaRules act
-    = ( case (fsLang fSpec, actEcas act) of
-         (Dutch,[])   -> [Plain [Str "Alle veranderingen die een gebruiker uitvoert zijn handmatig. Er is geen geautomatiseerde functionaliteit in deze activiteit."]]
-         (English,[]) -> [Plain [Str "All changes a user makes are done by hand. There is no automated functionality in this activity."]]
-         (Dutch,_)    -> [Plain [Str "De volgende tabel laat zien welke edit-acties welke functie aanroepen."]]
-         (English,_)  -> [Plain [Str "The following table shows which edit actions invoke which function."]]
-      )++
-      if length (actEcas act)<1 then [] else
-      [ Table [] [AlignLeft,AlignLeft,AlignLeft] [0.0,0.0,0.0]
-        ( case fsLang fSpec of
-           Dutch   ->
-               [[Plain [Str "actie"]]
-               ,[Plain [Str "relatie"]]
-               ,[Plain [Str "regel"]]]
-           English   ->
-               [[Plain [Str "action"]]
-               ,[Plain [Str "relation"]]
-               ,[Plain [Str "rule"]]] )
-        [ [ [Plain [ (Str . show . eSrt.ecaTriggr) eca]]
-          , [Plain [ (Str . show . eDcl.ecaTriggr) eca]]
-          , [Plain (shwEca eca)]
-          ] 
-        | eca<-actEcas act  -- tail haalt het eerste veld, zijnde I[c], eruit omdat die niet in deze tabel thuishoort.
-        ]]
-     where
-      shwEca :: ECArule -> [Inline]
-      shwEca eca
-       | isBlk (ecaAction eca)
-            = Str "error: rule ":
-              commaEngPandoc (Str "and")
-                       [ Quoted  SingleQuote [Str (let nrRules = length rs
-                                                       s  | nrRules == 0  = ""
-                                                          | nrRules == 1  = name (head rs)
-                                                          | otherwise     = name (head rs)++" (and "++show(nrRules - 1)++" other rules)."
-                                                   in s
-                                                  )]
-                       | (_,rs)<-paMotiv (ecaAction eca)
-                       ] 
-       | isNop (ecaAction eca)
-            = [ Str "no op"]
-       | otherwise = [ Str "ECA rule ", Str ((show . ecaNum ) eca) ]
-{-
-  ifcFieldTables
-   = if null (fsv_fields act) then [] else
-     if length (fsv_fields act)==1
-     then [ Para  $ [ case fsLang fSpec of
-                       Dutch   -> Str "In deze interface is het volgende veld zichtbaar: "
-                       English -> Str "This interface has one field: "
-                    ]
-          , head [b | BulletList [bs]<-[flds], b<-bs]
-          ]
-     else [ Para  $ [ case fsLang fSpec of
-                       Dutch   -> Str "In deze interface zijn de volgende velden zichtbaar. "
-                       English -> Str "This interface has the following fields. "
-                    ]
-          , flds
-          ]
-     where flds :: Block
-           flds = BulletList [recur ((objctx.ifcObj.fsv_ifcdef) act) f | f<-fsv_fields act]
-            where recur :: Expression -> Field -> [Block]
-                  recur e f | null (fld_sub f) = fld e f
-                            | otherwise        = fld e f ++
-                                                 [ BulletList [recur (ECps [e,fld_expr f']) f' | f'<-fld_sub f] ]
-           fld e f = [ Para [ Str (dealWithUnderscores (fld_name f)++if null cols then "" else "("++intercalate ", " cols++")") ]
-                     , Para [ Str "display on start: ", Math InlineMath $ showMath (conjNF e) ]
-                     ] 
-            where cols = ["lijst"         | fld_list    f]++
-                         ["verplicht"     | fld_must    f]++
-                         ["nieuw"         | fld_insAble f]++
-                         ["verwijderbaar" | fld_delAble f]
-                     
-           dealWithUnderscores :: String -> String
-           dealWithUnderscores x = 
-                  case x of 
-                    []     -> []
-                    '_':cs -> "\\_" ++ dealWithUnderscores cs
-                    c:cs   -> c : dealWithUnderscores cs
--}
-
-   txtKnowledgeGraph :: Activity -> [Block]
-   txtKnowledgeGraph act
-    = (case fsLang fSpec of                                     -- announce the knowledge graph
-           Dutch   -> [Para [ Str "Figuur ", xrefReference (picKnowledgeGraph flags fSpec act) 
-                            , Str " geeft de kennisgraaf weer voor deze interface."]]
-           English -> [Para [ Str "Figure ", xrefReference (picKnowledgeGraph flags fSpec act)
-                            , Str " shows the knowledge graph of this interface."]]
-      )
-      ++ [Plain ((toList . showImage flags) (picKnowledgeGraph flags fSpec act))]    -- draw the knowledge graph
-
-   txtSwitchboard :: Activity ->[Block]
-   txtSwitchboard act
-    = (if name act==name (head (fActivities fSpec)) then switchboardIntro else [])++
-     (case fsLang fSpec of                                     -- announce the switchboard diagram
-           Dutch   -> [Para [ Str "Figuur ", xrefReference (picSwitchboard flags fSpec act)
-                            , Str " geeft het schakelpaneel (switchboard diagram) weer voor deze interface."]]
-           English -> [Para [ Str "Figure ", xrefReference (picSwitchboard flags fSpec act)
-                            , Str " shows the switchboard diagram of this interface."]]
-     )
-     ++ [Plain ((toList . showImage flags) (picSwitchboard flags fSpec act))]        -- draw the switchboard
-
-   switchboardIntro :: [Block]
-   switchboardIntro
-    = if not (graphic flags) then [] else
-     [ Para $ case fsLang fSpec of                             -- tells us for who this interface exists
-        Dutch   -> [ Str "Iedere sectie in dit hoofdstuk beschrijft één activiteit. "
-                   , Str "Tijdens het uitvoeren van een activiteit zal een gebruiker populatie invoegen of verwijderen in verschillende relaties. "
-                   , Str "Hierdoor kunnen invarianten potentieel worden overtreden. "
-                   , Str "(Een invariant is een bedrijfsregel die op ieder moment waar moet blijven.) "
-                   , Str "De software die nodig is om invarianten waar te maken wordt automatisch gegenereerd. "
-                   , Str "De structuur van deze software wordt geïllustreerd door een zogenaamd schakelpaneel (switchboard-diagram), "
-                   , Str "waarvan u de eerste in figuur X aantreft. "
-                   , Str "Elk switchboard diagram bestaat uit drie kolommen: "
-                   , Str "Invariante regels staan in het midden en relaties staan aan de (linker en rechter) zijkanten. "
-                   , Str "Een pijl ter linkerzijde wijst van een relatie die ge-edit wordt naar een regel die daardoor mogelijk overtreden wordt. "
-                   , Str "Elke pijl ter rechterzijde van een regel representeert een edit-actie die nodig is om het waar-zijn ervan te herstellen. "
-                   , Str "Deze pijl wijst naar de relatie waarin deze herstel-actie moet worden uitgevoerd. "
-                   , Str "Een pijl gelabeled met '+' duidt op een insert event; een pijl met '-' op  "
-                   , Str "Hierdoor onstaat een accuraat beeld op welke manier de activiteit alle invarianten handhaaft. "
-                   ]
-        English -> [ Str "Every section in this chapter describes one activity. "
-                   , Str "While performing an activity, users will insert or delete population in various relations. "
-                   , Str "This may potentially violate invariants. "
-                   , Str "(An invariant is a business rule rules that must remain true at all times.) "
-                   , Str "The software to maintain the truth of invariant rules is generated automatically. "
-                   , Str "The structure of that software is illustrated by a so called switchboard diagram, "
-                   , Str "the first of which you will find in figure X. "
-                   , Str "Each switchboard diagram consists of three columns: "
-                   , Str "Invariant rules are drawn in the middle, and relations occur on the (right and left hand) sides. "
-                   , Str "An arrow on the left hand side points from a relation that may be edited to a rule that may be violated as a consequence thereof. "
-                   , Str "Each arrow on the right hand side of a rule represents an edit action that is required to restore its truth. "
-                   , Str "It points to the relation that is edited for that purpose. "
-                   , Str "If that arrow is labeled '+', it involves an insert event; if labeled '-' it refers to a delete event. "
-                   , Str "This yields an accurate perspective on the way in which invariants are maintained. "
-                   ]
-     ]
-
-picKnowledgeGraph :: Options -> Fspc -> Activity ->Picture
-picKnowledgeGraph flags fSpec act = makePicture flags fSpec (PTFinterface act)
-
-picSwitchboard :: Options -> Fspc -> Activity -> Picture
-picSwitchboard flags fSpec act
-    = makePicture flags fSpec (PTSwitchBoard act) -- the Picture that represents this interface's knowledge graph
-
-
-graphic :: Options -> Bool
-graphic flags = genGraphics flags && theme flags /= StudentTheme
-

− src/lib/DatabaseDesign/Ampersand/Output/ToPandoc/ChapterIntroduction.hs 
@@ -1,150 +0,0 @@-{-# OPTIONS_GHC -Wall #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-module DatabaseDesign.Ampersand.Output.ToPandoc.ChapterIntroduction
-where
-import DatabaseDesign.Ampersand.Output.ToPandoc.SharedAmongChapters 
-import Data.Time.Format
-
-chpIntroduction :: Fspc -> Options -> Blocks
-chpIntroduction fSpec flags =
-      chptHeader (fsLang fSpec) Intro
-   <> fromList purposesOfContext  -- the motivation(s) of this context 
-   <> readingGuide                -- tells what can be expected in this document.
-  where 
-    readingGuide 
-      = case fsLang fSpec of
-          Dutch
-            -> para ( text "Dit document"
-                   <> (note.para.text) ("Dit document is gegenereerd op "++date++" om "++time++", dmv. "++ampersandVersionStr++".")
-                   <> text " definieert de functionaliteit van een informatiesysteem genaamd "
-                   <> (singleQuoted.text.name) fSpec
-                   <> text ". "
-                   <> text "Het definieert de database en de business-services van " <> (text.name) fSpec <> text " door middel van bedrijfsregels"
-                   <> (note.para.text) "Het ontwerpen met bedrijfsregels is een kenmerk van de Ampersand aanpak, die gebruikt is bij het samenstellen van dit document. "
-                   <> text ". "
-                   <> (if SharedLang `elem` chaptersInDoc flags
-                       then ( if canXRefer flags 
-                              then text "Deze afspraken staan opgesomd in hoofdstuk "
-                                <> xRefReference flags SharedLang
-                              else text "Deze afspraken staan opgesomd in het hoofdstuk genaamd "
-                                <> (doubleQuoted.chptTitle (fsLang fSpec)) SharedLang
-                            ) <> text ", geordend op thema. "
-                       else text "Deze afspraken zijn niet opgenomen in dit document."
-                      )
-                    )
-            <> if Diagnosis `elem` chaptersInDoc flags
-               then para ((if canXRefer flags 
-                           then text "De diagnose in hoofdstuk "
-                             <> xRefReference flags Diagnosis
-                           else text "De diagnose in het hoofdstuk genaamd"
-                             <> (doubleQuoted.chptTitle (fsLang fSpec)) Diagnosis
-                          ) <> text " is bedoeld voor de auteurs om gebreken uit hun Ampersand model op te sporen. "
-                         )
-               else mempty
-            <> if ConceptualAnalysis `elem` chaptersInDoc flags
-               then para ( ( if canXRefer flags 
-                             then text "De conceptuele analyse in hoofdstuk "
-                               <> xRefReference flags ConceptualAnalysis
-                             else text "De conceptuele analyse in het hoofdstuk genaamd"
-                               <> (doubleQuoted.chptTitle (fsLang fSpec)) ConceptualAnalysis
-                           ) <> text " is bedoeld voor requirements engineers en architecten om de gemaakte afspraken"
-                             <> text " te valideren en te formaliseren. "
-                             <> text "Tevens is het bedoeld voor testers om eenduidige testgevallen te kunnen bepalen. "
-                             <> text "De formalisatie in dit hoofdstuk maakt consistentie van de functionele specificatie bewijsbaar. "
-                             <> text "Ook garandeert het een eenduidige interpretatie van de afspraken."
-                         )
-               else mempty
-            <> if DataAnalysis `elem` chaptersInDoc flags
-               then para ( text "De hoofdstukken die dan volgen zijn bedoeld voor de bouwers van "
-                        <> (singleQuoted.text.name) fSpec
-                        <> text ". "
-                        <> ( if canXRefer flags 
-                             then text "De gegevensanalyse in hoofdstuk "
-                               <> xRefReference flags DataAnalysis
-                             else text "De gegevensanalyse in het hoofdstuk genaamd"
-                               <> (doubleQuoted.chptTitle (fsLang fSpec)) DataAnalysis
-                           )
-                        <> text " beschrijft de gegevensverzamelingen waarop "
-                        <> (singleQuoted.text.name) fSpec
-                        <> text " wordt gebouwd. "
-                        <> text "Elk volgend hoofdstuk definieert één business service. "
-                        <> text "Hierdoor kunnen bouwers zich concentreren op één service tegelijk. "
-                         )
-                 <> para ( text "Tezamen ondersteunen deze services alle geldende afspraken. "
-                        <> text "Door alle functionaliteit uitsluitend via deze services te ontsluiten waarborgt "
-                        <> (singleQuoted.text.name) fSpec
-                        <> text " compliance ten aanzien van alle gestelde afspraken. "
-                         )
-               else mempty
-
-
-          English
-            -> para ( text "This document"
-                   <> (note.para.text) ("This document was generated at "++date++" on "++time++", using "++ampersandVersionStr++".")
-                   <> text " defines the functionality of an information system called "
-                   <> (singleQuoted.text.name) fSpec
-                   <> text ". "
-                   <> text "It defines the database and the business services of " <> (text.name) fSpec <> text " by means of business rules"
-                   <> (note.para.text) "Rule based design characterizes the Ampersand approach, which has been used to produce this document. "
-                   <> text ". "
-                   <> (if SharedLang `elem` chaptersInDoc flags
-                       then ( if canXRefer flags 
-                              then text "Those rules are listed in chapter "
-                                <> xRefReference flags SharedLang
-                                <> text ", ordered by theme. "
-                              else text "Those rules are listed in the chapter named "
-                                <> (doubleQuoted.chptTitle (fsLang fSpec)) SharedLang
-                            ) <> text ", ordered by theme. " 
-                       else text "Those rules are not included in this document."
-                      )
-                    ) 
-             <> if Diagnosis `elem` chaptersInDoc flags
-               then para ((if canXRefer flags 
-                           then text "The diagnosis in chapter "
-                             <> xRefReference flags Diagnosis
-                           else text "The diagnosis in the chapter named "
-                             <> (doubleQuoted.chptTitle (fsLang fSpec)) Diagnosis
-                          ) <> text " is meant to help the authors identify shortcomings in their Ampersand script."
-                         )
-               else mempty
-            <> if ConceptualAnalysis `elem` chaptersInDoc flags
-               then para ( ( if canXRefer flags 
-                             then text "The conceptual analysis in chapter "
-                               <> xRefReference flags ConceptualAnalysis
-                             else text "The conceptual analysis in the chapter named "
-                               <> (doubleQuoted.chptTitle (fsLang fSpec)) ConceptualAnalysis
-                           ) <> text " is meant for requirements engineers and architects to validate and formalize the requirements. "
-                             <> text "It is also meant for testers to come up with correct test cases. "
-                             <> text "The formalization in this chapter makes consistency of the functional specification provable. "
-                             <> text "It also yields an unambiguous interpretation of all requirements."
-                         )
-               else mempty
-            <> if DataAnalysis `elem` chaptersInDoc flags
-               then para ( text "Chapters that follow have the builders of "
-                        <> (singleQuoted.text.name) fSpec
-                        <> text " as their intended audience. "
-                        <> ( if canXRefer flags 
-                             then text "The data analysis in chapter "
-                               <> xRefReference flags DataAnalysis
-                             else text "The data analysis in the chapter named "
-                               <> (doubleQuoted.chptTitle (fsLang fSpec)) DataAnalysis
-                           )
-                        <> text " describes the data sets upon which "
-                        <> (singleQuoted.text.name) fSpec
-                        <> text " is built. "
-                        <> text "Each subsequent chapter defines one business service. "
-                        <> text "This allows builders to focus on a single service at a time. "
-                         )
-                 <> para ( text "Together, these services fulfill all commitments. "
-                        <> text "By disclosing all functionality exclusively through these services, "
-                        <> (singleQuoted.text.name) fSpec
-                        <> text " ensures compliance to all rules aggreed upon."
-                         )
-               else mempty
-      
-    date = formatTime (lclForLang (fsLang fSpec)) "%-d-%-m-%Y" (genTime flags)
-    time = formatTime (lclForLang (fsLang fSpec)) "%H:%M:%S" (genTime flags)
- 
-    purposesOfContext = concat [amPandoc (explMarkup p) | p<-purposesDefinedIn fSpec (fsLang fSpec) fSpec]
-    
- 
− src/lib/DatabaseDesign/Ampersand/Output/ToPandoc/ChapterNatLangReqs.hs 
@@ -1,450 +0,0 @@-{-# OPTIONS_GHC -Wall #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE OverloadedStrings #-}
-module DatabaseDesign.Ampersand.Output.ToPandoc.ChapterNatLangReqs where
-
-import Data.Char hiding (Space)
-import Data.List
-import Data.List.Split
-import GHC.Exts (sortWith)
-import Data.Maybe
-import DatabaseDesign.Ampersand.Basics
-import DatabaseDesign.Ampersand.Output.ToPandoc.SharedAmongChapters hiding (sortWith)
-import DatabaseDesign.Ampersand.ADL1
-import DatabaseDesign.Ampersand.Classes
-import DatabaseDesign.Ampersand.Output.PandocAux
-import Text.Pandoc.Builder
-
-fatal :: Int -> String -> a
-fatal = fatalMsg "Output.ToPandoc.ChapterNatLangReqs"
-
-{- TODO: This module needs to be rewritten from scratch. Instead of deciding on the fly what should be included, 
-         a datastructure needs to be added to the fSpec, which contains per theme the concepts, rules and relations
-         that need to be printed.  
--}
-chpNatLangReqs :: Int -> Fspc -> Options ->  Blocks
-chpNatLangReqs lev fSpec flags = 
-      --  *** Header ***
-   chptHeader (fsLang fSpec) SharedLang
-   <> --  *** Intro  ***
-    case fsLang fSpec of
-        Dutch   -> para
-                     (  "Dit hoofdstuk beschrijft een natuurlijke taal, waarin functionele eisen ten behoeve van "
-                     <> (singleQuoted.str.name) fSpec
-                     <> " kunnen worden besproken en uitgedrukt. "
-                     <> "Hiermee wordt beoogd dat verschillende belanghebbenden hun afspraken op dezelfde manier begrijpen. "
-                     <> "De taal van "
-                     <> (singleQuoted. str. name) fSpec
-                     <> " bestaat uit begrippen en basiszinnen, "
-                     <> "waarin afspraken worden uitgedrukt. "
-                     <> "Wanneer alle belanghebbenden afspreken dat zij deze basiszinnen gebruiken, "
-                     <> "althans voor zover het "
-                     <> (singleQuoted. str. name) fSpec
-                     <> " betreft, "
-                     <> "delen zij precies voldoende taal om afspraken op dezelfde manier te begrijpen. "
-                     <> "Alle definities zijn genummerd omwille van de traceerbaarheid. "
-                     )
-        English -> para
-                     (  "This chapter defines the natural language, in which functional requirements of "
-                     <> (singleQuoted.str.name) fSpec
-                     <> " can be discussed and expressed. "
-                     <> "The purpose of this chapter is to create shared understanding among stakeholders. "
-                     <> "The language of "
-                     <> (singleQuoted.str.name) fSpec
-                     <> " consists of concepts and basic sentences. "
-                     <> "All functional requirements are expressed in these terms. "
-                     <> "When stakeholders can agree upon this language, "
-                     <> "at least within the scope of "
-                     <> (singleQuoted.str.name) fSpec
-                     <> ", they share precisely enough language to have meaningful discussions about functional requirements. "
-                     <> "All definitions have been numbered for the sake of traceability. "
-                     )
-   <> --  *** Requirements ***
-   fromList dpRequirementsOld
---   dpRequirementesNew 
-   <> --  *** Legal Refs ***
-     if genLegalRefs flags then legalRefs else mempty
-       
-   
-  where
-  legalRefs :: Blocks
-  legalRefs = (labeledThing flags (lev+1) "LegalRefs" sectionTitle) 
-            <> table caption'
-                     [(AlignLeft,1/4),(AlignLeft,3/4)]
-                     [plain lawHeader, plain articleHeader]  --headers
-                     [ [(para.str.aOlLaw) art  , (para.str.unscanRef.aOlArt) art]
-                     | art <-(sort.nub.concatMap getArticlesOfLaw.getRefs) fSpec  ]
-                     
-         where (sectionTitle, lawHeader, articleHeader, caption') = 
-                 case fsLang fSpec of
-                   Dutch   -> ("Referentietabel", "Wet", "Artikel", "Referentietabel van de wetsartikelen")
-                   English -> ("Reference table", "Law", "Article", "Reference table of articles of law")
-               getRefs ::Fspc ->  [LawRef]
-               getRefs f = concatMap catMaybes ((map (map toLawRef).map explRefIds.explanations) f)
-
-  dpRequirementesNew :: Blocks
-  dpRequirementesNew =  let (_,blocks) = foldl printTheme (newCounter,mempty)  (orderingByTheme fSpec)
-                        in blocks
-    where
-     printTheme :: (Counter,Blocks)
-                -> ( Maybe Theme   -- A theme is about either a pattern or a process. 
-                   , [Rule]        -- The rules of that theme
-                   , [Declaration] -- The relations that are used in a rule of this theme, but not in any rule of a previous theme.
-                   , [A_Concept]   -- The concepts that are used in a rule of this theme, but not in any rule of a previous theme.
-                   ) -> (Counter,Blocks)
-     printTheme (counter,bs) themeStuff  =
-        let (blocks,count') = printOneTheme themeStuff counter
-        in (count',bs <> blocks)
-  
-  dpRequirementsOld :: [Block]
-  dpRequirementsOld = theBlocks
-    where
-      (theBlocks,_) = if null (themes fSpec)
-                      then printThemes toBeProcessedStuff newCounter $ map PatternTheme (patterns fSpec) ++ map (ProcessTheme . fpProc) (vprocesses fSpec)
-                      else printThemes toBeProcessedStuff newCounter $ [ PatternTheme pat | pat<-patterns fSpec, name pat `elem` themes fSpec ] ++
-                                                                       [ ProcessTheme $ fpProc fprc | fprc<-vprocesses fSpec, name fprc `elem` themes fSpec ] 
-      toBeProcessedStuff = ( conceptsWith
-                           , allRelsThatMustBeShown
-                           , [r | r<-vrules fSpec, r_usr r == UserDefined] )  -- All user declared rules
-         where
-           conceptsWith     -- All concepts that have at least one non-empty definition (must be the first)  
-              = [ c
-                | c@PlainConcept{} <- concs fSpec
-                , (not.null) (concDefs fSpec c)
-                ]           
-           allRelsThatMustBeShown -- All relations declared in this specification that have at least one user-defined purpose.
-              = [ d | d <- relsDefdIn fSpec
-                , decusr d
-                , not . null $ purposesDefinedIn fSpec (fsLang fSpec) d
-                ]
-                 
-      printThemes :: (   [A_Concept]     -- all concepts that have one or more definitions or purposes. These are to be used into this section and the sections to come
-                       , [Declaration]           -- all relations to be processed into this section and the sections to come
-                       , [Rule])                 -- all rules to be processed into this section and the sections to come
-                    -> Counter           -- unique definition counters
-                    -> [Theme]         -- the patterns that must be processed into this specification
-                    -> ([Block],Counter) -- The blocks that define the resulting document and the last used unique definition number
-      printThemes  (still2doCPre, still2doRelsPre, still2doRulesPre) iPre allThemes 
-           = case allThemes of
-              []  -> if null still2doCPre && null still2doRelsPre && null still2doRelsPre
-                     then ([],iPre)
-                     else let (a,b) = printOneTheme (Nothing, still2doRulesPre, still2doRelsPre, still2doCPre) iPre
-                          in (toList a,b)
-              _   -> (toList blocksOfOneTheme ++ blocksOfThemes,iPost)
-         where
-           (thm:thms) = allThemes
-           (blocksOfOneTheme,iPostFirst) = printOneTheme  thisThemeStuff iPre
-           (blocksOfThemes,iPost)        = printThemes stuff2PrintLater iPostFirst thms
-           thisThemeStuff    = (Just thm, [r | r<-thisThemeRules, r_usr r == UserDefined], thisThemeRels, thisThemeCs)
-           thisThemeRules    = [r | r<-still2doRulesPre, r_env r == name thm ]      -- only user defined rules, because generated rules are documented in whatever caused the generation of that rule.
-           rules2PrintLater  = still2doRulesPre >- thisThemeRules
-           thisThemeRels     = [ d | d <- still2doRelsPre
-                               , decpat d == name thm ||         -- all relations declared in this theme, combined
-                                 d `eleM` relsMentionedIn thisThemeRules] -- all relations used in this theme's rules
-           rels2PrintLater   = [x | x <-still2doRelsPre, (not.or) [ x==y | y <- thisThemeRels ]] 
-           thisThemeCs       = [c | c <- still2doCPre, c `eleM` (concs thisThemeRules ++ concs thisThemeRels)] -- relations are rules ('Eis') too
-           concs2PrintLater  = still2doCPre >- thisThemeCs
-           stuff2PrintLater  = (concs2PrintLater, rels2PrintLater, rules2PrintLater)
-           
-      -- | printOneTheme tells the story in natural language of a single theme.
-      -- For this purpose, Ampersand authors should take care in composing explanations.
-      -- Each explanation should state the purpose (and nothing else).
-  printOneTheme :: ( Maybe Theme    -- The theme to process (if any)
-                   , [Rule]         -- Rules to print in this section
-                   , [Declaration]  -- Relations to print in this section
-                   , [A_Concept]    -- Concepts, to print in this section
-                   )
-                -> Counter      -- first free number to use for numbered items
-                -> (Blocks,Counter)-- the resulting blocks and first free number after processing of the theme.
-  printOneTheme (mTheme, rules2print, rels2print, concs2print) counter0
-    = case (mTheme, themes fSpec) of
-       (Nothing, _:_) 
-          -> ( mempty, counter0 )         -- The document is partial (because themes have been defined), so we don't print loose ends.
-       _  -> ( (  --  *** Header of the theme: ***
-                 labeledThing flags (lev+1) 
-                              (xLabel DataAnalysis++case mTheme of
-                                                          Nothing ->  "_LooseEnds"
-                                                          _       -> themeName
-                                                   )
-                                  (case (mTheme,fsLang fSpec) of
-                                      (Nothing, Dutch  ) -> "Losse eindjes..."
-                                      (Nothing, English) -> "Loose ends..."
-                                      _                  -> themeName
-                                  )
-
-
-               <> --  *** Purpose of the theme: ***
-                  case mTheme of 
-                      Nothing  -> case fsLang fSpec of
-                                     Dutch   -> para $ 
-                                                    "Deze paragraaf beschrijft de relaties en concepten die "
-                                                 <> "niet in voorgaande secties zijn beschreven."
-                                     English -> para $
-                                                    "This paragraph shows remaining fact types and concepts "
-                                                 <> "that have not been described in previous paragraphs."
-                      Just pat -> purposes2Blocks flags (purposesDefinedIn fSpec (fsLang fSpec) pat)
-                <> --  *** Introduction text of the theme: ***
-                   printIntro (filter isDefined concs2print) 
-                <> fromList reqdefs
-                )
-             , Counter (getEisnr counter0 + length reqs)
-             )
-           where
-              isDefined :: A_Concept -> Bool
-              isDefined = not.null.concDefs fSpec
-              -- the concepts for which one of the relations of this theme contains a source or target definition
-              -- (these will be printed, regardless whether the concept was printed before)
-              
-              -- sort the requirements by file position
-              reqs = sortWith fst [ ((i,filenm org, linenr org,colnr org), bs) 
-                                  | (i,org,bs)<- addIndex 0 (printConcepts concs2print) ++ 
-                                                 addIndex 2 (printRels rels2print) ++ addIndex 3 (printRules rules2print)]
-               where addIndex i ps = [ (i::Int,fs, sn) | (fs,sn) <- ps ] -- add an index to sort first on category (concept, rel, ..)
-              
-              -- make blocks for requirements
-              reqblocks = [(pos,req (Counter cnt)) | (cnt,(pos,req))<-zip [(getEisnr counter0)..] reqs]
-              reqdefs = concatMap snd reqblocks
-
-              themeName = case mTheme of
-                           Nothing  -> ""
-                           Just pat -> name pat
-                           --Just (PatternTheme pat) -> "Pattern "++name pat
-                           --Just (ProcessTheme prc) -> "Process "++name prc
-                                          
-
--- The following paragraph produces an introduction of one theme (i.e. pattern or process).
-              printIntro :: [A_Concept] -> Blocks
-              printIntro [] = mempty
-              printIntro ccds
-                = case fsLang fSpec of
-                      Dutch   -> (case ([(emph.str.unCap) cname | cname<-map name ccds]
-                                       , length [p |p <- map PatternTheme (patterns fSpec) ++ map (ProcessTheme . fpProc) (vprocesses fSpec), name p == themeName]
-                                       ) of
-                                    ([] ,_) -> mempty
-                                    ([_],1) -> case mTheme of
-                                                 Nothing  -> mempty
-                                                 Just tme -> para ( "In het volgende wordt de taal geïntroduceerd ten behoeve van "
-                                                                 <> (str.name) tme <> "."
-                                                                  )
-                                    (cs ,1) -> para ( "Nu volgen definities van de concepten "
-                                                   <> commaNLPandoc' ("en") cs <> ".")
-                                    ([c],_) -> para ( "Deze sectie introduceert het concept " <>  c )
-                                    (cs ,_) -> para ( "Deze sectie introduceert de concepten " <>
-                                                          commaNLPandoc' "en" cs <> ". ")
-                                 ) <>  
-                                 (let cs = [(c,cds) | (c)<-ccds, let cds = concDefs fSpec c,length cds>1] in
-                                   case (cs, length cs==length ccds) of
-                                    ([]       ,   _  ) -> mempty
-                                    ([(c,_)]  , False) -> para ("Eén daarvan, " <> (str.name) c <>", heeft meerdere definities. ")
-                                    (_        , False) -> para ("Daarvan hebben "<>commaNLPandoc' "en" (map (str. name . fst) cs)<> " meerdere definities. ")
-                                    ([(_,cds)], True ) -> para ("Deze heeft "<>str(count Dutch (length cds) "definitie")<>". ")
-                                    (_        , True ) -> para ("Elk daarvan heeft meerdere definities. ")
-                                 )
-                                  
-                      English -> (case ([(emph.str.unCap) cname | cname<-map name ccds]
-                                       , length [p |p <- map PatternTheme (patterns fSpec) ++ map (ProcessTheme . fpProc) (vprocesses fSpec), name p == themeName]
-                                       ) of
-                                    ([] ,_) -> mempty
-                                    ([_],1) -> case mTheme of
-                                                 Nothing  -> mempty
-                                                 Just tme -> para ( "The sequel introduces the language of "
-                                                                 <> (str.name) tme <> "."
-                                                                  )
-                                    (cs ,1) -> para ( "At this point, the definitions of "
-                                                   <> commaEngPandoc' "and" cs <>" are given.")
-                                    ([c],_) -> para ("This section introduces concept " <> c )
-                                    (cs ,_) -> para ("This section introduces concepts " <>
-                                                       commaEngPandoc' "and" cs <> ". ")
-                                 )<> 
-                                 (let cs = [(c,cds) | c <- ccds, let cds = concDefs fSpec c, length cds>1] in
-                                   case (cs, length cs==length ccds) of
-                                    ([]       ,   _  ) -> mempty
-                                    ([(c,_)]  , False) -> para ("One of these concepts, " <> (str.name) c <>", has multiple definitions. ")
-                                    (_        , False) -> para ("Of those concepts "<>commaEngPandoc' "and" (map (str. name . fst) cs)<> " have multiple definitions. ")
-                                    ([(_,cds)], True ) -> para ("It has "<>str(count English (length cds) "definition")<>". ")
-                                    (_        , True ) -> para ("Each one has several definitions. ")
-                                 )
-                                  
-
-              -- | the origin of c is the origin of the head of uniquecds c
-              --   after sorting by origin the counter will be applied
-              printConcepts :: [A_Concept] -> [(Origin, Counter -> [Block])]
-              printConcepts cs = map printConcept cs
-              printConcept :: A_Concept -> (Origin, Counter -> [Block])
-              printConcept c = (case uniquecds fSpec c of
-                                  []      -> OriginUnknown 
-                                  (_,x):_ -> origin x 
-                               , cptBlock c
-                               )
-              -- | make a block for a c with all its purposes and definitions
-              cptBlock :: A_Concept -> Counter -> [Block]
-              cptBlock cpt cnt = concat [amPandoc (explMarkup e) | e<-exps] 
-                  ++ zipWith cdBlock
-                       (if length (uniquecds fSpec cpt) == 1 then [(cnt, "")] else
-                          [(cnt, '.' : show i) | i <- [(1 :: Int) ..]])
-                       [ (nm, symDefLabel cd, cddef cd, cdref cd) | (nm, cd) <- uniquecds fSpec cpt ]
-                  where exps = case purposeOf fSpec (fsLang fSpec) cpt of
-                                 Nothing -> []
-                                 Just ps -> ps
-              -- | make a block for a concept definition
-              cdBlock :: (Counter,String) -> (String,String,String,String) -> Block
-              cdBlock (cnt,xcnt) (nm,lbl,def',ref) = DefinitionList 
-                                        [( [ Str (case fsLang fSpec of
-                                                                 Dutch   -> "Definitie "
-                                                                 English -> "Definition ")
-                                           , Str (show (getEisnr cnt)++xcnt)
-                                           , Str ":"]
-                                         , [ makeDefinition flags (getEisnr cnt)  nm lbl def' ref ])]
-
-
-              -- | sctds prints the requirements related to relations that are introduced in this theme.
-              printRels :: [Declaration] -> [(Origin, Counter -> [Block])]
-              printRels = map (\dcl -> (origin dcl, printRel dcl))
-              printRel :: Declaration -> Counter -> [Block]
-              printRel dcl cnt 
-               = Plain [RawInline (Text.Pandoc.Builder.Format "latex") "\\bigskip"] :
-                 toList (purposes2Blocks flags purps)
-                 ++ 
-                 [ DefinitionList [ ( [ Str (case fsLang fSpec of
-                                                      Dutch   -> "Afspraak "
-                                                      English -> "Agreement ")
-                                     , Str (show(getEisnr cnt))
-                                     ,if development flags && name dcl/="" then Str (" ("++name dcl++"):") else Str ":"]
-                                   , [ Plain [RawInline (Text.Pandoc.Builder.Format "latex") $ symReqLabel dcl]:
-                                       meaning2Blocks (fsLang fSpec) dcl
-                                     ]
-                                   )] ]++
-                 ( case (fsLang fSpec, length samplePop) of
-                        (_      , 0) -> []
-                        (Dutch  , 1) -> [Para [Str "Een frase die hiermee gemaakt kan worden is bijvoorbeeld:"]]
-                        (English, 1) -> [Para [Str "A phrase that can be formed is for instance:"]]
-                        (Dutch  , _) -> [Para [Str "Frasen die hiermee gemaakt kunnen worden zijn bijvoorbeeld:"]]
-                        (English, _) -> [Para [Str "Phrases that can be made are for instance:"]]
-                 ) ++
-                 sampleSentences
-                 where purps     = purposesDefinedIn fSpec (fsLang fSpec) dcl
-                       samplePop = (take 3 . fullContents (gens fSpec) (initialPops fSpec) . EDcD) dcl
-                       sampleSentences =
-                         [ Para $ mkSentence (development flags) dcl srcViewAtom tgtViewAtom 
-                         | p <-samplePop
-                         , let srcViewAtom = showViewAtom fSpec (Just dcl) (source dcl) (srcPaire p) 
-                         , let tgtViewAtom = showViewAtom fSpec Nothing (target dcl) (trgPaire p)
-                         ] ++
-                         (if null samplePop then [] else [Plain [RawInline (Text.Pandoc.Builder.Format "latex") "\\medskip"]])
-
-              printRules :: [Rule] -> [(Origin,Counter -> [Block])]
-              printRules = map (\rul -> (origin rul, printRule rul))
-
-  printRule :: Rule -> Counter -> [Block]
-  printRule rul cnt 
-   =  Plain [RawInline (Text.Pandoc.Builder.Format "latex") "\\bigskip"] :
-      toList (purposes2Blocks flags purps)
-      ++
-      [ DefinitionList [ ( [ Str (case fsLang fSpec of
-                                    Dutch   -> "Afspraak "
-                                    English -> "Agreement ")
-                           , Str (show(getEisnr cnt))
-                           , if development flags && name rul/="" then Str (" ("++name rul++"):") else Str ":"]
-                         , [ Plain [ RawInline (Text.Pandoc.Builder.Format "latex") $ symReqLabel rul] :
-                                       meaning2Blocks (fsLang fSpec) rul
-                           ]
-                         )
-                       ] 
-      | not (null$meaning2Blocks (fsLang fSpec) rul)]
-   where purps = purposesDefinedIn fSpec (fsLang fSpec) rul
-          
-  mkSentence :: Bool -> Declaration -> String -> String -> [Inline]
-  mkSentence isDev decl srcAtom tgtAtom
-   = case decl of
-       Sgn{} | null (prL++prM++prR) 
-                  -> [str' (upCap srcAtom), Space] ++ devShow (source decl) ++ [Str "corresponds",Space,Str "to",Space,str' tgtAtom, Space] ++ devShow (target decl) ++[Str "in",Space,Str "relation",Space,str' (decnm decl),Str "."]
-             | otherwise 
-                  -> leftHalf prL ++ rightHalf
-                    where prL = decprL decl
-                          prM = decprM decl
-                          prR = decprR decl
-                          leftHalf ""    = devShow (source decl)
-                          leftHalf prLft = [str' (upCap prLft), Space] ++ devShow (source decl)
-                          rightHalf = [str' srcAtom,Space,str' prM, Space] ++ devShow (target decl) ++ [str' tgtAtom]++(if null prR then [] else [Space,str' prR]) ++ [str' "."]
-
-       Isn{}     -> devShow (source decl) ++ [str' (upCap srcAtom),Space,Str "equals",Space,str' tgtAtom,Str "."]
-       Vs{}      -> [Str "True"]
-   where str' = if fspecFormat flags==FLatex then RawInline (Text.Pandoc.Builder.Format "latex") . latexEscShw else Str
-         devShow c | isDev     = [Str "(", str' $ name c, Str ") "] -- only show the concept when --dev option is given
-                   | otherwise = []
-
--- TODO: fix showing/not showing based on relation
--- TODO: what about relations in the target view?
--- TODO: move these to some auxiliaries or utils
-showViewAtom :: Fspc -> Maybe Declaration -> A_Concept -> String -> String
-showViewAtom fSpec mDec cncpt atom =
-  case mapMaybe (getView fSpec) (cncpt : largerConcepts (gens fSpec) cncpt) of
-    []    -> atom
-    view:_ -> case mDec of
-              Nothing -> concatMap showViewSegment (vdats view)
-              Just md -> if (not.null) [() | ViewExp objDef <- vdats view, EDcD d<-[objctx objDef], d==md]
-                         then atom
-                         else concatMap showViewSegment (vdats view)
-             -- if we are showing one of the view relations, don't expand the view
-     where showViewSegment (ViewText str') = str'
-           showViewSegment (ViewHtml str') = str'
-           showViewSegment (ViewExp objDef) = 
-             case [ trgPaire p | p <- fullContents (gens fSpec) (initialPops fSpec) (objctx objDef), atom == srcPaire p ] of
-               []         -> ""
-               viewAtom:_ -> viewAtom  
-        -- justViewRels = map (Just . objctx) [objDef | ViewExp objDef <- vdats view]
-
-{-
-getIdentity :: Fspc -> A_Concept -> Maybe IdentityDef
-getIdentity fSpec cncpt = 
-  case filter ((== cncpt) .  idCpt) (vIndices fSpec) of
-    []         -> Nothing 
-    identity:_ -> Just identity 
--}
-
-getView :: Fspc -> A_Concept -> Maybe ViewDef
-getView fSpec cncpt = 
-  case filter ((== cncpt) .  vdcpt) (vviews fSpec) of
-    []       -> Nothing 
-    viewDef:_ -> Just viewDef 
-    
-data LawRef = LawRef { lawRef :: String}
-data ArticleOfLaw = ArticleOfLaw { aOlLaw :: String
-                                 , aOlArt :: [Either String Int]
-                                 } deriving Eq
-toLawRef:: String -> Maybe LawRef
-toLawRef s = case s of
-              [] -> Nothing
-              _  -> (Just . LawRef) s
-getLaw :: ArticleOfLaw -> Inlines
-getLaw x = (str.aOlLaw) x
-
--- the article is everything but the law (and we also drop any trailing commas)
-getArticlesOfLaw :: LawRef -> [ArticleOfLaw]
-getArticlesOfLaw ref = map buildLA  ((splitOn ", ".unwords.init.words.lawRef) ref)
-   where 
-     buildLA art = ArticleOfLaw ((last.words.lawRef) ref) (scanRef art)
-       where
-    -- group string in number and text sequences, so "Art 12" appears after "Art 2" when sorting (unlike in normal lexicographic string sort)              
-         scanRef :: String -> [Either String Int]
-         scanRef "" = []
-         scanRef str'@(c:_) | isDigit c = scanRefInt str'
-                            | otherwise = scanRefTxt str'
-         scanRefTxt "" = []
-         scanRefTxt str' = let (txt, rest) = break isDigit str'
-                           in  Left txt : scanRefInt rest
-
-         scanRefInt "" = []
-         scanRefInt str' = let (digits, rest) = break (not . isDigit) str'
-                           in  Right (read digits) : scanRefTxt rest
-               
-  
-instance Ord ArticleOfLaw where
- compare a b =
-   case compare (aOlLaw a) (aOlLaw b) of
-     EQ   -> compare (aOlArt a) (aOlArt b)
-     ord' -> ord'
-
-unscanRef :: [Either String Int] -> String
-unscanRef scannedRef = concat $ map (either id show) scannedRef
-             
− src/lib/DatabaseDesign/Ampersand/Output/ToPandoc/ChapterProcessAnalysis.hs 
@@ -1,173 +0,0 @@-{-# OPTIONS_GHC -Wall #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-module DatabaseDesign.Ampersand.Output.ToPandoc.ChapterProcessAnalysis
-where
-import DatabaseDesign.Ampersand.Output.ToPandoc.SharedAmongChapters 
-import DatabaseDesign.Ampersand.Classes
-import Data.List
-import DatabaseDesign.Ampersand.Output.PandocAux
-
---DESCR -> the process analysis contains a section for each process in the fSpec
--- If an Ampersand script contains no reference to any role whatsoever, a process analysis is meaningless.
--- In that case it will not be printed. To detect whether this is the case, we can look whether the
--- mayEdit attributes remain empty.
-noProcesses :: Fspc -> Bool
-noProcesses fSpec = null (fRoles fSpec)
-
-chpProcessAnalysis :: Int -> Fspc -> Options -> (Blocks,[Picture])
-chpProcessAnalysis lev fSpec flags
- = if null procs
-   then (mempty,[])
-   else (headerBlocks <> fromList (roleRuleBlocks ++ roleRelationBlocks ++ processSections) , pictures)
- where
-  pictures = [pict | (_,picts)<-procSections procs,pict<-picts]
-  procs = if null (themes fSpec)
-          then vprocesses fSpec
-          else [ prc | prc<-vprocesses fSpec, name prc `elem` themes fSpec ]
-  processSections :: [Block]
-  processSections
-   = [block | (bs,_)<-procSections procs, block<-bs]
-
-  headerBlocks :: Blocks
-  headerBlocks
-   = (chptHeader (fsLang fSpec) ProcessAnalysis) <>
-     purposes2Blocks flags purps <> -- This explains the purpose of this context.
-     fromList( 
-     [ case fsLang fSpec of
-         Dutch   ->
-            Plain [ Str $ upCap (name fSpec)++" benoemt geen enkele rol. "
-                  , Str "Een generieke rol, User, zal worden gedefinieerd om al het werk te doen wat in het bedrijfsproces moet worden uitgevoerd."
-                  ]
-         English ->
-            Plain [ Str $ upCap (name fSpec)++" does not mention any role. "
-                  , Str "A generic role, User, will be defined to do all the work that is necessary in the business process."
-                  ]
-     | null (fRoles fSpec)] ++
-     [ case fsLang fSpec of
-         Dutch   ->
-            Plain [ Str $ upCap (name fSpec)++" specificeert niet welke rollen de inhoud van welke relaties mogen wijzigen. "
-                  , Str ""
-                  ]
-         English ->
-            Plain [ Str $ upCap (name fSpec)++" does not specify which roles may change the contents of which relations. "
-                  , Str ""
-                  ]
-     | null (fRoleRels fSpec)])
-     where purps = purposesDefinedIn fSpec (fsLang fSpec) fSpec
-
-  roleRuleBlocks :: [Block]
-  roleRuleBlocks
-   = if null (fRoleRuls fSpec) && (not.null.udefrules) fSpec then [] else
-     [ case fsLang fSpec of
-          Dutch   ->
-            Para [ Str $ upCap (name fSpec)++" kent regels aan rollen toe. "
-                 , Str "De volgende tabel toont de regels die door een bepaalde rol worden gehandhaafd."
-                 ]
-          English ->
-            Para [ Str $ upCap (name fSpec)++" assigns rules to roles. "
-                 , Str "The following table shows the rules that are being maintained by a given role."
-                 ]
--- the table containing the role-rule assignments
-     , Para  $ [ RawInline (Format "latex") "\\begin{tabular}{|l|l|}\\hline\n"
-               , case fsLang fSpec of
-                  Dutch   -> RawInline (Format "latex") "Rol&Regel\\\\ \\hline\n"
-                  English -> RawInline (Format "latex") "Role&Rule\\\\ \\hline\n"
-               ]++
-               [ RawInline (Format "latex") $ intercalate "\\\\ \\hline\n   " 
-                       [ role++" & "++name r++
-                         concat[ "\\\\\n   &"++name rul | rul<-map snd (tail rrClass)]
-                       | rrClass<-eqCl fst (fRoleRuls fSpec)
-                       , let role=fst (head rrClass), let r=snd (head rrClass)
-                       ]
-               ]++
-               [ RawInline (Format "latex") "\\\\ \\hline\n\\end{tabular}"
-               ]
-     ]
-
--- the table containing the role-relation assignments
-  roleRelationBlocks :: [Block]
-  roleRelationBlocks
-   = if null (fRoleRels fSpec) then [] else
-     [ case fsLang fSpec of
-          Dutch   ->
-            Para [ Str $ upCap (name fSpec)++" kent rollen aan relaties toe. "
-                 , Str "De volgende tabel toont de relaties waarvan de inhoud gewijzigd kan worden door iemand die een bepaalde rol vervult."
-                 ]
-          English ->
-            Para [ Str $ upCap (name fSpec)++" assigns roles to relations. "
-                 , Str "The following table shows the relations, the content of which can be altered by anyone who fulfills a given role."
-                 ]
-     , Para  $ [ RawInline (Format "latex") "\\begin{tabular}{|l|l|}\\hline\n"
-               , RawInline (Format "latex")
-                    (case  fsLang fSpec of
-                       Dutch   -> "Rol&Relatie\\\\ \\hline\n"
-                       English -> "Role&Relation\\\\ \\hline\n")
-               ]++
-               [ RawInline (Format "latex") $ intercalate "\\\\ \\hline\n   " 
-                       [ role++" & $"++showMath r++"$"++
-                         concat[ "\\\\\n   &$"++showMath (snd rs)++"$" | rs<-tail rrClass]
-                       | rrClass<-eqCl fst (fRoleRels fSpec)
-                       , let role=fst (head rrClass), let r=snd (head rrClass)
-                       ]
-               ]++
-               [ RawInline (Format "latex") "\\\\ \\hline\n" | not (null rolelessRels)]++
-               [ RawInline (Format "latex") $ intercalate "\\\\\n   " [ "&$"++showMath d++"$" | d<-rolelessRels] | not (null rolelessRels)]++
-               [ RawInline (Format "latex") "\\\\ \\hline\n\\end{tabular}"
-               ]
-     ]
-     where
-      rolelessRels = [ d | d<-relsDefdIn fSpec, d `notElem` (nub.map snd) (fRoleRels fSpec) ]
-
-  emptyProcess :: Process -> Bool
-  emptyProcess p = null (udefrules p)
-  
--- the sections in which processes are analyzed
-  procSections :: [FProcess] -> [([Block],[Picture])]
-  procSections fprocs = iterat [fp |fp<-fprocs, (not.emptyProcess.fpProc) fp] 1 declaredConcepts  declaredRelations
-   where
-    declaredRelations = (concatMap relsDefdIn.map fpProc.vprocesses) fSpec
-    declaredConcepts  = (concs.map fpProc.vprocesses) fSpec
-    iterat :: [FProcess] -> Int -> [A_Concept] -> [Declaration] -> [([Block],[Picture])]
-    iterat [] _ _ _ = []
-    iterat (fproc:fps) i seenConcepts seenDeclarations
-     = (  toList (labeledThing flags (lev+1) (xLabel ProcessAnalysis++"_"++name fproc) (name fproc))    -- new section to explain this theme
-       ++ toList (purposes2Blocks flags (purposesDefinedIn fSpec (fsLang fSpec) fproc))  
-       ++ txtProcessModel fproc
-   --    ++ txtLangModel fproc
-       ++ (if null sctRules then [] else [DefinitionList sctRules])
-       , [picProcessModel fproc]):  iterat fps i' seenCrs seenDrs
-       where
-         sctRules :: [([Inline], [[Block]])]
-         (sctRules,i',seenCrs,seenDrs) = dpRule fSpec flags (udefrules (fpProc fproc)) i seenConcepts seenDeclarations
-
---  txtLangModel :: FProcess->[Block]
---  txtLangModel fp
---   = if not (genGraphics flags) then [] else
---     -- (if name ifc==name (head (fActivities fSpec)) then processModelIntro else [])++
---      [Para (case fsLang fSpec of                                     -- announce the conceptual diagram
---             Dutch   -> [ Str "Het conceptueel diagram in figuur ", xrefReference pict
---                        , Str " geeft een overzicht van de taal waarin dit proces wordt uitgedrukt."]
---             English -> [ Str "The conceptual diagram of figure ", xrefReference pict
---                        , Str " provides an overview of the language in which this process is expressed."])
---      ,Plain ((toList . showImage flags) pict)]                     -- draw the diagram
---     where pict = picLangModel fp
-
-  txtProcessModel :: FProcess->[Block]
-  txtProcessModel p
-   = if not (genGraphics flags) then [] else
-     -- (if name ifc==name (head (fActivities fSpec)) then processModelIntro else [])++
-     [Para (case fsLang fSpec of                                     -- announce the processModel diagram
-             Dutch   -> [ Str "Figuur ", xrefReference pict
-                        , Str " geeft het procesmodel weer."]
-             English -> [ Str "Figure ", xrefReference pict
-                        , Str " shows the process model."])
-     ,Plain ((toList . showImage flags) pict)]                     -- draw the diagram
-     where pict = picProcessModel p
-
-
-
-  -- | the Picture that represents this interface's knowledge graph with only those relations that are used in rules (controlled by Plain_CG).
-  picProcessModel :: FProcess->Picture
-  picProcessModel fproc = makePicture flags fSpec (PTProcess fproc) 
-
-

− src/lib/DatabaseDesign/Ampersand/Output/ToPandoc/ChapterSoftwareMetrics.hs 
@@ -1,74 +0,0 @@-{-# OPTIONS_GHC -Wall #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-module DatabaseDesign.Ampersand.Output.ToPandoc.ChapterSoftwareMetrics
-where
-import DatabaseDesign.Ampersand.Output.ToPandoc.SharedAmongChapters 
---import DatabaseDesign.Ampersand.Output.Statistics (Statistics(..))
---import DatabaseDesign.Ampersand.Output.PandocAux
-
-
------------------- Function Point Analysis --------------------
--- TODO: Engels en Nederlands netjes scheiden.
--- TODO: Andere formaten dan LaTeX ondersteunen.
-
-fpAnalysis :: Fspc -> Options ->  Blocks
-fpAnalysis _ _ = mempty -- if null (themes fSpec) then header ++ caIntro ++ fpa2Blocks else []
- where 
---  header :: Blocks
---  header = chptHeader (fsLang fSpec) SoftwareMetrics
---  caIntro :: [Block]
---  caIntro = 
---   case fsLang fSpec of
---      Dutch   -> [Para
---                  [ Str "De specificatie van "
---                  , Quoted  SingleQuote [Str (name fSpec)]
---                  , Str " is geanalyseerd door middel van een functiepuntentelling"
---                  , xrefCitation "IFPUG"
---                  , Str ". "
---                  , Str $ "Dit heeft geresulteerd in een geschat totaal van "++(show.nFpoints) fSpec++" functiepunten."
---                  ]]
---      English -> [Para
---                  [ Str "The specification of "
---                  , Quoted  SingleQuote [Str (name fSpec)]
---                  , Str " has been analysed by counting function points"
---                  , xrefCitation "IFPUG"
---                  , Str ". "
---                  , Str $ "This has resulted in an estimated total of "++(show.nFpoints) fSpec++" function points."
---                  ]]
---   
---
---  fpa2Blocks' :: [Block]
---  fpa2Blocks' = []
---   = [ Table [] [AlignLeft,AlignLeft,AlignRight] [0.0,0.0,0.0]
---             ( case fsLang fSpec of
---                 Dutch   -> [ [Plain [Str "gegevensverzameling"]]
---                            , [Plain [Str "analyse"]]
---                            , [Plain [Str "FP"]]]
---                 English -> [ [Plain [Str "data set"]]
---                            , [Plain [Str "analysis"]]
---                            , [Plain [Str "FP"]]]
---             )
---             [ [ [Plain [(Str . name)                 plug]]
---               , [Plain [(Str . show . fpa)           plug]]
---               , [Plain [(Str . show . fPoints . fpa) plug]]
---               ]
---             | plug<-plugInfos fSpec, fPoints (fpa plug)>0
---             ]
---     , Table [] [AlignLeft,AlignLeft,AlignRight] [0.0,0.0,0.0]
---             ( case fsLang fSpec of
---                Dutch   ->
---                    [ [Plain [Str "interface"]]
---                    , [Plain [Str "analyse"]]
---                    , [Plain [Str "FP"]]]
---                English ->
---                    [ [Plain [Str "interface"]]
---                    , [Plain [Str "analysis"]]
---                    , [Plain [Str "FP"]]]
---             )
---             [ [ [Plain [(Str . name)                    act]]
---               , [Plain [(Str . show . actFPA)           act]]
---               , [Plain [(Str . show . fPoints . actFPA) act]]]
---             | act<-fActivities fSpec
---             ]
---     ]            
-

− src/lib/DatabaseDesign/Ampersand/Output/ToPandoc/SharedAmongChapters.hs 
@@ -1,374 +0,0 @@-{-# OPTIONS_GHC -Wall #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE OverloadedStrings #-}
-module DatabaseDesign.Ampersand.Output.ToPandoc.SharedAmongChapters 
-    ( module Text.Pandoc
-    , module Text.Pandoc.Builder
-    , bulletList -- (is redefined in this module, but belongs in Text.Pandoc.Builder.)
-    , math -- 
-    , module Data.Monoid
-    , module DatabaseDesign.Ampersand.Basics  
-    , module DatabaseDesign.Ampersand.Fspec
-    , module DatabaseDesign.Ampersand.Misc
-    , module DatabaseDesign.Ampersand.Core.AbstractSyntaxTree
-    , Chapter(..)
-    , chaptersInDoc
-    , chptHeader
-    , chptTitle
-    , Xreferencable(..)
-    , showImage
-    , canXRefer
-    , Purpose(..)
-    , purposes2Blocks
-    , isMissing
-    , lclForLang
-    , dpRule
-    , relsInThemes
-    , Counter(..),newCounter,incEis
-    , inlineIntercalate
-    , orderingByTheme
-    )
-where
-import DatabaseDesign.Ampersand.Basics  
-import DatabaseDesign.Ampersand.Core.AbstractSyntaxTree hiding (Meta)
-import DatabaseDesign.Ampersand.ADL1
-import DatabaseDesign.Ampersand.Classes
-import DatabaseDesign.Ampersand.Fspec
-import Text.Pandoc
-import Text.Pandoc.Builder hiding (bulletList,math)
-import qualified Text.Pandoc.Builder as  BuggyBuilder
-import DatabaseDesign.Ampersand.Output.PredLogic        (PredLogicShow(..), showLatex)
-import DatabaseDesign.Ampersand.Misc
-import DatabaseDesign.Ampersand.Output.PandocAux
-import Data.List             (intercalate,partition)
-import Data.Monoid
-import System.Locale
-
-fatal :: Int -> String -> a
-fatal = fatalMsg "Output.ToPandoc.SharedAmongChapters"
-
-data Chapter = Intro 
-             | SharedLang
-             | Diagnosis 
-             | ConceptualAnalysis
-             | ProcessAnalysis
-             | DataAnalysis
-             | SoftwareMetrics
-             | EcaRules
-             | Interfaces
-             | Glossary
-             deriving (Eq, Show)
-
--- | Define the order of the chapters in the document.
-chaptersInDoc :: Options -> [Chapter]  
-chaptersInDoc flags = [chp | chp<-chapters, chp `notElem` disabled]
- where
-   -- temporarily switch off chapters that need too much refactoring, but keep this Haskell code compilable.
-    disabled = [Interfaces]
-    chapters
-     | test flags                  = [SharedLang]
-     | diagnosisOnly flags         = [Diagnosis]
-     | theme flags == StudentTheme = [Intro,SharedLang,Diagnosis,ConceptualAnalysis,DataAnalysis]
-     | otherwise                   = [ Intro 
-                                     , SharedLang
-                                     , Diagnosis 
-                                     , ConceptualAnalysis
-                                     , ProcessAnalysis
-                                     , DataAnalysis
-                                     , SoftwareMetrics
-                                     , EcaRules
-                                     , Interfaces
-                                     , Glossary
-                                     ]
-
--- | This function returns a header of a chapter
-chptHeader :: Lang -> Chapter -> Blocks
-chptHeader lang chap 
- = header 1 (chptTitle lang chap ) <> singleton (Para [xrefLabel chap])
- 
-chptTitle :: Lang -> Chapter -> Inlines
-chptTitle lang cpt =
-     (case (cpt,lang) of
-        (Intro             , Dutch  ) -> text "Inleiding"
-        (Intro             , English) -> text "Introduction"
-        (SharedLang        , Dutch  ) -> text "Gemeenschappelijke taal"
-        (SharedLang        , English) -> text "Shared Language"
-        (Diagnosis         , Dutch  ) -> text "Diagnose" 
-        (Diagnosis         , English) -> text "Diagnosis" 
-        (ConceptualAnalysis, Dutch  ) -> text "Conceptuele Analyse"
-        (ConceptualAnalysis, English) -> text "Conceptual Analysis"
-        (ProcessAnalysis   , Dutch  ) -> text "Procesanalyse"
-        (ProcessAnalysis   , English) -> text "Process Analysis"
-        (DataAnalysis      , Dutch  ) -> text "Gegevensstructuur"
-        (DataAnalysis      , English) -> text "Data structure"
-        (SoftwareMetrics   , Dutch  ) -> text "Functiepunt Analyse"
-        (SoftwareMetrics   , English) -> text "Function Point Analysis"
-        (EcaRules          , Dutch  ) -> text "ECA regels" 
-        (EcaRules          , English) -> text "ECA rules (Flash points)" 
-        (Interfaces        , Dutch  ) -> text "Koppelvlakken" 
-        (Interfaces        , English) -> text "Interfaces"
-        (Glossary          , Dutch  ) -> text "Begrippen"
-        (Glossary          , English) -> text "Glossary"
-     )
-
-class Xreferencable a where
-  xLabel :: a  -> String
-  xrefReference :: a  -> Inline   --Depreciated! TODO: use xRefReference instead
-  xrefReference a = RawInline (Text.Pandoc.Builder.Format "latex") ("\\ref{"++xLabel a++"}")
-  xRefReference :: Options -> a -> Inlines
-  xRefReference flags a 
-    | canXRefer flags = rawInline "latex" ("\\ref{"++xLabel a++"}")
-    | otherwise       = mempty -- "fatal 89 xreferencing is not supported!"
-  xrefLabel :: a -> Inline
-  xrefLabel a = RawInline (Text.Pandoc.Builder.Format "latex") ("\\label{"++xLabel a++"}")
-
-canXRefer :: Options -> Bool
-canXRefer opts = fspecFormat opts `elem` [FLatex] 
-
-instance Xreferencable Chapter where
-  xLabel a = "chapter" ++ escapeNonAlphaNum (show a)
-  
-instance Xreferencable Picture where
-  xLabel a = "figure" ++ escapeNonAlphaNum (caption a)
-
---Image [Inline] Target
---      alt.text (URL,title)
-showImage :: Options -> Picture -> Inlines
-showImage flags pict = 
-      case fspecFormat flags of
-         FLatex  -> rawInline "latex" ("\\begin{figure}[htb]\n\\begin{center}\n\\scalebox{"++scale pict++"}["++scale pict++"]{")
-         _       -> mempty
-   <> image (imagePath flags pict) (xLabel pict) (text $ "Here, "++caption pict++" should have been visible" )
-   <> case fspecFormat flags of
-         FLatex  -> rawInline "latex" "}\n"
-                  <>rawInline "latex" ("\\caption{"++latexEscShw (caption pict)++"}\n") 
-         _       -> mempty
-   <> singleton (xrefLabel pict)
-   <> case fspecFormat flags of
-         FLatex  -> rawInline "latex" "\n\\end{center}\n\\end{figure}"
-         _       -> mempty
-
--- | This function orders the content to print by theme. It returns a list of 
---   tripples by theme. The last tripple might not have a theme, but will contain everything
---   that isn't handled in a specific theme.
-orderingByTheme :: Fspc -> [( Maybe Theme   -- A theme is about either a pattern or a process. 
-                            , [Rule]        -- The rules of that theme
-                            , [Declaration] -- The relations that are used in a rule of this theme, but not in any rule of a previous theme.
-                            , [A_Concept]   -- The concepts that are used in a rule of this theme, but not in any rule of a previous theme.
-                            )
-                           ]
-orderingByTheme fSpec 
- = f (allRules fSpec) (filter isUserDefined (relsMentionedIn fSpec)) (allConcepts fSpec) tms
- where
-  isUserDefined d = case d of
-                       Sgn{} -> decusr d
-                       _     -> False  
-  -- | The themes that should be taken into account for this ordering
-  tms = if null (themes fSpec)
-        then map PatternTheme (patterns fSpec) ++ map (ProcessTheme . fpProc) (vprocesses fSpec)
-        else [ PatternTheme pat           | pat <-patterns   fSpec, name pat  `elem` themes fSpec ]
-           ++[ ProcessTheme (fpProc fprc) | fprc<-vprocesses fSpec, name fprc `elem` themes fSpec ] 
-  f ruls rels cpts ts
-   = case ts of
-       t:ts' -> let ( (rulsOfTheme,rulsNotOfTheme)
-                     , (relsOfTheme,relsNotOfTheme)
-                     , (cptsOfTheme,cptsNotOfTheme)
-                     ) = partitionByTheme t ruls rels cpts 
-                in (Just t, rulsOfTheme, relsOfTheme, cptsOfTheme)
-                   : f rulsNotOfTheme relsNotOfTheme cptsNotOfTheme ts'
-       []    -> [(Nothing, ruls, rels, cpts)]
-  -- | This function takes care of partitioning each of the 
-  --   lists in a pair of lists of elements which do and do not belong
-  --   to the theme, respectively 
-  partitionByTheme :: Theme
-                   -> [Rule]
-                   -> [Declaration]
-                   -> [A_Concept]
-                   -> ( ([Rule],[Rule])
-                      , ([Declaration],[Declaration])
-                      , ([A_Concept],[A_Concept])
-                      )
-  partitionByTheme thme ruls rels cpts
-      = ((rulsOfTheme,rulsNotOfTheme), (relsOfTheme,relsNotOfTheme), (cptsOfTheme,cptsNotOfTheme))
-     where 
-       (rulsOfTheme,rulsNotOfTheme) = partition isRulOfTheme ruls
-       isRulOfTheme r = r `elem` (case thme of
-                                    PatternTheme pat -> ptrls pat
-                                    ProcessTheme prc -> prcRules prc
-                                 )
-       (relsOfTheme,relsNotOfTheme) = partition isRelOfTheme rels
-       isRelOfTheme r = r `elem` (concatMap relsDefdIn rulsOfTheme++concatMap relsUsedIn rulsOfTheme)
-       (cptsOfTheme,cptsNotOfTheme) = partition isCptOfTheme cpts
-       isCptOfTheme c = c `elem` concatMap concs relsOfTheme
-        
-        
---GMI: What's the meaning of the Int?
-dpRule :: Fspc -> Options -> [Rule] -> Int -> [A_Concept] -> [Declaration]
-          -> ([([Inline], [[Block]])], Int, [A_Concept], [Declaration])
-dpRule fSpec flags = dpR
- where
-   dpR [] n seenConcs seenDeclarations = ([], n, seenConcs, seenDeclarations)
-   dpR (r:rs) n seenConcs seenDeclarations
-     = ( ( [Str (name r)]
-         , [ let purps = purposesDefinedIn fSpec (fsLang fSpec) r in            -- Als eerste de uitleg van de betreffende regel..
-             toList (purposes2Blocks flags purps) ++
-             toList (purposes2Blocks flags [p | d<-nds, p<-purposesDefinedIn fSpec (fsLang fSpec) d]) ++  -- Dan de uitleg van de betreffende relaties
-             [ Plain text1 | not (null nds)] ++
-             pandocEqnArray [ ( texOnly_Id(name d)
-                              , ":"
-                              , texOnly_Id(name (source d))++(if isFunction d then texOnly_fun else texOnly_rel)++texOnly_Id(name(target d))++symDefLabel d
-                              )
-                            |d<-nds] ++
-             [ Plain text2 | not (null rds)] ++
-             [ Plain text3 ] ++
-             (if showPredExpr flags
-              then pandocEqnArrayOnelabel (symDefLabel r) ((showLatex.toPredLogic) r)
-              else pandocEquation (showMath r++symDefLabel r)
-             )++
-             (if length nds>1 then text5 else [])
-           ] 
-         ): dpNext
-       , n'
-       , seenCs 
-       , seenDs
-       )
-       where
-        text1
-         = case (length nds,fsLang fSpec) of
-             (1,Dutch)   -> let d = head nds in
-                            [Str ("Om dit te formaliseren is een "++(if isFunction d then "functie" else "relatie")++" "),Str (name d),Str " nodig (",RawInline (Text.Pandoc.Builder.Format "latex") $ symDefRef d,Str "):"]
-             (1,English) -> let d = head nds in
-                            [Str "In order to formalize this, a ", Str (if isFunction d then "function" else "relation"), Space, Str (name d),Str " is introduced (",RawInline (Text.Pandoc.Builder.Format "latex") $ symDefRef d,Str "):"]
-             (l,Dutch)   -> [Str "Om te komen tot de formalisatie in vergelijking",RawInline (Text.Pandoc.Builder.Format "latex") "~",RawInline (Text.Pandoc.Builder.Format "latex") $ symDefRef r,Str (" zijn de volgende "++count Dutch l "relatie"++" nodig.")]
-             (l,English) -> [Str "To arrive at the formalization in equation",RawInline (Text.Pandoc.Builder.Format "latex") "~",RawInline (Text.Pandoc.Builder.Format "latex") $ symDefRef r,Str (", the following "++count English l "relation"++" are introduced.")]
-        text2
-         = (case (length nds,length rds,fsLang fSpec) of
-             (0,1,Dutch)   -> [Str "Definitie ",RawInline (Text.Pandoc.Builder.Format "latex") $ symDefRef (head rds), Space, Str "(", Str (name (head rds)), Str ") wordt gebruikt"]
-             (0,1,English) -> [Str "We use definition ",RawInline (Text.Pandoc.Builder.Format "latex") $ symDefRef (head rds), Space, Str "(", Str (name (head rds)), Str ")"]
-             (0,_,Dutch)   -> Str "We gebruiken definities ":commaNLPandoc (Str "en") [RawInline (Text.Pandoc.Builder.Format "latex") $ symDefRef d++" ("++texOnly_Id (name d)++")" |d<-rds]
-             (0,_,English) -> Str "We use definitions ":commaEngPandoc (Str "and") [RawInline (Text.Pandoc.Builder.Format "latex") $ symDefRef d++" ("++texOnly_Id (name d)++")" |d<-rds]
-             (_,1,Dutch)   -> [Str "Daarnaast gebruiken we definitie ",RawInline (Text.Pandoc.Builder.Format "latex") $ symDefRef (head rds), Space, Str "(", Str (name (head rds)), Str ")"]
-             (_,1,English) -> [Str "Beside that, we use definition ",RawInline (Text.Pandoc.Builder.Format "latex") $ symDefRef (head rds), Space, Str "(", Str (name (head rds)), Str ")"]
-             (_,_,Dutch)   -> Str "Ook gebruiken we definities ":commaNLPandoc (Str "en") [RawInline (Text.Pandoc.Builder.Format "latex") $ symDefRef d++" ("++texOnly_Id (name d)++")" |d<-rds]
-             (_,_,English) -> Str "We also use definitions ":commaEngPandoc (Str "and") [RawInline (Text.Pandoc.Builder.Format "latex") $ symDefRef d++" ("++texOnly_Id (name d)++")" |d<-rds]
-           )++
-           (case (length nds,fsLang fSpec) of
-             (1,Dutch)   -> [Str " om eis",RawInline (Text.Pandoc.Builder.Format "latex") "~",RawInline (Text.Pandoc.Builder.Format "latex") $ symReqRef r, Str " (pg.",RawInline (Text.Pandoc.Builder.Format "latex") "~",RawInline (Text.Pandoc.Builder.Format "latex") $ symReqPageRef r, Str ") te formaliseren:"]
-             (1,English) -> [Str " to formalize requirement",RawInline (Text.Pandoc.Builder.Format "latex") "~",RawInline (Text.Pandoc.Builder.Format "latex") $ symReqRef r, Str " (page",RawInline (Text.Pandoc.Builder.Format "latex") "~",RawInline (Text.Pandoc.Builder.Format "latex") $ symReqPageRef r, Str "):"]
-             _           -> [Str ". "]
-           )
-        text3
-         = case (fsLang fSpec,isSignal r) of
-            (Dutch  ,False) -> [Str "De regel luidt: "]
-            (English,False) -> [Str "This means: "]
-            (Dutch  ,True)  -> [Str "Activiteiten, die door deze regel zijn gedefinieerd, zijn afgerond zodra: "]
-            (English,True)  -> [Str "Activities that are defined by this rule are finished when: "]
---        text4
---         = case fsLang fSpec of
---                 Dutch   -> [Str " Deze activiteiten worden opgestart door:"]
---                 English -> [Str " These activities are signalled by:"]
-        text5
-         = case (fsLang fSpec,isSignal r) of
-             (Dutch  ,False) -> [ Plain [ Str "Dit komt overeen met de afspraak op pg.",RawInline (Text.Pandoc.Builder.Format "latex") "~",RawInline (Text.Pandoc.Builder.Format "latex") $ symReqPageRef r, Str ":"]]++meaning2Blocks (fsLang fSpec) r
-             (English,False) -> [ Plain [ Str "This corresponds to the requirement on page",RawInline (Text.Pandoc.Builder.Format "latex") "~",RawInline (Text.Pandoc.Builder.Format "latex") $ symReqPageRef r, Str ":"]]++meaning2Blocks (fsLang fSpec) r
-             (Dutch  ,True)  -> [ Plain [ Str "Dit komt overeen met "
-                                        , Quoted  SingleQuote [Str (name r)]
-                                        , Str " (",RawInline (Text.Pandoc.Builder.Format "latex") $ symReqRef r, Str " op pg.",RawInline (Text.Pandoc.Builder.Format "latex") "~",RawInline (Text.Pandoc.Builder.Format "latex") $ symReqPageRef r, Str ")."]]
-             (English,True)  -> [ Plain [ Str "This corresponds to "
-                                        , Quoted  SingleQuote [Str (name r)]
-                                        , Str " (",RawInline (Text.Pandoc.Builder.Format "latex") $ symReqRef r, Str " op pg.",RawInline (Text.Pandoc.Builder.Format "latex") "~",RawInline (Text.Pandoc.Builder.Format "latex") $ symReqPageRef r, Str ")."]]
-        ncs = concs r >- seenConcs            -- newly seen concepts
-        cds = [(c,cd) | c<-ncs, cd<-cDefsInScope fSpec, cdcpt cd==name c]    -- ... and their definitions
-        ds  = relsUsedIn r
-        nds = [d | d@Sgn{}<-ds >- seenDeclarations]     -- newly seen relations
-        rds = [d | d@Sgn{}<-ds `isc` seenDeclarations]  -- previously seen relations
-        ( dpNext, n', seenCs,  seenDs ) = dpR rs (n+length cds+length nds+1) (ncs++seenConcs) (nds++seenDeclarations)
-
-relsInThemes :: Fspc -> [Declaration]
-relsInThemes fSpec
-        -- a relation is considered relevant iff it is declared or mentioned in one of the relevant themes.
- = [d | d<-relsDefdIn fSpec
-   , decusr d
-   , (  decpat d `elem` themes fSpec  
-         || d `elem` relsMentionedIn [p | p<-            patterns fSpec   , name p `elem` themes fSpec]
-         || d `elem` relsMentionedIn [p | p<-map fpProc (vprocesses fSpec), name p `elem` themes fSpec]
-     )
-   ]
-
-data Counter = Counter { --getConc :: Int
-                    --     getDecl :: Int
-                    --   , getRule :: Int
-                        getEisnr:: Int
-                       }
-newCounter :: Counter
-newCounter = Counter 1
-incEis :: Counter -> Counter
---incConc x = x{getConc = getConc x + 1}
---incDecl x = x{getDecl = getDecl x + 1}
---incRule x = x{getRule = getRule x + 1}
-incEis x = x{getEisnr = getEisnr x + 1}
-
-purposes2Blocks :: Options -> [Purpose] -> Blocks
-purposes2Blocks flags ps
- = fromList $
-     case ps of
-      [] -> []
-            -- by putting the ref after the first inline of the definition, it aligns nicely with the definition
-      _  -> case concatMarkup [expl{amPandoc = insertAfterFirstInline (ref purp) $ amPandoc expl} | purp<-ps, let expl=explMarkup purp] of
-             Nothing -> []
-             Just p  -> amPandoc p
-       where   -- The reference information, if available for this purpose, is put
-        ref purp = case fspecFormat flags of
-                    FLatex | (not.null.explRefIds) purp-> [RawInline (Text.Pandoc.Builder.Format "latex") 
-                                                             ("\\marge{"++intercalate "; " (map latexEscShw (explRefIds purp))++"}\n")]
-                    _                                  -> []
-concatMarkup :: [A_Markup] -> Maybe A_Markup
-concatMarkup es
- = case eqCl f es of
-    []   -> Nothing
-    [cl] -> Just A_Markup { amLang   = amLang (head cl)
-                          , amFormat = amFormat (head cl)
-                          , amPandoc = concatMap amPandoc es
-                          }
-    cls  -> fatal 136 ("don't call concatMarkup with different languages and formats\n   "++
-                      intercalate "\n   " [(show.f.head) cl | cl<-cls])
-   where f e = (amLang e, amFormat e)
-
-
--- Insert an inline after the first inline in the list of blocks, if possible. 
-insertAfterFirstInline :: [Inline] -> [Block] -> [Block]
-insertAfterFirstInline inlines (            Plain (inl:inls):pblocks)        =             Plain (inl : (inlines++inls)) : pblocks
-insertAfterFirstInline inlines (            Para (inl:inls):pblocks)         =             Para (inl : (inlines++inls)) : pblocks
-insertAfterFirstInline inlines (BlockQuote (Para (inl:inls):pblocks):blocks) = BlockQuote (Para (inl : (inlines++inls)) : pblocks):blocks
-insertAfterFirstInline inlines blocks                                        = Plain inlines : blocks
-
-isMissing :: Maybe Purpose -> Bool
-isMissing mp =
-  case mp of 
-    Nothing -> True
-    Just p  -> (not . explUserdefd) p
-
-lclForLang :: Lang -> TimeLocale
-lclForLang lang = defaultTimeLocale { months =
-         case lang of
-           Dutch   -> [ ("januari","jan"),("februari","feb"),("maart","mrt"),("april","apr")
-                      , ("mei","mei"),("juni","jun"),("juli","jul"),("augustus","aug")
-                      , ("september","sep"),("oktober","okt"),("november","nov"),("december","dec")]
-           English -> [ ("January","Jan"),("February","Feb"),("March","Mar"),("April","Apr")
-                      , ("May","May"),("June","Jun"),("July","Jul"),("August","Aug")
-                      , ("September","Sep"),("October","Oct"),("November","Nov"),("December","Dec")]
-           }
-
-
-inlineIntercalate :: Inlines -> [Inlines] -> Inlines
-inlineIntercalate _  [] = mempty
-inlineIntercalate _ [x] = x
-inlineIntercalate sep (x:xs) = x <> sep <> inlineIntercalate sep xs
-
--- Temporary fixes of Pandoc builder. ---  
-bulletList :: [Blocks] -> Blocks
-bulletList [] = mempty
-bulletList xs = BuggyBuilder.bulletList xs
-
-math :: String -> Inlines
-math s = BuggyBuilder.math ("{"++s++"}")