packages feed

ampersand 3.0.3 → 3.1.0

raw patch · 140 files changed

+8631/−9600 lines, 140 filesdep +MissingHdep +QuickCheckdep +conduitdep −HDBCdep −HDBC-odbcdep −uulibdep ~basedep ~filepathdep ~pandocsetup-changed

Dependencies added: MissingH, QuickCheck, conduit, lens, parsec, transformers, wl-pprint, xlsx, zlib

Dependencies removed: HDBC, HDBC-odbc, uulib

Dependency ranges changed: base, filepath, pandoc, pandoc-types, simple-sql-parser, text, utf8-string

Files

− AmpersandData/Examples/Delivery/Delivery.adl 
@@ -1,277 +0,0 @@-CONTEXT Delivery IN ENGLISH -- DATE: zo 24-04-2011  13:14:37,34
--- (file:  Delivery.pat ) -- 
-PATTERN Deliveries
-
- from :: Order * Client [UNI] PRAGMA "" " was ordered by "
-  = [ ("C45666"                  , "Applegate")
-    ; ("Order 22/09/2006 Cookies", "Brown"    )
-    ; ("C45683"                  , "Conway"   )
-    ].
-
- item :: Order * Product PRAGMA "" " mentions " " as an order item".
- PURPOSE RELATION item[Order*Product]
- {+An order becomes useful only if it mentions products to be ordered.
- Each order item corresponds to a line on the order form.
- For the sake of simplicity, we have left out quantity, product codes, etcetera. 
- -}
- item :: Delivery * Product PRAGMA "" " has " " as an order item"
-  = [ ("Jelly beans #4921"  , "Jelly beans"  )
-    ; ("Cookies #0382"      , "Cookies"      )
-    ; ("Peanut butter #1993", "Peanut butter")
-    ].
- PURPOSE RELATION item[Delivery*Product]
- {+A delivery becomes useful only if there are items to be delivered.
- Each delivery item corresponds to a line on the delivery form.
- For the sake of simplicity, we have left out quantity, product codes, etcetera. 
- -}
-
- PURPOSE RELATION of
- {+Each delivery must correspond to one particular order.
- This is registered in relation `of`.
- -}
- of :: Delivery -> Order PRAGMA "" " corresponds to "
-  = [ ("Cookies #0382"      , "Order 22/09/2006 Cookies")
-    ; ("Jelly beans #4921"  , "C45666"                  )
-    ; ("Peanut butter #1993", "C45683"                  )
-    ].
-
-RULE "correct delivery":
-  item[Delivery*Product] |- of;item
-  PHRASE IN ENGLISH "Each item in a delivery is mentioned on the order."
-PURPOSE RULE "correct delivery" IN ENGLISH
-{+We want orders to be delivered correctly, with only items that are mentioned on the order.
--}
-
-RULE "complete delivery": of;item |- item[Delivery*Product]
-PHRASE IN ENGLISH "Every item on an order must also be in the corresponding delivery."
-PURPOSE RULE "complete delivery" IN ENGLISH
-{+We want orders to be delivered completely, with no items missing.
--}
-
- provided :: Provider * Delivery [SUR,INJ] PRAGMA "" " has delivered "
-  = [ ("Candy's candy", "Cookies #0382")
-    ; ("Carter"       , "Jelly beans #4921")
-    ; ("Carter"       , "Peanut butter #1993")
-    ].
-
- accepted :: Provider * Order [INJ] PRAGMA "" "has accepted"
-  = [ ("Candy's candy", "Order 22/09/2006 Cookies")
-    ; ("Carter"       , "C45666"                  )
-    ; ("Carter"       , "C45683"                  )
-    ].
- rejected :: Provider * Order [INJ] PRAGMA "" "has rejected"
-  = [ ("Candy's candy", "Order 22/09/2006 Cookies")
-    ; ("Carter"       , "C45666"                  )
-    ; ("Carter"       , "C45683"                  )
-    ].
-
---RULE "accept or reject": -(accepted /\ rejected)
--- PHRASE IN ENGLISH "An order cannot be accepted and rejected at the same time."
-
- addressedTo :: Order -> Provider PRAGMA "" " was issued to "
-  = [ ("Order 22/09/2006 Cookies", "Candy's candy")
-    ; ("C45666"                  , "Carter"       )
-    ; ("C45683"                  , "Carter"       )
-    ].
-
- RULE "proper address": (accepted\/rejected) |- addressedTo~ -- \ref{rule 0} % uit het artikel
- PHRASE IN ENGLISH "A provider can only accept or reject orders that are addressed to that provider."
-PURPOSE RULE "proper address" IN ENGLISH
-{+Accepting an order is always done by the provider to whom the order was addressed.
-To prevent an order to be accepted or rejected by anyone else, we need this requirement.
--}
-
- deliveredTo :: Delivery -> Client PRAGMA "" " is delivered to "
-  = [ ("Jelly beans #4921", "Applegate")
-    ; ("Cookies #0382", "Brown")
-    ; ("Peanut butter #1993", "Conway")
-    ].
-
-RULE "order based delivery":    provided  |- accepted;of~
-PHRASE IN ENGLISH "For every delivery a provider has made, there exists an accepted order."
-PURPOSE RULE "order based delivery" IN ENGLISH
-{+In this context, providers only deliver when there is an order.
-So, if a delivery is made by a provider, we assume the existence of an order that is accepted by that provider.
--}
-
- sentTo :: Invoice -> Client PRAGMA "" " was sent to "
-  = [ ("5362a", "Applegate")
-    ; ("721i" , "Brown"    )
-    ; ("9443a", "Conway"   )
-    ].
-
- delivery :: Invoice -> Delivery PRAGMA "" " covers "
-  = [ ("5362a", "Jelly beans #4921")
-    ; ("721i" , "Cookies #0382"    )
-    ; ("9443a", "Peanut butter #1993"   )
-    ].
-
- from :: Invoice -> Provider PRAGMA "" " has been sent by "
-  = [ ("721i" , "Candy's candy")
-    ; ("5362a", "Carter"       )
-    ; ("9443a", "Carter"       )
-    ].
-
- paid :: Client * Invoice [INJ] PRAGMA "" " has paid "
-  = [ ("Applegate", "5362a")
-    ; ("Brown", "721i")
-    ; ("Conway", "9443a")
-    ].
- RULE "correct payments": paid |- sentTo~ PHRASE IN ENGLISH "Payments are made only for invoices sent."
-PURPOSE RULE "correct payments" IN ENGLISH
-{+To prevent arbitrary payments, we enforce that every invoice is paid by the client to whom it was sent.
--}
- RULE "correct invoices": sentTo |- delivery;of;from
- PHRASE IN ENGLISH "Invoices are sent to a customer only if there is a delivery made to that customer."
-PURPOSE RULE "correct invoices" IN ENGLISH
-{+To make sure that deliveries are billed to the right customer,
- there must be a delivery for each invoice sent.
--}
- 
-ENDPATTERN
---[Sessions]----------------------------------------------
-PATTERN Sessions
-
- sProvider :: Session * Provider [UNI] PRAGMA "" " is being run by ".
- sClient   :: Session * Client   [UNI] PRAGMA "" " is being run by ".
-
-ENDPATTERN
---[Delivery Process]--------------------------------------
-PROCESS Delivery
-
-RULE "login": I[Session] |- (sProvider;V/\-sClient;V) \/ (sClient;V\/-sProvider;V)
-PHRASE "Every session is being run by either a Provider or a Client"
-ROLE Client MAINTAINS "login"
-ROLE Client EDITS  sClient[Session*Client]
-ROLE Provider MAINTAINS "login"
-ROLE Provider EDITS sProvider[Session*Provider]
-
-RULE "create orders": I[Order] |- from; from~
-PHRASE IN ENGLISH "Each order is created by precisely one client."
-PURPOSE RULE "create orders" IN ENGLISH
-{+Orders should be deliverable and payable. For such purposes, it is necessary to know the client (customer) that created the order-}
-ROLE Client MAINTAINS "create orders"
-ROLE Client EDITS  from[Order*Client], item[Order*Product]
-
-RULE "accept orders": addressedTo~ |- accepted\/rejected
-PHRASE IN ENGLISH "Orders addressed to a provider must be accepted or rejected by that provider."
-PURPOSE RULE "accept orders" IN ENGLISH
-{+Not every order received by a provider leads to a delivery.
-The provider may decide to accept or to reject an order.
-Eventually, all orders must be acknowledged, either positively (accept) or negatively (reject).
--}
-PURPOSE RULE "accept orders" IN DUTCH
-{+Orders worden verstrekt door klanten om een verkooptransactie te starten.
-Op enig moment moet een leverancier deze order accepteren of afwijzen.
-In het huidige (simplistische) model wordt elke order uiteindelijk geaccepteerd.
-In een meer realistisch model moet tenminste worden gegarandeerd dat orders niet verloren gaan.
--}
-PURPOSE RULE "accept orders" IN ENGLISH
-{+Orders are issued by clients for the purpose of making a sales transaction.
-At some point in time, a provider must accept or reject the order.
-In this simplistic model, every order will be accepted.
-A more realistic model should at least ensure that orders will not be lost.
--}
-ROLE Provider MAINTAINS "accept orders"
-ROLE Provider EDITS accepted,rejected
-
-RULE "ship orders": accepted |- provided;of
-PHRASE IN ENGLISH "Each order that has been accepted by a provider must (eventually) be shipped by that provider."
-PURPOSE RULE "ship orders" IN ENGLISH
-{+Ultimately, each order accepted must be shipped by the provider who has accepted that order.
-The provider will be signalled of orders waiting to be shipped.
--}
-ROLE Provider MAINTAINS "ship orders"
-ROLE Provider EDITS item[Delivery*Product]
-
-RULE "pay invoices": sentTo~ |- paid
-PHRASE IN ENGLISH "All invoices sent to a customer must be paid by that customer."
-PURPOSE RULE "pay invoices" IN ENGLISH
-{+A client who receives an invoice must eventually pay.
--}
-ROLE Client MAINTAINS "pay invoices"
-ROLE Client EDITS paid
-
-RULE "receive goods": of;from |- deliveredTo
-PHRASE IN ENGLISH "Every delivery must be acknowledged by the client who placed the corresponding order."
-PURPOSE RULE "receive goods" IN ENGLISH
-{+The ordered goods must be delivered at some point in time to the client.
-This is done in one delivery.
--}
-ROLE Client MAINTAINS "receive goods"
-ROLE Client EDITS deliveredTo
-
-RULE "send invoices": delivery;of;from |- sentTo
-PHRASE IN ENGLISH "After a delivery has been made to a customer, an invoice must be sent."
-PURPOSE RULE "send invoices" IN ENGLISH
- {+In order to induce payment, a provider sends an invoice for deliveries made.
--}
-ROLE Provider MAINTAINS "send invoices"
-ROLE Provider EDITS item[Delivery*Product]
-
-ENDPROCESS
---[Services]----------------------------------------------
-SERVICE Login(sClient,sProvider) : I /\ -(sClient;sClient~ \/ sProvider;sProvider~)
- = [ "Login as Provider"  : sProvider[Session*Provider]
-   , "or login as Client" : sClient[Session*Client]
-   ]
-
---!t.b.v.  RULE "order creation": I[Order] |- from; from~
-SERVICE Orders(from[Order*Client],addressedTo,item[Order*Product]) : (I /\ sClient;sClient~);V;(I[Order] /\ -(from[Order*Client];from[Order*Client]~))
- = [ "Client"          : from[Order*Client]
-   , "Provider"        : addressedTo[Order*Provider]
-   , "Items"           : item[Order*Product]
-   ]
-
---!t.b.v.  RULE "accept orders": addressedTo~ |- accepted\/rejected   (door Provider)
-SERVICE Orders(accepted,rejected) : sProvider;addressedTo~;(I[Order] /\ -(accepted~ \/ rejected~);V)
- = [ "Client"          : from[Order*Client]
-   , "Items"           : item[Order*Product]
-   , "Accepted by"     : accepted[Provider*Order]~
-   , "Rejected by"     : rejected[Provider*Order]~
-   ]
-
---!t.b.v.  RULE "ship orders": accepted |- provided;of   (door Provider)
-SERVICE Deliveries(of[Delivery*Order]) : sProvider;accepted[Provider*Order];(I /\ -of[Delivery*Order]~;V)
- = [ "Delivery"      : of[Delivery*Order]~
-   , "Client"        : from[Order*Client]
-   , "Items"         : item[Order*Product]
-   ]
-
---!t.b.v.  RULE "send invoices": delivery;of;from |- sentTo
-SERVICE SendInvoice(sentTo[Invoice*Client],delivery[Invoice*Delivery],from[Invoice*Provider]) : sProvider;accepted[Provider*Order];of[Delivery*Order]~;(I[Delivery] /\ -(delivery~;(I[Invoice]/\sentTo;sentTo~ /\from[Invoice*Provider];from[Invoice*Provider]~));delivery)
- = [ "invoice"  : delivery[Invoice*Delivery]~
-   = [ "Sent to" : sentTo[Invoice*Client]
-     , "Sent by" : from[Invoice*Provider]
-   ] ]
-
---!t.b.v.  RULE "pay invoices": sentTo~ |- paid
-SERVICE PayInvoice(paid[Client*Invoice]) : sClient;(from[Order*Client]~;of[Delivery*Order]~;delivery[Invoice*Delivery]~/\-paid[Client*Invoice])
- = [ "Delivery"      : delivery[Invoice*Delivery]
-   = [ "Order"       : of[Delivery*Order]
-     = [ "Items"       : item[Order*Product]
-     ] ]
-   , "paid by"       : paid[Client*Invoice]~
-   ]
-
---!t.b.v.  RULE "receive goods": of[Delivery*Order];from[Order*Client] |- deliveredTo[Delivery*Client]
-SERVICE SignDeliveryReceipt(deliveredTo) : I[Delivery]
- = [ "Order"         : of[Delivery*Order]
-   = [ "Client"        : from[Order*Client]
-     , "Items"         : item[Order*Product]
-     ]
-   , "Delivered items" : item[Delivery*Product]
-   ]
-
--- deliveredTo :: Delivery -> Client PRAGMA "" " is delivered to "
-
---[Miscellaneous Populations]------------------------------
-
-POPULATION item[Order*Product] CONTAINS
-    [ ("C45666"                  , "Jelly beans"  )
-    ; ("Order 22/09/2006 Cookies", "Cookies"      )
-    ; ("C45683"                  , "Peanut butter")
-    ]
-
-{-===================================================================-}
-ENDCONTEXT
− AmpersandData/FormalAmpersand/AST.adl 
@@ -1,256 +0,0 @@-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"
-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." 
-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 Patterns
-CONCEPT Pattern "A pattern is a container for relation declarations and rule definitions"
-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.
-
---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 Specialization
-VIEW Gen: Gen( TXT "CLASSIFY ", genspc;name , TXT " ISA " , gengen;name )
-RULE "eq gen": gengen;gengen~ /\ genspc;genspc~ |- I
-MEANING "Two generalization rules are identical when the specific concepts are identical and the generic concepts are identical."
-
-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."
-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
-
-
-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"
-
---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 "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~;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 "]" )
-
-
-RELATION src[Sign*Concept] [UNI,TOT]
-MEANING "The source of a sign."
-RELATION trg[Sign*Concept] [UNI,TOT]
-MEANING "The target of a sign."
-
---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."
-
-
---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.
-
-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
---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"
-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."
-
---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  |- 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 |- 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
---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??
-
-RELATION exprvalue[ExpressionID*Expression] --[UNI,TOT]
-MEANING "The value of an expression."
-RELATION relsMentionedIn[ExpressionID*Declaration]
-MEANING "The user-declared relations in an expression."
-
--- 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
-
-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
-
-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]
-
--- 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 
@@ -1,91 +0,0 @@-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 
@@ -1,222 +0,0 @@-CONTEXT RAP IN ENGLISH LATEX
-{- This file contains the documentation of RAP in LaTeX format.
-   Each concept of the RAP metamodel has its own section, where sections are separated by comments -}
-
--- Context
-PURPOSE PATTERN Context
-{+The rules that govern contexts are brought together in one pattern,
-in order to formalize contexts and determine their meaning.
--}
-CONCEPT Context "A context is a set of statements in a formal language that are true within that context."
-PURPOSE CONCEPT Context
-{+
-Contexts exist in Ampersand for the purpose of dealing with truth.
-Within one context there can be no contradictions.
-Ampersand's way of dealing with a contradiction is either to resolve it or to separate them in different contexts.
-\subsubsection*{Explanation}
-The world is full of contradictions. Examples:
-\begin{itemize}
-\item   Bob's personal income over March 2013 according to Bob's employer differs from Bob's personal income over March 2013 according to the National Tax Authority.
-\item   The police can be convinced that Peter X commited the crime, yet his attorney is convinced he is innocent.
-\item   One computer system can tell that the person with social security number 721-07-4426 was born on April 27th, 1943, while at the same time another computer system tells me this person was born on May 3rd, 1952.
-\end{itemize}
-
-\begin{itemize}
-In language philosopy, the idea of a context was invented to give truth a place.
-\item   In the context of the National Tax Authority, Bob's personal income over March 2013 can be computed to precisely one amount. In the context of his employment, Bob's personal income over March 2013 can be different, because that is another context.
-\item   The job of a court of law is to create a new truth, whose consequences (e.g. imprisonement) can be enforced by law. The court creates a new context, in which conflicts between the (different) truths of both parties are resolved by a decision of the court.
-\item   If two computers operate in the same context, yet disagree on matters of fact, we say there is an error. It is likely that in this example someone must step in to determine which date of birth is correct (if any). The error could be detected because we know (i.e. we have a rule that says) that a person must have a unique date of birth.
-\end{itemize}
-
-Ampersand uses contexts to organize truth.
-Within one context, there is a single truth and there are no contradictions.
-For this reason, a context defines a language by means of concepts and relations, in which utterances can be made.
-We say that these utterances {\emph make sense} in that context.
--}
-
-PURPOSE PATTERN Rules
-{+The rules that govern rules are brought together in one pattern,
-in order to formalize rules and determine their meaning.
--}
-CONCEPT Rule "A rule is a statement that must be true in each context in which it is valid."
-PURPOSE CONCEPT Rule
-{+
-Rules are used as a concrete reason for people to act, feel or believe.
-In philosophy, this is called a 'norm'.
-\subsubsection*{Explanation}
-A rule differs from a statement in that it must always be true.
-Example:
-\begin{itemize}
-\item   The statement "St. Paul street is a one way street." might be either true or false.
-        We just have to check the road signs on St. Paul street to know.
-        If, however, the city council decides that St. Paul street is a one way street, we have a rule.
-        It is a rule because St. Paul street must be a one way street.
-        As long as the appropriate road signs are absent, the situation on the street contradicts the decision of the city council.
-\end{itemize}
-The word 'must' implies that there is someone who says so.
-In this example, the city council, by the authority invested upon it by the law, says that St. Paul street must be a one way street.
-The people who are affected by this are called stakeholders.
-All contexts in which this rule is valid are called the scope of this rule.
-Outside its scope, a rule has no meaning.
-For example a rule may be valid in downtown St. Catharines, Ontario, but totally meaningless in Smalltown, NY that does not even have a St. Paul street.
--}
-
-PURPOSE PATTERN Patterns
-{+The rules that govern patterns are brought together in one pattern,
-in order to formalize patterns and determine their meaning.
--}
-CONCEPT Pattern "A pattern is a set of rules that describes a theme or a general reusable solution to a commonly occurring problem."
-PURPOSE CONCEPT Pattern
-{+
-Patterns are used to isolate discussions about a specific theme to a particular group of stakeholders,
-who are competent to identify (define, select, invent, etc.) rules that define the theme.
-
-\subsubsection*{Explanation}
-A pattern formalizes the agreement among stakeholders on this particular theme.
-Design patterns are meant to make solutions reusable.
-On top of that, Ampersand advocates "one theme in one pattern".
-Stakeholders confine their discussion to one theme, and deliver the result in one pattern.
-A pattern is created when a group of stakeholders is trying to agree on a solution for a particular problem.
-The agreements they reach are written as rules, which are collected in a pattern.
-Therefore, they are independent from a particular context.
-\subsubsection*{Example}
-The problem of identifying which persons have been using an information system can be solved by making rules
-about log-in, users and sessions.
--}
-
--- Expression
-PATTERN Expressions
-PURPOSE PATTERN Expressions
-{+The rules that govern expressions are brought together in one pattern,
-in order to formalize expressions and determine their meaning.
--}
-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.
-An Ampersand professional uses expressions to calculate with language and to specify information systems and business processes.
-\subsubsection*{Explanation}
-An expression combines relations with operators.
-That results in new relations, the population of which can be calculated from the constituent parts.
-This is similar to arithmetic, where for instance the result of expression $(3+5)\times 2$ can be calculated from the constituent numbers.
-In ampersand, you calculate with relations rather than numbers.
-\subsubsection*{Example}
-The problem of identifying which persons have been using an information system can be solved by making rules
-about log-in, users and sessions.
--}
-ENDPATTERN
-
-PURPOSE PATTERN Specialization
-{+Let us briefly recall, by example, what specialization is all about.
-Citrus fruit comes in many colors: oranges are orange, lemons are yellow, limes are green, and grapefruits are red, yellow or a mixture of both.
-Based on such an observation, we might have a concept $\id{Citrus}$, with a property $\id{color}$.
-Since all limes are citrus fruits, we might have a concept $\id{Lime}$.
-Every instance of $\id{Lime}$ is a small green and very sour fruit. It is not just a $\id{Lime}$, but it is a $\id{Citrus}$ as well.
-This is called {\em specialization}.
-The reason we call \id{Lime} a specialization of \id{Citrus} is that every lime (i.e.\ each instance of \id{Lime}) has all the properties of a citrus
-and on top of that it has properties specific to limes.
-
-Specialization should be used on intrinsic properties only.
-Ask yourself: once a lime, always a lime? If the answer is yes (which sounds right to me), you can use specialization.
-Now ask yourself: once an employee, always an employee? The answer to this question is more likely to be no.
-Therefore, don't use specialization to say that an employee is a person.
--}
-
--- Concept
-PATTERN Concepts
-PURPOSE PATTERN Concepts
-{+The rules that govern concepts are brought together in one pattern,
-in order to formalize concepts and determine their meaning.
--}
---HJO, 20150420: In het documentatie bestand moet je eigenlijk geen definities opnemen. Die moeten elders --CONCEPT A_Concept "A concept is a name for a category of similar objects."
---HJO, 20150420: In het documentatie bestand moet je eigenlijk geen definities opnemen. Die moeten elders ----CONCEPT ConceptOne "ConceptOne, also known as ONE, is a predefined concept that has the role of universal singleton"
-PURPOSE CONCEPT PlainConcept
-{+
-In order to reason about meaning,
-Ampersand has borrowed the idea of a "concept" from the field of semantics
-(a part of the philosophy of language).
-\subsubsection*{Example}
-For example, the city of Amsterdam is an instance of the concept ``City''.
-\subsubsection*{Explanation}
-Concepts, such as City, Person, Document, Installment, and so on,
-allow a designer to talk about things without having them.
-We can discuss cities and persons that live in them
-without referring to the actual instances of those concepts.
-The distinction between an object (Amsterdam) and the corresponding concept (City)
-has been studied for a long time [e.g.\ Frege, 1892] and is highly relevant for Ampersand.
--}
-ENDPATTERN
-
-PATTERN Populations
-PURPOSE PATTERN Populations
-{+The rules that govern atoms, pairs, and populations are brought together in one pattern,
-in order to formalize them and determine their meaning.
--}
-
-CONCEPT Population "The contents of a Concept or Relation"
-PURPOSE CONCEPT Population
-{+
-Populations are a means to specify a number of true statements that are stored in a relation.
-If an information system is generated, the population specified in an Ampersand script
-is used as the initial data stored in the database.
-This data can subsequently be changed by performing transactions on that database.
-\subsubsection*{Example}
-\begin{verbatim}
-  POPULATION address[Person,Address] CONTAINS
-  { ("Peter", "148 Browning Street")
-  ; ("Susan", "Dorpsstraat 78")
-  ; ("Bart",  "2013 McGinnigall Drive")
-  }
-\end{verbatim}
-\subsubsection*{Explanation}
-Populations provide the initial content of a database. 
-
-The word {\emph population} is used sloppily for contexts as well.
-It refers the the total of all populations in relations and concepts inside that context.
--}
-
-CONCEPT RelPopu "The content of a relation"
-CONCEPT CptPopu "The content of a concept"
-CONCEPT 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"
-CONCEPT String "A string is a pString expected to be less than 256 characters."
---HJO20150420: Uitgezet: CONCEPT Conid "A conid is an identifier starting with an uppercase"
---HJO20150420: Uitgezet: CONCEPT Varid "A varid is an identifier starting with a lowercase"
---HJO20150420: Uitgezet: CONCEPT ADLid "An ADLid is an identifier of type pVarid <|> pConid <|> pString"
-CONCEPT Gen "A gen, or generalization rule, is the is-a-relation between a more specific and a more generic concept."
-CONCEPT Sign "A sign is a relation type signature consisting of a source concept and a target concept."
-CONCEPT PropertyRule "A property rule is a rule, that is a property of a user-declared relation"
-CONCEPT Property "UNI<|>TOT<|>INJ<|>SUR<|>RFX<|>IRF<|>SYM<|>ASY<|>TRN<|>PROP"
-CONCEPT 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 
@@ -1,147 +0,0 @@-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 
@@ -1,10 +0,0 @@-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. 
--}
-
-ENDCONTEXT
− AmpersandData/FormalAmpersand/Generics.adl 
@@ -1,245 +0,0 @@-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 
@@ -1,104 +0,0 @@-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 
@@ -1,15 +0,0 @@-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 
@@ -1,33 +0,0 @@-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 
@@ -1,210 +0,0 @@-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 
@@ -1,182 +0,0 @@-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"
-INCLUDE "admin_interfaces.adl"
-INCLUDE "Fspec.adl"
---IN ENGLISH
---LATEX
-
-PROCESS AtlasLoad
-ROLE Student MAINTAINS parseerror,typeerror,popchanged
---TODO -> BUG1 => only  inios = cptos does not imply  inios |- cptos, thus removal of concept population is not detected by conceptwijzigingen.
--- workaround = two rules
---TODO -> BUG2 => removal of cptos results in KEY AtomID => <KEY relation not total>
---RULE "conceptwijzigingen": inios = cptos
---MESSAGE "U heeft wijzigingen gemaakt in de populatie van concepten, die nog niet effectief en persistent opgeslagen zijn. Mogelijk heeft u overtredingen verholpen of veroorzaakt. U kunt deze atlasbewerkingen effectueren en persistent maken door ze op te slaan in een volgende versie van het bronbestand."
---RULE "conceptwijzigingen1": inios |- cptos
---MESSAGE "U heeft atomen verwijderd uit de populatie van concepten, hetgeen nog niet effectief en persistent opgeslagen is. Mogelijk heeft u overtredingen verholpen of veroorzaakt. U kunt deze atlasbewerkingen effectueren en persistent maken door ze op te slaan in een volgende versie van het bronbestand."
---RULE "conceptwijzigingen2": cptos |- inios
---MESSAGE "U heeft atomen toegevoegd aan de populatie van concepten."
-
---RULE "popadd": (left;atomvalue)~;(decpopu~;decpopu /\ I);right;atomvalue |- inileft~;(inipopu~;inipopu /\ I);iniright
---RULE "popdel": inileft~;(inipopu~;inipopu /\ I);iniright |- (left;atomvalue)~;(decpopu~;decpopu /\ I);right;atomvalue
-RULE "popchanged": inipopu = decpopu
---RULE "popchanged": (-((left;atomvalue)~;(decpopu~;decpopu /\ I);right;atomvalue) \/ (inileft~;(inipopu~;inipopu /\ I);iniright)) /\ (-(inileft~;(inipopu~;inipopu /\ I);iniright) \/ ((left;atomvalue)~;(decpopu~;decpopu /\ I);right;atomvalue))
-MESSAGE "<br/>You entered change(s) on the screen. You can: <br/> 1) <b>enter more</b> change(s), or; <br/> 2) <b>undo</b> your changes <b>by (re)loading</b> any CONTEXT into Atlas, or;<br/> 3) <a href='index.php?interface=Validate&atom=1&role=0'>click here</a> to <b>commit</b> the change(s) <b>and update</b> violations on your rules."
-VIOLATION (TXT "added or deleted pair ",TGT I, TXT " of ", TGT (inipopu\/decpopu)~)
-
-
-RULE "parseerror": parseerror |- -parseerror
-MESSAGE "<span class='errsignal'>A syntax error was encountered in your script.</span> No CONTEXT screen could be generated."
-VIOLATION (TGT I, TXT " Open ", SRC I,TXT " to fix error.")
-
-RULE "typeerror": typeerror |- -typeerror
-MESSAGE "<span class='errsignal'>Type error(s) were encountered in your script.</span> A CONTEXT screen was generated with concepts and relation declarations only, which may be useful to understand and fix the errors"
-VIOLATION (TGT I, TXT ". Open ", SRC I,TXT " to fix error.")
-ENDPROCESS
-
-PROCESS Student
-ROLE Student MAINTAINS otherviolations, multviolations1,multviolations2,multviolations3, homoviolations
-
---RULE "conceptorphan": cptos |- src~;decsgn~;decpopu;left \/ trg~;decsgn~;decpopu;right
---MESSAGE "<br/><span class='warnsignal'>The atoms below are not related to any atom, besides the identity relation.</span> These atoms have no purpose to exist, except when the atom is used in a RULE assertion. An atom that has lost its purpose will not exist anymore in the next CONTEXT version if you <a href='index.php?interface=Validate&atom=1&role=0'>Validate</a> now."
---VIOLATION (TGT I)
-
---RULE "specgenduplicate": -(cptos;atomvalue /\ (genspc~;gengen \/ genspc~;gengen;genspc~;gengen \/ genspc~;gengen;genspc~;gengen;genspc~;gengen)~;cptos;atomvalue)
---MESSAGE "<span class='warnsignal'>Atom(s) of a concept that is a specialization have the same name(s) as atom(s) of a more general concept.</span> The integrity rules demand that no two atoms in the population of a concept have the same name. If you commit and validate on the <a href='index.php?interface=Validate&atom=1&role=0'>Validate-screen</a> then Ampersand records that the atoms with identical names refer to the same real-world object. If the atoms refer to different real-world objects, then you must change the name of at least one atom before validating."
---VIOLATION (TXT "Atom ", TGT I, TXT "will become the most specific concept")
-
-RULE "multviolations1": -((I[PropertyRule] /\ declaredthrough;('TOT' \/ 'SUR');declaredthrough~);rrviols)
-MESSAGE "<br/><br/><span class='violsignal'>A TOTal or SURjective multiplicity rule is violated for some relation(s).</span> Add tuple(s) in the relation(s) to correct the violation(s)."
-VIOLATION (TXT "RULE ", SRC I, TXT " is violated by the atom ", TGT left, TXT ".")
-
-RULE "multviolations2": -((I[PropertyRule] /\ declaredthrough;('UNI' \/ 'INJ');declaredthrough~);rrviols)
-MESSAGE "<br/><br/><span class='violsignal'>A UNIvalence or INJective multiplicity rule is violated for some relation(s).</span> Delete tuple(s) in the relation(s) to correct the violation(s)."
-VIOLATION (TXT "RULE ",SRC I, TXT " is violated by the tuple ", TGT I, TXT " in combination with some other tuple(s).")
-
-RULE "multviolations3": -((I[PropertyRule] /\ declaredthrough;'->';declaredthrough~);rrviols)
-MESSAGE "<br/><br/><span class='violsignal'>A UNIvalence or TOTal multiplicity rule is violated for some relation(s).</span> Delete tuple(s) in the relation(s) to correct the violation(s)."
-VIOLATION (TXT "RULE ",SRC I, TXT " is violated by the tuple ", TGT I, TXT " in combination with some other tuple(s).")
-
-RULE "homoviolations": -((I[PropertyRule] /\ declaredthrough;('RFX' \/ 'IRF' \/ 'SYM' \/ 'ASY' \/ 'TRN' \/ 'PROP');declaredthrough~);rrviols)
-MESSAGE "<br/><br/><span class='violsignal'>A rule for homogeneous relation(s) is violated.</span> Add or delete tuple(s) in the relation(s) to correct the violation(s)."
-VIOLATION (TXT "RULE ",SRC I, TXT " is violated by the tuple ", TGT I, TXT " in combination with some other tuple(s).")
-
-RULE "otherviolations": -((-I[PropertyRule] /\ I[Rule]);rrviols)
-MESSAGE "<br/><br/><span class='violsignal'>A business rule that involves several relations is violated.</span> Add or delete tuple(s) in one or more of the relation(s) to correct the violation(s)."
-VIOLATION (TXT "RULE ",SRC I[Rule], TXT " is violated by the violation ", TGT I, TXT " in combination with some other tuple(s).")
-ENDPROCESS
-
-PROCESS Admin
---no signals for admin yet
-RULE dummy: firstloadedwith |- firstloadedwith
-ROLE Admin MAINTAINS dummy
-ENDPROCESS
-
-
-PATTERN AtlasLoad
-firstloadedwith :: AdlFile * AdlVersion [UNI]
-MEANING IN ENGLISH "The version of the Ampersand compiler with which the rule specification file was loaded for the first time."
-inios::Concept*AtomID
-MEANING IN ENGLISH "The initial population of a concept from a rule specification file."
-inipopu::Declaration*PairID
-MEANING IN ENGLISH "The initial population of a relation from a rule specification file."
-inileft::PairID*Atom
-MEANING IN ENGLISH "The initial source of a relationship from the initial population of a relation from a rule specification file."
-iniright::PairID*Atom
-MEANING IN ENGLISH "The initial target of a relationship from the initial population of a relation from a rule specification file."
-CONCEPT ErrorMessage "An error message is a description of an error." TYPE "Blob"
-KEY ParseError: ParseError(TXT "Click here for error details.")
-parseerror   :: File * ParseError[UNI]
-MEANING IN ENGLISH "The parse error resulting from the parser of the Ampersand compiler when the rule specification file was loaded for the first time."
-pe_action    :: ParseError -> String
-MEANING IN ENGLISH "Possible actions which may resolve a parse error."
-pe_position  :: ParseError -> String
-MEANING IN ENGLISH "The position of a parse error."
-pe_expecting :: ParseError -> ErrorMessage
-MEANING IN ENGLISH "A message of what was expected by the parser."
-KEY TypeError: TypeError(TXT "Click here for details of error at ", te_position)
-typeerror   :: File * TypeError
-MEANING IN ENGLISH "The type error resulting from the type checker of the Ampersand compiler when the rule specification file was loaded for the first time."
-te_message  :: TypeError * ErrorMessage [UNI]
-MEANING IN ENGLISH "A complete description of a type error."
-te_parent   :: TypeError * TypeError [UNI]
-MEANING IN ENGLISH "The parent type error of a nested type error."
-te_position :: TypeError * String [UNI]
-MEANING IN ENGLISH "The position of a type error."
-te_origtype :: TypeError * String [UNI]
-MEANING IN ENGLISH "The type of element in which the type error has been detected."
-te_origname :: TypeError * String [UNI]
-MEANING IN ENGLISH "The name of the element in which the type error has been detected."
-ENDPATTERN
-
-PATTERN FileManagement
-filename :: File->FileName
-MEANING IN ENGLISH "The name of a file"
-filepath :: File*FilePath[UNI]
-MEANING IN ENGLISH "The path of a file"
-KEY File: File(PRIMHTML "<a href='../../index.php?file=", filepath, filename,PRIMHTML "&userrole=", uploaded~;userrole, PRIMHTML "'>", filename, PRIMHTML "</a>")
-RULE "unique file location": filename;filename~ /\ filepath;filepath~ |- I
-MEANING IN ENGLISH "Each file has its own location on the file system."
-
-filetime :: File*CalendarTime[UNI]
-MEANING IN ENGLISH "The last time a file has been updated. In RAP this is the creation date, because files may not be edited or overwritten."
-
-uploaded::User*File
-MEANING IN ENGLISH "The files in RAP uploaded by a student"
-userrole::User*Role [UNI]
-MEANING IN ENGLISH "The current role of a mainstream user."
-RULE "user roles": 'Student' \/ 'StudentDesigner' \/ 'Designer' |- I[Role]
-MEANING IN ENGLISH "There are three roles: Student, StudentDesigner and Designer"
-
-SPEC AdlFile ISA File
---KEY AdlFile: inherit from File
-sourcefile::Context->AdlFile
-MEANING IN ENGLISH "The rule specification file in which a context is defined."
-includes  ::Context*File
-MEANING IN ENGLISH "The files included by the main rule specification file of a context."
-
-applyto::G->AdlFile
-MEANING IN ENGLISH "The application of an Ampersand compiler function (G) to a rule specification file."
-functionname :: G->String
-MEANING IN ENGLISH "The description of the application of an Ampersand compiler function to a rule specification file."
-operation :: G->Int
-MEANING IN ENGLISH "The operation number of an Ampersand compiler function."
-KEY G: G(PRIMHTML "<a href='../../index.php?operation=",operation
-        ,PRIMHTML "&file=", applyto;filepath , applyto;filename
-        ,PRIMHTML "&userrole=", applyto;uploaded[User*AdlFile]~;userrole
-        ,PRIMHTML "'>", functionname, PRIMHTML "</a>")
-
-
-SPEC NewAdlFile ISA AdlFile
-KEY NewAdlFile: NewAdlFile(PRIMHTML "<a href='../../index.php'>",filename[NewAdlFile*FileName],PRIMHTML"</a>")
-newfile::User->NewAdlFile
-MEANING IN ENGLISH "The predefined rule specification file with an empty context, which is copied to create a new file requested by a student."
-
-SPEC SavePopFile ISA File
-KEY SavePopFile: SavePopFile(PRIMHTML "<a href='../../index.php?operation=4&file=", filepath[SavePopFile*FilePath] , filename[SavePopFile*FileName]
-                            ,PRIMHTML "'>", filename[SavePopFile*FileName] ,PRIMHTML "</a>")
-savepopulation::Context->SavePopFile
-MEANING IN ENGLISH "The file, which will be created to export the population of a context when requested by a student."
-
-SPEC SaveAdlFile ISA AdlFile
-KEY SaveAdlFile: SaveAdlFile(PRIMHTML "<a href='../../index.php?operation=2&file=", filepath[SaveAdlFile*FilePath] , filename[SaveAdlFile*FileName]
-                            ,PRIMHTML "&userrole=", savecontext~;sourcefile;uploaded[User*AdlFile]~;userrole
-                            ,PRIMHTML "'>", filename[SaveAdlFile*FileName], PRIMHTML "</a>")
-savecontext::Context->SaveAdlFile
-MEANING IN ENGLISH "The rule specification file, which will be created to commit and upload changes in the loaded context when requested by a student."
-ENDPATTERN
-
-PATTERN Metrics
-countrules :: Context*Int[UNI]
-MEANING IN ENGLISH "The number of user-defined rules in a context"
-countdecls :: Context*Int[UNI]
-MEANING IN ENGLISH "The number of user-declared relations in a context"
-countcpts  :: Context*Int[UNI]
-MEANING IN ENGLISH "The number of concepts in a context"
-ENDPATTERN
-
-ENDCONTEXT
-
-
− AmpersandData/FormalAmpersand/README.txt 
@@ -1,4 +0,0 @@-This directory contains a formal specification of Ampersand in Ampersand. 
-
-
-The RAP.adl file and its included files are used to generate a repository. In this initial version, they are exact copies of the files in the RAP branch.
− AmpersandData/FormalAmpersand/student_AST_interfaces.adl 
@@ -1,200 +0,0 @@-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
-    ,"concepts" : V[ONE*Context];ctxcs
-    ,"ISA-relations" : V[ONE*Context];ctxpats;ptgns 
-    ,"relations" : V[ONE*Context];ctxpats;ptdcs  BOX ["relation":I, "with properties": decprps;declaredthrough] 
-    ,"RULEs" : V[ONE*Context];ctxpats;ptrls;(I[Rule] /\ -I[PropertyRule])
-    ]
-INTERFACE "Validate" FOR Student: I[ONE]
-BOX ["Click to commit and validate":V[ONE*Context];savecontext
-    ]
---CSS refers to most names in this interface
-INTERFACE "CONTEXT files (Design / reload)" FOR Student: I[ONE]
-BOX ["loaded into Atlas" : V[ONE*Context] 
-    BOX ["CONTEXT":I,"source file (click to edit)":sourcefile \/ includes,"operations (click to perform)":sourcefile;applyto~]
-    ,"overview of files" : V[ONE*User]
-    BOX [ "open new source file" : newfile
-        , "source files" : uploaded[User*File];I[AdlFile] BOX ["file name (click to edit)":I[AdlFile],"created at":filetime,"operations (click to perform)":applyto~]
-        ]
-    ]
-
---css refers to this interface
-INTERFACE "Diagnosis" FOR Student: I[ONE]
-BOX [ "concepts without definition": V[ONE*Concept];(-(cptdf;cptdf~) /\ I) -- THIS IS A THIRD CHOICE expression!!
---SECOND CHOICE: V[ONE*Concept];-(cptdf;cptdf~) <= results in SQL with empty atoms => see test2 below in comments
---FIRST CHOICE: -(V[ONE*Blob];cptdf~) <= results in:fatal error 583 (module RelBinGenSQL, Prototype v2.2.0.2100M (lib: Ampersand v2.2.0.578:579M)) A_Concept ONE may not be represented in SQL
-    , "relations without MEANING": V[ONE*Declaration];(-(decmean;decmean~) /\ I) -- -(V[ONE*Blob];decmean~)
-    , "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;relsMentionedIn;reldcl)
-    ]
-
-INTERFACE "Syntax error" FOR Student: I[ParseError]
-BOX [ "expecting":pe_expecting
-    , "position" :pe_position
-    , "try"      :pe_action
-    ]
-INTERFACE "Type error" FOR Student: I[TypeError]
-BOX [ "error" : I
-    BOX [ "in" :te_origtype
-        , "at" :te_position
-        , "stating" :te_origname
-        ]
-    , "error message":te_message
-    , "declared relations": V[TypeError*Declaration]
-    ]
-
-{-
-PROCESS Test
-ROLE Student MAINTAINS test1
-,test2
-,test3
-,test4
---,test5
-RULE test1: -(cptdf;cptdf~)
-RULE test2: cptdf;cptdf~
-RULE test3: cptdf
-RULE test4: -(-(cptdf;cptdf~) /\ I)
-ENDPROCESS
--}
-{-
-CONTEXT Test
-PATTERN "Test"
-  SPEC "Medewerker" ISA "Persoon"
-  SPEC "Klant" ISA "Persoon"
-  helptzichzelf :: Medewerker * Klant
-  dummy :: A * B
-ENDPATTERN
-  CONCEPT "B" "een B" 
-POPULATION helptzichzelf[Medewerker*Klant] CONTAINS [ 'y' * 'x'   ]
-POPULATION dummy[A*B] CONTAINS [ 'x' * 'y'   , 'y' * 'x'   ]
-POPULATION Medewerker CONTAINS   [ 'y'   , 'x'   ]
-POPULATION Klant CONTAINS   [ 'x'   ]
-POPULATION A CONTAINS   [ 'x'   , 'y'   ]
-POPULATION B CONTAINS   [ 'y'   , 'x'   ]
-POPULATION Persoon CONTAINS   [ 'y'   , 'x'   ]
-ENDCONTEXT
-
-Signals for Student
-Rule 'test1' is broken:
-- B
-Rule 'test2' is broken:
--
-- ('Medewerker', '')
-- ('Klant', '')
-- ('A', '')
-- ('B', '')
-- ('Persoon', '')
-- ('', 'Medewerker')
-- Medewerker
-- ('Klant', 'Medewerker')
-- ('A', 'Medewerker')
-- ('B', 'Medewerker')
-- ('Persoon', 'Medewerker')
-- ('', 'Klant')
-- ('Medewerker', 'Klant')
-- Klant
-- ('A', 'Klant')
-- ('B', 'Klant')
-- ('Persoon', 'Klant')
-- ('', 'A')
-- ('Medewerker', 'A')
-- ('Klant', 'A')
-- A
-- ('B', 'A')
-- ('Persoon', 'A')
-- ('', 'B')
-- ('Medewerker', 'B')
-- ('Klant', 'B')
-- ('A', 'B')
-- ('Persoon', 'B')
-- ('', 'Persoon')
-- ('Medewerker', 'Persoon')
-- ('Klant', 'Persoon')
-- ('A', 'Persoon')
-- ('B', 'Persoon')
-- Persoon
-Rule 'test3' is broken:
-- ('', 'een B')
-- ('Medewerker', 'een B')
-- ('Klant', 'een B')
-- ('A', 'een B')
-- ('Persoon', 'een B')
-Rule 'test4' is broken:
-- Medewerker
-- Klant
-- A
-- Persoon
-
--}
-
---CSS refers to all names in this interface
-INTERFACE "Extra functions"(filename,userrole) FOR Student: I[ONE]
-BOX ["Export POPULATIONs to...":V[ONE*Context];savepopulation
-    BOX ["file (INCLUDE only)":I[SavePopFile],"type a file name":filename]
-    ,"User settings": V[ONE*User] BOX ["use role to load files":userrole]
-    , "files with only POPULATIONs" : V[ONE*User];uploaded;(I[File] /\ -I[AdlFile]) BOX ["file name":I[File],"created at":filetime]
-    ]
-
-INTERFACE "CONTEXT" FOR Student: I[Context]
-BOX ["name" : ctxnm 
-    ,"PATTERNs" : ctxpats
-    ,"concepts" : ctxcs 
-    ,"ISA-relations" : ctxpats;ptgns 
-    ,"relations" : ctxpats;ptdcs BOX ["relation":I, "with properties": decprps;declaredthrough]
-    ,"RULEs" : ctxpats;ptrls;(I[Rule] /\ -I[PropertyRule]) 
-    ]
-INTERFACE "PATTERN" FOR Student: I[Pattern]
-BOX ["PURPOSEs" :ptxps
-    ,"name" :ptnm
-    ,"RULEs" :ptrls;(I[Rule] /\ -I[PropertyRule])
-    ,"relations" :ptdcs  BOX ["relation":I, "with properties": decprps;declaredthrough]
-    ,"ISA-relations" :ptgns
-    ,"diagram" : ptpic
-    ]
-INTERFACE "ISA-relation" FOR Student: I[Gen]
-BOX ["SPEC" : genspc
-    ,"ISA" : gengen
-    ,"in PATTERN" : ptgns~
-    ]
-INTERFACE "Concept"(cptos,atomvalue) FOR Student: I[Concept]
-BOX ["PURPOSEs" :cptpurpose
-    ,"CONCEPT definition" :cptdf
-    ,"name" :cptnm
-    ,"POPULATION" :cptos BOX ["atom":atomvalue]
-    ,"POPULATION (through ISA)":(genspc~;gengen \/ genspc~;gengen;genspc~;gengen \/ genspc~;gengen;genspc~;gengen;genspc~;gengen)~ --TODO closure
-    BOX ["more specific concept":I[Concept], "POPULATION":cptos;atomvalue]
-    ,"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;relsMentionedIn)~;(I[Rule] /\ -I[PropertyRule])
-    ,"diagram" : cptpic
-    ]
-INTERFACE "Atom"(cptos) FOR Student: I[Atom];atomvalue~
-BOX ["in POPULATION of": cptos~]
-INTERFACE Relation(decpopu,left,right) FOR Student: I[Declaration]
-BOX ["PURPOSEs" :decpurpose
-    ,"MEANING" :decmean
-    ,"example of basic sentence" :decexample
-    ,"name" :decnm
-    ,"type" :decsgn BOX ["source":src , "target":trg]
-    ,"properties" :decprps;declaredthrough
-    ,"from PATTERN" :ptdcs~
-    ,"POPULATION" :decpopu BOX ["source":left , "target":right] --select existing atoms only!
-    ,"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;relsMentionedIn BOX ["relation":reldcl, "with properties": reldcl;decprps;declaredthrough, "source":relsgn;src, "target":relsgn;trg]
-    ,"in PATTERN":ptrls~
-    ,"diagram" : rrpic
-    ]
-ENDCONTEXT
-
-
Setup.hs view
@@ -9,21 +9,22 @@ 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 qualified Data.Time.Format as DTF
 import Data.Time.LocalTime
 import System.Directory
 import System.FilePath
 import System.IO
-import System.Locale
+import qualified System.Locale as SL
+import qualified Data.ByteString.Lazy.Char8 as BS
+import qualified Codec.Compression.GZip as GZip
 
 
 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.
+-- the current 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.
 
@@ -33,7 +34,7 @@ 
     ; gitInfoStr <- getGitInfoStr
     ; clockTime <- getCurrentTime >>= utcToLocalZonedTime 
-    ; let buildTimeStr = formatTime defaultTimeLocale "%d-%b-%y %H:%M:%S %Z" clockTime
+    ; let buildTimeStr = DTF.formatTime SL.defaultTimeLocale "%d-%b-%y %H:%M:%S %Z" clockTime
     ; writeFile (pathFromModuleName buildInfoModuleName) $
         buildInfoModule cabalVersionStr gitInfoStr buildTimeStr
     
@@ -144,38 +145,41 @@       --; 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"
+   do { putStrLn $ "\n\n\nWarning: Cannot read previously generated " ++ sfModulePath ++ ":\n" ++
+                   show (err :: SomeException) ++ "\nThis warning should disappear the next time you build Ampersand. If the error persists, please report this as a bug.\n"
       ; return []
       }
         
--- Scan static file directory and collect all files from oldFrontend and newFrontend
+-- Collect all files required to be inside the ampersand.exe 
 readAllStaticFiles :: IO String
 readAllStaticFiles = 
-  do { oldStaticFiles <- readStaticFiles False "static/oldFrontend" "."
-     ; newStaticFiles <- readStaticFiles True  "static/newFrontend" "."
-     ; return $ mkStaticFileModule $ oldStaticFiles ++ newStaticFiles
+  do { zwolleFrontEndFiles  <- readStaticFiles ZwolleFrontEnd   "static/zwolle" "."  -- files that define the Zwolle Frontend
+     ; pandocTemplatesFiles <- readStaticFiles PandocTemplates  "outputTemplates" "." -- templates for several PANDOC output types
+     ; formalAmpersandFiles <- readStaticFiles FormalAmpersand  "AmpersandData/FormalAmpersand" "."  --meta information about Ampersand
+     ; return $ mkStaticFileModule $ zwolleFrontEndFiles ++ pandocTemplatesFiles ++ formalAmpersandFiles
      }
   
-readStaticFiles :: Bool -> FilePath -> FilePath -> IO [String]
-readStaticFiles isNewFrontend base fileOrDirPth = 
+readStaticFiles :: FileKind -> FilePath -> FilePath -> IO [String]
+readStaticFiles fkind 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
+           ; fmap concat $ mapM (\fOrD -> readStaticFiles fkind 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)
+           ; return [ "SF "++show fkind++" "++show fileOrDirPth++" "++utcToEpochTime timeStamp ++
+                             " {-"++show timeStamp++" -} (BS.unpack$ GZip.decompress "++show (GZip.compress fileContents)++")"
                     ]
            }
      }
   where utcToEpochTime :: UTCTime -> String
-        utcToEpochTime utcTime = formatTime defaultTimeLocale "%s" utcTime
+        utcToEpochTime utcTime = DTF.formatTime SL.defaultTimeLocale "%s" utcTime
 
+data FileKind = ZwolleFrontEnd | PandocTemplates | FormalAmpersand deriving (Show, Eq)
+
 mkStaticFileModule :: [String] -> String
 mkStaticFileModule sfDeclStrs =
   unlines staticFileModuleHeader ++ 
@@ -184,20 +188,31 @@            
 staticFileModuleHeader :: [String]
 staticFileModuleHeader =
-  [ "module "++staticFileModuleName++" where"
+  [ "{-# LANGUAGE OverloadedStrings #-}"
+  , "module "++staticFileModuleName++" where"
+  , "import qualified Data.ByteString.Lazy.Char8 as BS"
+  , "import qualified Codec.Compression.GZip as GZip"
   , ""
-  , "data StaticFile = SF { isNewFrontend     :: Bool"
-  , "                     , filePath          :: FilePath -- relative path, including extension"
-  , "                     , timeStamp         :: Integer  -- unix epoch time"
-  , "                     , contentString     :: String"
+  , "data FileKind = ZwolleFrontEnd | PandocTemplates | FormalAmpersand deriving (Show, Eq)" 
+  , "data StaticFile = SF { fileKind      :: FileKind"
+  , "                     , filePath      :: FilePath -- relative path, including extension"
+  , "                     , timeStamp     :: Integer  -- unix epoch time"
+  , "                     , contentString :: String"
   , "                     }"
   , ""
+  , "getStaticFileContent :: FileKind -> FilePath -> Maybe String"
+  , "getStaticFileContent fk fp ="
+  , "     case filter isRightFile allStaticFiles of"
+  , "        [x] -> Just (contentString x)"
+  , "        _   -> Nothing"
+  , "  where"
+  , "    isRightFile :: StaticFile -> Bool"
+  , "    isRightFile (SF fKind path _ _ ) = fKind == fk && path == \".\\\\\"++fp"
+  , ""
   , "{-"++"# 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
ampersand.cabal view
@@ -1,10 +1,10 @@ name:           ampersand
-version:        3.0.3
+version:        3.1.0
 author:         Stef Joosten
 maintainer:     stef.joosten@ou.nl
 synopsis:       Toolsuite for automated design of business processes.
 description:    You can define your business processes by means of rules, written in Relation Algebra.
-homepage:       ampersand.sourceforge.net
+homepage:       http://wiki.tarski.nl
 category:       Database Design
 stability:      alpha
 cabal-version:  >= 1.10
@@ -13,52 +13,10 @@ license:        GPL
 license-file:   LICENSE
 copyright:      Stef Joosten
-bug-reports:    https://sourceforge.net/p/ampersand/tickets/
+bug-reports:    https://github.com/AmpersandTarski/ampersand/issues
 -- 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/AST.adl, 
-                AmpersandData/FormalAmpersand/ASTdocumentation.adl, 
-                AmpersandData/FormalAmpersand/ASTInterface.ifc, 
-                AmpersandData/FormalAmpersand/Atoms.adl, 
-                AmpersandData/FormalAmpersand/FormalAmpersand.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
 
 source-repository head
@@ -71,11 +29,10 @@   hs-source-dirs:    src
   default-language:  Haskell2010
   ghc-options:       -rtsopts -Wall
-  build-depends:     HDBC == 2.4.*,
-                     HDBC-odbc == 2.3.*,
+  build-depends:     
                      HStringTemplate == 0.7.*,
                      SpreadsheetML == 0.1.*,
-                     base >= 4.6 && < 5.0,
+                     base >= 4.7 && < 5.0,
                      bytestring == 0.10.*,
                      containers == 0.5.*,
                      csv == 0.1.*,
@@ -88,14 +45,18 @@                      old-time == 1.1.*,
                      pandoc == 1.13.*,
                      pandoc-types == 1.12.*,
+                     parsec == 3.1.*,
                      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.*
-        
+                     text >=1.1 && <1.3,
+                     xlsx == 0.1.*,
+                     zlib,
+                     lens,
+                     MissingH,
+                     wl-pprint
   other-modules:     
                      Database.Design.Ampersand,
                      Database.Design.Ampersand.ADL1,
@@ -104,7 +65,7 @@                      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.PrettyPrinters,
                      Database.Design.Ampersand.ADL1.Rule,
                      Database.Design.Ampersand.Basics,
                      Database.Design.Ampersand.Basics.Auxiliaries,
@@ -116,7 +77,6 @@                      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,
@@ -132,37 +92,44 @@                      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.FSpec.ToFSpec.Populated,
+                     Database.Design.Ampersand.Graphic.ClassDiag2Dot,
+                     Database.Design.Ampersand.Graphic.ClassDiagram,
+                     Database.Design.Ampersand.Graphic.Fspec2ClassDiagrams,
+                     Database.Design.Ampersand.Graphic.Graphics,
                      Database.Design.Ampersand.Input,
                      Database.Design.Ampersand.Input.ADL1.CtxError,
                      Database.Design.Ampersand.Input.ADL1.FilePos,
+                     Database.Design.Ampersand.Input.ADL1.Lexer,
+                     Database.Design.Ampersand.Input.ADL1.LexerMessage,
+                     Database.Design.Ampersand.Input.ADL1.LexerMonad,
+                     Database.Design.Ampersand.Input.ADL1.LexerTexts,
+                     Database.Design.Ampersand.Input.ADL1.LexerToken,
                      Database.Design.Ampersand.Input.ADL1.Parser,
-                     Database.Design.Ampersand.Input.ADL1.UU_BinaryTrees,
-                     Database.Design.Ampersand.Input.ADL1.UU_Scanner,
+                     Database.Design.Ampersand.Input.ADL1.ParsingLib,
                      Database.Design.Ampersand.Input.Parsing,
+                     Database.Design.Ampersand.Input.Xslx.XLSX,
                      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.Population2Xlsx,
                      Database.Design.Ampersand.Output.PredLogic,
                      Database.Design.Ampersand.Output.Statistics,
                      Database.Design.Ampersand.Output.ToPandoc.ChapterConceptualAnalysis,
@@ -177,9 +144,6 @@                      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,
@@ -188,7 +152,52 @@                      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
+                     Paths_ampersand,
+                     Database.Design.Ampersand.Core.A2P_Converters
+
+
+Test-Suite ampersand-test
+  type:              exitcode-stdio-1.0
+  main-is:           Test.hs
+  hs-source-dirs:    src
+  default-language:  Haskell2010
+  ghc-options:       -fhpc -with-rtsopts=-M1536m -Wall
+  build-depends:     
+                     base,
+                     bytestring >=0.10 && <0.11,
+                     containers >=0.5 && <0.6,
+                     directory >=1.2 && <1.3,
+                     hashable >=1.2 && <1.3,
+                     filepath,
+                     MissingH,
+                     mtl >=2.1 && <2.2,
+                     old-locale == 1.0.*,
+                     pandoc,
+                     pandoc-types,
+                     parsec >=3.1 && <3.2,
+                     QuickCheck == 2.8.*,
+                     text >=1.1 && <1.2,
+                     time >=1.4 && <1.5,
+                     simple-sql-parser,
+                     utf8-string,
+                     wl-pprint,
+                     transformers >=0.3 && <0.4,
+                     conduit >=1.2 && <1.3,
+                     xlsx == 0.1.*,
+                     zlib,
+                     lens
+  other-modules:     
+                     Database.Design.Ampersand.Misc.Options,
+                     Database.Design.Ampersand.Test.Parser.ArbitraryPandoc,
+                     Database.Design.Ampersand.Test.Parser.ArbitraryTree,
+                     Database.Design.Ampersand.Test.Parser.ParserTest,
+                     Database.Design.Ampersand.Test.Parser.QuickChecks,
+                     Database.Design.Ampersand.Test.RunAmpersand,
+                     Database.Design.Ampersand.Test.TestScripts,
+                     Database.Design.Ampersand.Input.Xslx.XLSX,
+                     Database.Design.Ampersand.Output.Population2Xlsx,
+                     Database.Design.Ampersand.Graphic.ClassDiag2Dot,
+                     Database.Design.Ampersand.Graphic.Fspec2ClassDiagrams,
+                     Database.Design.Ampersand.Core.A2P_Converters
− outputTemplates/default.asciidoc 
@@ -1,26 +0,0 @@-$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 
@@ -1,177 +0,0 @@-\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 
@@ -1,87 +0,0 @@-\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 
@@ -1,32 +0,0 @@-<?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 
@@ -1,13 +0,0 @@-$for(include-before)$
-$include-before$
-
-$endfor$
-$if(toc)$
-__TOC__
-
-$endif$
-$body$
-$for(include-after)$
-
-$include-after$
-$endfor$
− outputTemplates/default.dzslides 
@@ -1,123 +0,0 @@-<!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 
@@ -1,50 +0,0 @@-<?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 
@@ -1,56 +0,0 @@-<?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 
@@ -1,1 +0,0 @@-$body$
− outputTemplates/default.html 
@@ -1,61 +0,0 @@-<!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 
@@ -1,64 +0,0 @@-<!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 
@@ -1,43 +0,0 @@-<?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 
@@ -1,195 +0,0 @@-\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
-\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
-  \ifxetex
-    \usepackage{mathspec}
-    \usepackage{xltxtra,xunicode}
-  \else
-    \usepackage{fontspec}
-  \fi
-  \defaultfontfeatures{Mapping=tex-text,Scale=MatchLowercase}
-  \newcommand{\euro}{€}
-$if(mainfont)$
-    \setmainfont{$mainfont$}
-$endif$
-$if(sansfont)$
-    \setsansfont{$sansfont$}
-$endif$
-$if(monofont)$
-    \setmonofont[Mapping=tex-ansi]{$monofont$}
-$endif$
-$if(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{$if(biblio-style)$$biblio-style$$else$plainnat$endif$}
-$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}
-\VerbatimFootnotes
-$endif$
-$if(tables)$
-\usepackage{longtable,booktabs}
-$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>\textheight\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$
-\ifxetex
-  \usepackage[setpagesize=false, % page size defined by xetex
-              unicode=false, % unicode breaks when used with xetex
-              xetex]{hyperref}
-\else
-  \usepackage[unicode=true]{hyperref}
-\fi
-\hypersetup{breaklinks=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}}}
-$endif$
-$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)$
-\setcounter{secnumdepth}{5}
-$else$
-\setcounter{secnumdepth}{0}
-$endif$
-$if(verbatim-in-note)$
-\VerbatimFootnotes % allows verbatim text in footnotes
-$endif$
-
-$if(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$
-
-$endfor$
-$if(toc)$
-{
-\hypersetup{linkcolor=black}
-\setcounter{tocdepth}{$toc-depth$}
-\tableofcontents
-}
-$endif$
-$if(lot)$
-\listoftables
-$endif$
-$if(lof)$
-\listoffigures
-$endif$
-$body$
-
-$if(natbib)$
-$if(biblio-files)$
-$if(biblio-title)$
-$if(book-class)$
-\renewcommand\bibname{$biblio-title$}
-$else$
-\renewcommand\refname{$biblio-title$}
-$endif$
-$endif$
-\bibliography{$biblio-files$}
-
-$endif$
-$endif$
-$if(biblatex)$
-\printbibliography$if(biblio-title)$[title=$biblio-title$]$endif$
-
-$endif$
-$for(include-after)$
-$include-after$
-
-$endfor$
-\end{document}
− outputTemplates/default.man 
@@ -1,18 +0,0 @@-$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 
@@ -1,21 +0,0 @@-$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 
@@ -1,13 +0,0 @@-$for(include-before)$
-$include-before$
-
-$endfor$
-$if(toc)$
-__TOC__
-
-$endif$
-$body$
-$for(include-after)$
-
-$include-after$
-$endfor$
− outputTemplates/default.opendocument 
@@ -1,30 +0,0 @@-<?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 
@@ -1,11 +0,0 @@-<?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 
@@ -1,24 +0,0 @@-$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 
@@ -1,21 +0,0 @@-$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 
@@ -1,108 +0,0 @@-<!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 
@@ -1,42 +0,0 @@-$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 
@@ -1,30 +0,0 @@-{\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 
@@ -1,70 +0,0 @@-<!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 
@@ -1,79 +0,0 @@-<?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 
@@ -1,63 +0,0 @@-<?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 
@@ -1,64 +0,0 @@-\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 
@@ -1,9 +0,0 @@-$for(include-before)$
-$include-before$
-
-$endfor$
-$body$
-$for(include-after)$
-
-$include-after$
-$endfor$
src/Database/Design/Ampersand.hs view
@@ -4,7 +4,7 @@    , 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(..)
+   , Signature(..), ConceptDef(..), ConceptStructure(..)
    , Activity(..)
    , AMeaning(..)
    , Quad(..), Conjunct(..)
@@ -18,7 +18,7 @@    , Expression(..)
    , Population(..)
    , FSpec(..), concDefs
-   , PlugSQL(..), SqlField(..), SqlType(..), PlugInfo(..)
+   , PlugSQL(..), SqlField(..), SqlTType(..), PlugInfo(..)
    , PAclause(..)
    , Rule(..)
    , Prop(..), RuleOrigin(..)
@@ -26,8 +26,7 @@    , SqlFieldUsage(..)
    , DnfClause(..)
    , Options(..), DocTheme(..)
-   , Picture(..), writePicture , PictureReq(..), makePicture
-   , FilePos(..), Origin(..), Pos(Pos)
+   , FilePos(..), Origin(..)
    , mkPair
    -- * Classes:
    , Association(..), flp
@@ -45,7 +44,7 @@    , Language(..)
    , ShowHS(..), ShowHSName(..), haskellIdentifier
    -- * Functions on concepts
-   , (<==>),meet,join,sortWith,atomsOf
+   , (<==>),meet,join,sortWith,atomValuesOf
    , smallerConcepts, largerConcepts, rootConcepts
    -- * Functions on relations
    -- * Functions on rules
@@ -59,15 +58,13 @@    , deMorganERad, deMorganECps, deMorganEUni, deMorganEIsc
    , exprUni2list, exprIsc2list, exprCps2list, exprRad2list, exprPrd2list
    -- * Functions with plugs:
---   , showPlug, plugFields, tblcontents, plugpath, fldauto, requires, requiredFields, isPlugIndex
-   , showPlug, plugFields, tblcontents, fldauto
+   , showPlug, plugFields, fldauto
    -- * Parser related stuff
    , parseADL1pExpr, CtxError
    , createFSpec
-   , getGeneralizations, getSpecializations
     -- * Type checking and calculus
    , Guarded(..), pCtx2aCtx
-   , makeFSpec, getPopulationsFrom
+   , makeFSpec
     -- * Generators of output
    , generateAmpersandOutput
    -- * Prettyprinters
@@ -75,7 +72,7 @@    -- * Functions with Options
    , getOptions
    , verboseLn, verbose
-   , FileFormat(..),helpNVersionTexts
+   ,helpNVersionTexts
    -- * Other functions
    , eqCl, showErr, unCap,upCap,escapeNonAlphaNum, fatalMsg
    , ampersandVersionStr, ampersandVersionWithoutBuildTimeStr
@@ -91,8 +88,9 @@    -- * Stuff that should probably not be in the prototype
    , A_Markup(..), blocks2String, aMarkup2String, PandocFormat(..), Meaning(..)
    , rulefromProp
-   , fullContents, Paire, srcPaire,trgPaire
+   , fullContents, AAtomPair, apLeft,apRight
    , Purpose(..), ExplObj(..)
+   , ContextInfo,AAtomValue
    )
 where
 import Database.Design.Ampersand.Core.AbstractSyntaxTree
src/Database/Design/Ampersand/ADL1.hs view
@@ -8,9 +8,8 @@ where
 import Database.Design.Ampersand.Core.ParseTree (
            PPurpose(..), PRef2Obj(..)
-         , Paire, Pairs, mkPair , srcPaire, trgPaire
-         , Label(..)
-         , FilePos(..), Origin(..), Pos(..), Traced(..)
+         , mkPair
+         , FilePos(..), Origin(..), Traced(..)
          , Prop(..)
          , P_Concept(..)
          , P_Sign(..)
@@ -37,7 +36,7 @@          )
 import Database.Design.Ampersand.Core.AbstractSyntaxTree (
           A_Concept(..)
-         ,Sign(..),showSign,GenR()
+         ,Signature(..),showSign
          , (<==>),meet,join
          ,A_Context(..)
          ,Association(..)
@@ -58,6 +57,7 @@          ,A_RoleRelation(..)
          ,Population(..)
          ,Purpose(..), ExplObj(..)
+         , AAtomPair(..), AAtomValue(..), mkAtomPair, ContextInfo(..), representationOf
          , (.==.), (.|-.), (./\.), (.\/.), (.-.), (./.), (.\.), (.<>.), (.:.), (.!.), (.*.)
          )
 import Database.Design.Ampersand.ADL1.Expression
@@ -67,6 +67,6 @@ import Database.Design.Ampersand.ADL1.ECArule (
          isAll, isCHC, isBlk, isNop, isDo, eventsFrom)
 import Database.Design.Ampersand.ADL1.Rule (
-          rulefromProp, ruleviolations
+          rulefromProp
          ,consequent,antecedent,hasantecedent)
src/Database/Design/Ampersand/ADL1/Disambiguate.hs view
@@ -1,5 +1,5 @@-{-# OPTIONS_GHC -Wall #-}
-module Database.Design.Ampersand.ADL1.Disambiguate(disambiguate, DisambPrim(..),pCpt2aCpt) where
+{-# OPTIONS_GHC -Wall -Werror #-}
+module Database.Design.Ampersand.ADL1.Disambiguate(disambiguate, orWhenEmpty, 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)
@@ -99,11 +99,11 @@   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)
+  disambInfo (P_Ru fps nm expr mean msg Nothing) x
+   = (P_Ru fps nm exp' 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)
+  disambInfo (P_Ru fps nm expr mean msg (Just viol)) x
+   = (P_Ru fps nm exp' 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)
@@ -130,13 +130,13 @@    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)
+  disambInfo (P_ViewText nr a) _ = (P_ViewText nr a,noConstraints)
+  disambInfo (P_ViewHtml nr a) _ = (P_ViewHtml nr a,noConstraints)
+  disambInfo (P_ViewExp nr a) i = (P_ViewExp nr 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_InterfaceRef o a b) _      = (P_InterfaceRef o 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) [])
@@ -172,7 +172,7 @@   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 )
+  disambInfo (PInc o a b) env1 = ( PInc 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 )
@@ -213,7 +213,7 @@  = 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
+ | Mp1 PSingleton -- a singleton atomvalue, 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.
 
@@ -227,7 +227,7 @@                 ((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))
+     Mp1 x   -> determineBySize suggest (map (EMp1 x) (Set.toList possibleConcs))
      Vee     -> determineBySize (const (pure unkn))
                   [EDcV (Sign a b) | a<-Set.toList mustBeSrc, b<-Set.toList mustBeTgt]
  where
@@ -252,12 +252,14 @@    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
+
+orWhenEmpty :: [a] -> [a] -> [a]
+orWhenEmpty a b = if (null a) then b else a
 
 pCpt2aCpt :: P_Concept -> A_Concept
 pCpt2aCpt pc
src/Database/Design/Ampersand/ADL1/ECArule.hs view
@@ -65,8 +65,8 @@ 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 p@New{}          = On Ins (Isn (paCpt p)): eventsFrom (paCl p (makePSingleton "x"))
+eventsFrom p@Rmv{}          = On Del (Isn (paCpt p)): eventsFrom (paCl p (makePSingleton "x"))
 eventsFrom Nop{}            = []
 eventsFrom Blk{}            = []
 eventsFrom Let{}            = fatal 56 "eventsFrom not defined for `Let` constructor of PAclause"
src/Database/Design/Ampersand/ADL1/Expression.hs view
@@ -21,7 +21,7 @@ subst (decl,expr) = subs
      where
        subs (EEqu (l,r)) = EEqu (subs l,subs r)
-       subs (EImp (l,r)) = EImp (subs l,subs r)
+       subs (EInc (l,r)) = EInc (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)
@@ -48,7 +48,7 @@ 
 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 (EInc (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
@@ -73,7 +73,7 @@ primitives expr =
   case expr of
     (EEqu (l,r)) -> primitives l `uni` primitives r
-    (EImp (l,r)) -> primitives l `uni` primitives r
+    (EInc (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
@@ -130,10 +130,9 @@ isCpl _ = False
 
 isPos :: Expression -> Bool
-isPos (ECpl{}) = False
-isPos _ = True
+isPos  = not . isNeg
 isNeg :: Expression -> Bool
-isNeg = not . isPos
+isNeg = isCpl
 
 isMp1 :: Expression -> Bool
 isMp1 EMp1{} = True
@@ -162,7 +161,7 @@      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  (EInc (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)
src/Database/Design/Ampersand/ADL1/P2A_Converters.hs view
@@ -1,4 +1,4 @@-{-# OPTIONS_GHC -Wall #-}
+{-# OPTIONS_GHC -Wall -Werror #-}
 {-# LANGUAGE LambdaCase #-}
 module Database.Design.Ampersand.ADL1.P2A_Converters (pCtx2aCtx,pCpt2aCpt)
 where
@@ -7,7 +7,7 @@ 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.ViewPoint
 import Database.Design.Ampersand.Classes.ConceptStructure
 import Database.Design.Ampersand.Basics
 import Database.Design.Ampersand.Misc
@@ -23,7 +23,7 @@ fatal :: Int -> String -> a
 fatal = fatalMsg "ADL1.P2A_Converters"
 
-newtype SignOrd = SignOrd Sign
+newtype SignOrd = SignOrd Signature
 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
@@ -44,6 +44,7 @@ -- Part 3 is done below, the other two are done in pCtx2aCtx'
 pCtx2aCtx :: Options -> P_Context -> Guarded A_Context
 pCtx2aCtx opts = checkOtherAtomsInSessionConcept
+               . checkMultipleRepresentationsOfConcepts
                . 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
@@ -80,7 +81,7 @@ 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 )
+    ExplConceptDef concDef -> let nm = name concDef in nm `notElem` map name (concs 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)
@@ -99,9 +100,9 @@       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
+                                   Nothing                  -> []
+                                   Just (InterfaceRef isLinkto nm) -> [nm | not isLinkto]
+                                   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"
@@ -130,13 +131,28 @@    case gCtx of
      Errors _  -> gCtx
      Checked ctx -> case [mkOtherAtomInSessionError atom
-                         | pop@PCptPopu{popcpt =cpt} <- ctxpopus ctx
+                         | pop@ACptPopu{popcpt =cpt} <- ctxpopus ctx
                          , name cpt == "SESSION"
-                         , atom <- filter (/= "_SESSION") (popas pop)
+                         , atom <- filter (not.isPermittedSessionValue) (popas pop)
                          ] of
                       [] -> gCtx
                       errs -> Errors errs
-
+        where isPermittedSessionValue :: AAtomValue -> Bool
+              isPermittedSessionValue (AAVString _ str) = str == "_SESSION"
+              isPermittedSessionValue _                 = False
+checkMultipleRepresentationsOfConcepts :: Guarded A_Context -> Guarded A_Context
+checkMultipleRepresentationsOfConcepts gCtx =
+   case gCtx of 
+     Errors _ -> gCtx
+     Checked ctx -> case [ mkMultipleRepresentationsForConceptError cpt (filter (isAbout cpt) (ctxreprs ctx))
+                         | cpt <- nub . concatMap reprcpts . ctxreprs $ ctx
+                         , (length . nub . map reprdom . filter (isAbout cpt) . ctxreprs) ctx > 1
+                         ] of
+                      []   -> gCtx
+                      errs -> Errors errs
+   where
+    isAbout :: String -> Representation -> Bool 
+    isAbout cpt rep = cpt `elem` reprcpts rep                 
 pCtx2aCtx' :: Options -> P_Context -> Guarded A_Context
 pCtx2aCtx' _
  PCtx { ctx_nm     = n1
@@ -145,13 +161,13 @@       , 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_reprs  = p_representations
       , ctx_vs     = p_viewdefs
       , ctx_gs     = p_gens
       , ctx_ifcs   = p_interfaces
@@ -161,7 +177,7 @@       , ctx_php    = p_phpdefs
       , ctx_metas  = p_metas
       }
- = (\pats rules identdefs viewdefs interfaces purposes udpops sqldefs phpdefs allRoleRelations
+ = (\pats rules identdefs viewdefs interfaces purposes udpops sqldefs phpdefs allRoleRelations declsAndPops
      -> ACtx{ ctxnm = n1
             , ctxpos = n2
             , ctxlang = deflangCtxt
@@ -169,12 +185,19 @@             , ctxthms = p_themes
             , ctxpats = pats
             , ctxrs = rules
-            , ctxds = ctxDecls
-            , ctxpopus = nub (udpops++dclPops++mp1Pops rules++mp1Pops pats++mp1Pops identdefs++mp1Pops viewdefs++mp1Pops interfaces)
+            , ctxds = map fst declsAndPops
+            , ctxpopus = nub (udpops
+                            ++map snd declsAndPops
+                            ++mp1Pops contextInfo rules
+                            ++mp1Pops contextInfo pats
+                            ++mp1Pops contextInfo identdefs
+                            ++mp1Pops contextInfo viewdefs
+                            ++mp1Pops contextInfo interfaces)
             , ctxcds = allConceptDefs
             , ctxks = identdefs
             , ctxrrules = allRoleRules
             , ctxRRels = allRoleRelations
+            , ctxreprs = allRepresentations
             , ctxvs = viewdefs
             , ctxgs = map pGen2aGen p_gens
             , ctxgenconcs = map (map castConcept) (concGroups ++ map (:[]) soloConcs)
@@ -184,8 +207,8 @@             , 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 pPat2aPat p_patterns            --  The patterns defined in this context
+      <*> traverse (pRul2aRul n1) p_rules       --  All user defined rules in this context, but outside patterns
       <*> 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
@@ -193,16 +216,23 @@       <*> 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))
+      <*> traverse pRoleRelation2aRoleRelation (p_roleRelations ++ concatMap pt_RRels p_patterns)
+      <*> traverse (pDecl2aDecl n1 deflangCtxt deffrmtCtxt) p_declarations
       
   where
+    contextInfo :: ContextInfo
+    contextInfo = 
+      CI { ctxiGens = map pGen2aGen p_gens
+         , ctxiRepresents = allRepresentations
+         }
+
     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)
+               | x <- p_gens ++ concatMap pt_gns p_patterns
                ]
     genLattice :: Op1EqualitySystem String
     genLattice = optimize1 (foldr addEquality emptySystem genRules)
@@ -218,17 +248,42 @@ 
     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.
+--    decls  = map fst declsAndPops ++concatMap ptdcs pats
+    decls = case f of
+             Checked ds -> ds
+             Errors err -> fatal 253 $ "there are errors."++show err
+      where f = (\declsWithPops
+                  -> map fst declsWithPops -- ++ concatMap ptdcs pats
+                ) <$> traverse (pDecl2aDecl n1 deflangCtxt deffrmtCtxt) (p_declarations  ++ concatMap pt_dcs p_patterns)
+ 
 
+--    dclPops= ctxDclPops++patDclPops
+--    (ctxDecls,_ ) =  ctxDecls'
+--    dps = ctxDecls'++patDecls
+--    (ctxDecls,ctxDclPops) = [ pDecl2aDecl n1         deflangCtxt deffrmtCtxt pDecl | pDecl<-p_declarations ] --  The relations declared in this context, outside the scope of patterns
+--    (patDecls,patDclPops) = [ pDecl2aDecl (name pat) deflangCtxt deffrmtCtxt pDecl | pat<-p_patterns, 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
+    findDecl o x = (getOneExactly o . findDecls') x
+    findDecls' x = Map.elems (findDecls x)
+    findDeclsLooselyTyped x (Just src) (Just tgt)
+     = findDeclsTyped x (Sign src tgt)
+       `orWhenEmpty` (findDeclsLooselyTyped x (Just src) Nothing `isct` findDeclsLooselyTyped x Nothing (Just tgt))
+       `orWhenEmpty` (findDeclsLooselyTyped x (Just src) Nothing `unin`  findDeclsLooselyTyped x Nothing (Just tgt))
+       `orWhenEmpty` findDecls' x
+     where isct lsta lstb = [a | a<-lsta, a `elem` lstb]
+           unin lsta lstb = nub (lsta ++ lstb)
+    findDeclsLooselyTyped x Nothing Nothing = findDecls' x
+    findDeclsLooselyTyped x (Just src) Nothing
+     = [dcl | dcl <- findDecls' x, name (source dcl) == name src ]
+       `orWhenEmpty` findDecls' x
+    findDeclsLooselyTyped x Nothing (Just tgt)
+     = [dcl | dcl <- findDecls' x, name (target dcl) == name tgt ]
+       `orWhenEmpty` findDecls' x
+    findDeclLooselyTyped o x src tgt = getOneExactly o (findDeclsLooselyTyped x src tgt)
     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
@@ -242,25 +297,30 @@          String         -- The name of the pattern
       -> Lang           -- The default language
       -> PandocFormat   -- The default pandocFormat
-      -> P_Declaration -> (Declaration, Population)
+      -> P_Declaration -> Guarded (Declaration,Population)
     pDecl2aDecl patNm defLanguage defFormat pd
-     = let dcl = Sgn { decnm   = dec_nm pd
+     = let (prL:prM:prR:_) = dec_pragma pd ++ ["", "", ""]
+           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
+                     , decprL  = prL
+                     , decprM  = prM
+                     , decprR  = prR
                      , 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})
+       in (\aps -> (dcl,ARelPopu { popdcl = dcl
+                                 , popps = aps
+                                 , popsrc = source dcl
+                                 , poptgt = target dcl
+                                 })
+          ) <$> traverse (pAtomPair2aAtomPair dcl) (dec_popu pd)
 
-    pSign2aSign :: P_Sign -> Sign
+    pSign2aSign :: P_Sign -> Signature
     pSign2aSign (P_Sign src tgt) = Sign (pCpt2aCpt src) (pCpt2aCpt tgt)
 
     pGen2aGen :: P_Gen -> A_Gen
@@ -273,7 +333,7 @@              , genspc = pCpt2aCpt (gen_spc pg)
              }
 
-    castSign :: String -> String -> Sign
+    castSign :: String -> String -> Signature
     castSign a b = Sign (castConcept a) (castConcept b)
 
     leastConcept :: A_Concept -> String -> A_Concept
@@ -288,17 +348,54 @@     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))
+    pPop2aPop pop = 
+     case pop of
+       P_RelPopu{p_nmdr = nmdr, p_popps=aps, p_src = src, p_tgt = tgt}
+         -> unguard $
+             (\dcl
+               -> (\aps' src' tgt'
+                    -> ARelPopu { popdcl = dcl
+                                , popps = aps'
+                                , popsrc = maybe (source dcl) castConcept src'
+                                , poptgt = maybe (target dcl) castConcept tgt'
+                                }
+                  ) <$> traverse (pAtomPair2aAtomPair dcl) aps
+                    <*> maybeOverGuarded (isMoreGeneric pop dcl Src) src
+                    <*> maybeOverGuarded (isMoreGeneric pop dcl Tgt) tgt
+             ) <$> (case p_mbSign nmdr of
+                      Nothing -> findDeclLooselyTyped pop (name nmdr) (castConcept <$> src) (castConcept <$> tgt)
+                      Just s -> findDeclTyped nmdr (p_nrnm nmdr) (pSign2aSign s)
+                   ) -- disambiguate
+       P_CptPopu{}
+         -> let cpt = castConcept (p_cnme pop) in  
+            (\vals
+              -> ACptPopu { popcpt = cpt
+                          , popas  = vals
+                          }
+              ) <$> traverse (pAtomValue2aAtomValue cpt) (p_popas pop)
+    isMoreGeneric o dcl sourceOrTarget givenType
+     = if givenType `elem` findExact genLattice (Atom (getConcept sourceOrTarget dcl) `Meet` Atom givenType)
+       then pure givenType
+       else mkTypeMismatchError o dcl sourceOrTarget (castConcept givenType)
+         
+    
+    pAtomPair2aAtomPair :: Declaration -> PAtomPair -> Guarded AAtomPair
+    pAtomPair2aAtomPair dcl pp = 
+     (\l r ->
+       mkAtomPair l r
+     ) <$> pAtomValue2aAtomValue (source dcl) (ppLeft  pp)
+       <*> pAtomValue2aAtomValue (target dcl) (ppRight pp)
 
+    pAtomValue2aAtomValue ::A_Concept -> PAtomValue -> Guarded AAtomValue
+    pAtomValue2aAtomValue cpt pav =
+       case unsafePAtomVal2AtomValue typ (Just cpt) pav of
+        Left msg -> Errors [mkIncompatibleAtomValueError pav msg]
+        Right av -> pure av
+      where typ = representationOf contextInfo cpt
+               
+
     pObjDef2aObjDef :: P_ObjectDef -> Guarded ObjectDef
     pObjDef2aObjDef x = pObjDefDisamb2aObjDef $ disambiguate termPrimDisAmb x
 
@@ -329,16 +426,18 @@        <$> 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
+    typeCheckViewSegment o vs
+     = case vs of 
+        P_ViewExp{} -> 
+          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 (vs_nr vs) obj{objctx = addEpsilonLeft' (head r) (objctx obj)})
+                                 else mustBeBound (origin obj) [(Tgt,objctx obj)])
+         <$> typecheckObjDef (vs_obj vs)
+        P_ViewText{} -> pure$ ViewText (vs_nr vs) (vs_txt vs)
+        P_ViewHtml{} -> pure$ ViewHtml (vs_nr vs) (vs_htm vs)
      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
@@ -405,7 +504,7 @@       = case x of
          P_InterfaceRef{si_str = ifcId} 
            ->  unguard $
-             (\(refIfcExpr,_) -> (\objExprEps -> (objExprEps,InterfaceRef ifcId)) <$> typeCheckInterfaceRef o ifcId objExpr refIfcExpr)
+             (\(refIfcExpr,_) -> (\objExprEps -> (objExprEps,InterfaceRef (si_isLink x) 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]
@@ -444,12 +543,12 @@                                    _      -> (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
+         PInc _ 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
+         PLrs _ a b -> unguard $ binary' (./.)  (MBE (Tgt,snd) (Tgt,fst)) ((Src,fst),(Src,snd)) Tgt Tgt <$> tt a <*> tt b
+         PRrs _ a b -> unguard $ binary' (.\.)  (MBE (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
@@ -544,8 +643,8 @@     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))]
+    namedRel2Decl o@(PNamedRel _ r Nothing)  = findDecl o r
+    namedRel2Decl o@(PNamedRel _ r (Just s)) = findDeclTyped o r (pSign2aSign s)
 
     pIfc2aIfc :: (P_Interface, P_ObjDef (TermPrim, DisambPrim)) -> Guarded Interface
     pIfc2aIfc (P_Ifc { ifc_Params = tps
@@ -591,29 +690,29 @@          <*> traverse pPop2aPop (pt_pop ppat)
          <*> traverse pViewDef2aViewDef (pt_vds ppat) 
          <*> traverse pPurp2aPurp (pt_xps ppat)
+         <*> traverse (pDecl2aDecl (name ppat) deflangCtxt deffrmtCtxt) (pt_dcs 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
-                      }
+        f rules' keys' pops' views' xpls declsAndPops
+           = A_Pat { ptnm  = name ppat
+                   , ptpos = pt_pos ppat
+                   , ptend = pt_end ppat
+                   , ptrls = rules'
+                   , ptgns = map pGen2aGen (pt_gns ppat)
+                   , ptdcs = map fst declsAndPops
+                   , ptups = pops' ++ map snd declsAndPops
+                   , 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
+    typeCheckRul env P_Ru { rr_fps = orig
+                          , rr_nm = nm
                           , rr_exp = expr
-                          , rr_fps = orig
                           , rr_mean = meanings
                           , rr_msg = msgs
                           , rr_viol = viols
@@ -691,17 +790,19 @@     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} 
+        []    -> Cd{cdpos=OriginUnknown, cdcpt=s, cdplug=True, cddef="", cdref="", cdfrom=n1} 
         (x:_) -> x
     allConceptDefs :: [ConceptDef]
-    allConceptDefs = p_conceptdefs++concatMap pt_cds (p_patterns++p_processes)
+    allConceptDefs = p_conceptdefs++concatMap pt_cds p_patterns
     allRoleRules :: [A_RoleRule]
     allRoleRules = map pRoleRule2aRoleRule 
-                      (p_roleRules ++ concatMap pt_RRuls (p_patterns++p_processes))
+                      (p_roleRules ++ concatMap pt_RRuls p_patterns)
+    allRepresentations :: [Representation]
+    allRepresentations = p_representations++concatMap pt_Reprs p_patterns
+
 pDisAmb2Expr :: (TermPrim, DisambPrim) -> Guarded Expression
 pDisAmb2Expr (_,Known x) = pure x
 pDisAmb2Expr (_,Rel [x]) = pure x
@@ -726,7 +827,6 @@              , 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
@@ -744,7 +844,7 @@   (Src,(e,(b,_))) -> (Src,(e,b))
   (Tgt,(e,(_,b))) -> (Tgt,(e,b))
 
-maybeOverGuarded :: Applicative f => (t -> f a) -> Maybe t -> f (Maybe a)
+maybeOverGuarded :: (t -> Guarded a) -> Maybe t -> Guarded (Maybe a)
 maybeOverGuarded _ Nothing = pure Nothing
 maybeOverGuarded f (Just x) = Just <$> f x
 
@@ -778,7 +878,6 @@   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 :: Association a => SrcOrTgt -> a -> String
 getConcept Src = name . source
 getConcept Tgt = name . target
-
− src/Database/Design/Ampersand/ADL1/Pair.hs 
@@ -1,26 +0,0 @@-{-# 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/PrettyPrinters.hs view
@@ -0,0 +1,418 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}
+module Database.Design.Ampersand.ADL1.PrettyPrinters(prettyPrint)
+where
+
+import Text.PrettyPrint.Leijen
+import Database.Design.Ampersand.Basics        (fatalMsg)
+import Database.Design.Ampersand.Core.ParseTree
+import Database.Design.Ampersand.Input.ADL1.Lexer(keywords)
+import Data.List (intercalate,intersperse)
+import Data.List.Utils (replace)
+import Data.Char (toUpper)
+
+fatal :: Int -> String -> a
+fatal = fatalMsg "PrettyPrinters"
+
+prettyPrint :: Pretty a => a -> String
+prettyPrint x = displayS (renderPretty rfrac col_width doc) ""
+        where col_width = 120
+              rfrac = 0.4
+              doc = pretty x
+
+(<~>) :: Pretty b => Doc -> b -> Doc
+(<~>) a b = a <+> pretty b
+
+(<+\>) :: Doc -> Doc -> Doc
+(<+\>) a b = a <$$> b
+
+(<~\>) :: Pretty b => Doc -> b -> Doc
+(<~\>) a b = a <+\> pretty b
+
+perline :: Pretty a => [a] -> Doc
+perline = vsep . map pretty
+
+perlinePrefix :: Pretty a => String -> [a] -> Doc
+perlinePrefix pref xs = vsep $ map addPrefix xs
+           where addPrefix x = text pref <+> pretty x
+
+--quoteWith :: String -> String -> String -> Doc
+--quoteWith l r x = enclose (text l) (text r) (text x)
+
+quote :: String -> Doc
+quote = text.show
+--singlequote :: String -> Doc
+--singlequote = squotes.text.escapeAll
+--escapeAll :: [Char] -> [Char]
+--escapeAll = escapeQuote.escapeBreaklines.escapeSlash
+--        where escapeQuote = escape "\""
+--              escapeBreaklines = replace "\n" "\\n"
+--              escapeSlash = escape "\\"
+--              escape x = replace x ("\\" ++ x)
+
+quoteAll :: [String] -> [Doc]
+quoteAll = map quote
+
+quotePurpose :: String -> Doc
+quotePurpose p = text "{+" </> escapeExpl p </> text "-}"
+        where escapeExpl = text.escapeCommentStart.escapeLineComment.escapeExplEnd
+              escapeCommentStart = escape "{-"
+              escapeLineComment = escape "--"
+              escapeExplEnd = escape "-}"
+              escape x = replace x (intersperse ' ' x)
+
+isId :: String -> Bool
+isId a = not (null a) && all isIdChar a && isFirstIdChar(head a) && a `notElem` keywords
+       where isFirstIdChar x = elem x $ "_"++['a'..'z']++['A'..'Z']
+             isIdChar x = isFirstIdChar x || elem x ['0'..'9']
+
+isUpperId :: String -> Bool
+isUpperId xs = isId xs && head xs `elem` ['A'..'Z']
+
+maybeQuote :: String -> Doc
+maybeQuote a = if isId a then text a else quote a
+
+-- adds quotes unless it's an upper identifier
+quoteConcept :: String -> Doc
+quoteConcept a = if isUpperId a then text a else quote a
+
+prettyhsep :: Pretty a => [a] -> Doc
+prettyhsep = hsep . map pretty
+
+commas :: [Doc] -> Doc
+commas = encloseSep empty empty comma
+
+listOf :: Pretty a => [a] -> Doc
+listOf = commas . map pretty
+
+listOfLists :: [[String]] -> Doc
+listOfLists xs = commas $ map (hsep.quoteAll) xs
+
+separate :: Pretty a => String -> [a] -> Doc
+separate d xs = encloseSep empty empty (text d) $ map pretty xs
+
+--TODO: This replace shouldn't be necessary, I don't know why quotes are getting into the Prel
+-- Example to test: AmpersandData\FormalAmpersand\AST.adl
+takeQuote :: String -> String
+takeQuote = replace "\"" ""
+
+labelArgs :: [[String]] -> Doc
+labelArgs args = if null args || all null args
+                 then empty
+                 else braces $ listOfLists args
+
+prettyLabel :: String -> [[String]] -> Doc
+prettyLabel nm strs = maybeQuote nm <+> labelArgs strs
+
+instance Pretty P_Context where
+    pretty (PCtx nm _ lang markup thms pats rs ds cs ks rrules rrels reprs vs gs ifcs ps pops sql php metas) =
+               text "CONTEXT"
+               <+> quoteConcept nm
+               <~> lang
+               <~> markup
+               <+\> perline metas
+               <+\> themes
+               <+\> perline ps
+               <+\> perline pats
+               <+\> perline rs
+               <+\> perline ds
+               <+\> perline cs
+               <+\> perline ks
+               <+\> perline rrules
+               <+\> perline rrels
+               <+\> perline reprs
+               <+\> perline vs
+               <+\> perline gs
+               <+\> perline ifcs
+               <+\> perline pops
+               <+\> perlinePrefix "SQLPLUG" sql
+               <+\> perlinePrefix "PHPPLUG" php
+               <+\> text "ENDCONTEXT"
+             where themes | null thms = empty
+                          | otherwise = text "THEMES" <+> commas (map quoteConcept thms)
+
+instance Pretty Meta where
+    pretty (Meta _ obj name val) =
+        text "META" <~> obj <+> quote name <+> quote val
+
+instance Pretty MetaObj where
+    pretty ContextMeta = empty -- for the context meta we don't need a keyword
+
+instance Pretty P_RoleRelation where
+    pretty (P_RR _ roles rels) =
+        text "ROLE" <+> listOf roles <+> text "EDITS" <+> listOf rels
+
+instance Pretty P_RoleRule where
+    pretty (Maintain _ roles rules) =
+        text "ROLE" <+> listOf roles <+> text "MAINTAINS" <+> commas (map maybeQuote rules)
+
+instance Pretty Role where
+    pretty (Role name) = maybeQuote name
+    pretty (Service name) = maybeQuote name
+
+instance Pretty P_Pattern where
+    pretty (P_Pat _ nm rls gns dcs rruls rrels reprs cds ids vds xps pop _) =
+          text keyword
+          <+>  quoteConcept nm
+          <+\> perline rls
+          <+\> perline gns
+          <+\> perline dcs
+          <+\> perline rruls
+          <+\> perline rrels
+          <+\> perline reprs
+          <+\> perline cds
+          <+\> perline ids
+          <+\> perline vds
+          <+\> perline xps
+          <+\> perline pop
+          <+>  text ("END"++keyword)
+        where keyword = if null rruls && null rrels then "PATTERN" else "PROCESS"
+
+instance Pretty P_Declaration where
+    pretty (P_Sgn nm sign prps pragma mean popu _ plug) =
+        text "RELATION" <+> text nm <~> sign <+> props <+> byplug <+\> pragmas <+\> prettyhsep mean <+\> content
+        where props   = if prps == [Sym, Asy] then text "[PROP]"
+                        else text "[" <> listOf prps <> text "]"
+              byplug  | plug        = text "BYPLUG"
+                      | otherwise   = empty
+              pragmas | null pragma = empty
+                      | otherwise   = text "PRAGMA" <+> hsep (map quote pragma)
+              content | null popu   = empty
+                      | otherwise   = text "=\n[" <+> commas (map pretty popu) <+> text "]"
+
+instance Pretty a => Pretty (Term a) where
+   pretty p = case p of
+       Prim a -> pretty a
+       -- level 0 (rule)
+       PEqu _ t1 t2 -> two t1 t2 "="
+       PInc _ t1 t2 -> two t1 t2 " |- "
+       -- level 1
+       PIsc _ t1 t2 -> two t1 t2 "/\\"
+       PUni _ t1 t2 -> two t1 t2 "\\/"
+       -- level 2
+       PDif _ t1 t2 -> two t1 t2 "-"
+       -- level 3
+       PLrs _ t1 t2 -> two t1 t2 "/"
+       PRrs _ t1 t2 -> two t1 t2 "\\"
+       PDia _ t1 t2 -> two t1 t2 "<>"
+       -- level 4
+       PCps _ t1 t2 -> two t1 t2 ";"
+       PRad _ t1 t2 -> two t1 t2 "!"
+       PPrd _ t1 t2 -> two t1 t2 "#"
+       -- level 5
+       PKl0 _ t -> pos t "*"
+       PKl1 _ t -> pos t "+"
+       PFlp _ t -> pos t "~"
+       PCpl _ t -> pre t " -" -- a double dash can happen when combined with PDif, therefore the extra space
+       -- level 6
+       PBrk _ t -> parens $ pretty t
+       
+       where pos t op     = pretty t <> text op
+             pre t op     = text op <> pretty t
+             two t1 t2 op = pretty t1 <> text op <> pretty t2
+
+instance Pretty TermPrim where
+    pretty p = case p of
+        PI _ -> text "I"
+        Pid _ concept -> text "I[" <> pretty concept <> text "]"
+        Patm _ val (Just concept) -> text (show val) <> text "[" <> pretty concept <> text "]"
+        Patm _ val Nothing        -> text (show val) 
+        PVee _ -> text "V"
+        Pfull _ s1 s2 -> text "V" <~> P_Sign s1 s2
+        PNamedR rel -> pretty rel
+
+--instance Pretty PSingleton where
+--    pretty = text . show
+instance Pretty P_NamedRel where
+    pretty (PNamedRel _ str mpSign) = text (takeQuote str) <~> mpSign
+
+instance Pretty a => Pretty (PairView a) where
+    pretty (PairView ss) = text "VIOLATION" <+> parens (listOf ss)
+
+instance Pretty a => Pretty (PairViewSegment a) where
+    pretty (PairViewText _ str) = text "TXT" <+> quote str
+    pretty (PairViewExp _ srcTgt term) = pretty srcTgt <~> term
+
+instance Pretty SrcOrTgt where
+    pretty Src = text "SRC"
+    pretty Tgt = text "TGT"
+
+instance Pretty a => Pretty (P_Rule a) where
+    pretty (P_Ru _ nm expr mean msg viol) =
+                text "RULE" <+> name <~>
+                expr <+\>
+                perline mean <+\>
+                perline msg <~\>
+                viol
+            where name = if null nm then empty
+                         else maybeQuote nm <> text ":"
+
+instance Pretty ConceptDef where
+    pretty (Cd _ cpt plug def ref _) -- from, the last argument, is not used in the parser
+        = text "CONCEPT" <+> quoteConcept cpt <+> (if plug then text "BYPLUG" else empty)
+               <+> quote def <+> maybeText ref
+        where maybeText txt = if null txt then empty
+                              else quote txt
+
+instance Pretty P_Population where
+    pretty p = case p of
+                P_RelPopu _ _ _ nrel  cs -> text "POPULATION" <+> pretty nrel      <+> text "CONTAINS" <+> contents cs
+                P_CptPopu _ nm    ps -> text "POPULATION" <+> quoteConcept nm  <+> text "CONTAINS" <+> pretty ps
+               where contents = list . map pretty
+
+instance Pretty Representation where
+    pretty (Repr _ cs tt) = text "REPRESENT" <+> listOf cs <~> text "TYPE" <+> pretty tt
+
+instance Pretty TType where
+    pretty = text . show
+      
+instance Pretty P_Interface where
+    pretty (P_Ifc name klass prms args roles obj _ _) =
+        text "INTERFACE" <+> maybeQuote name <+> class_
+               <+> params <+> labelArgs args <+> iroles
+               <+> text ":" <~\> obj_ctx obj <~> obj_msub obj
+                 where class_ = case klass of
+                                     Nothing  -> empty
+                                     Just str -> text "CLASS" <+> quoteConcept str
+                       params = if null prms then empty
+                                else parens $ listOf prms
+                       iroles = if null roles then empty
+                                else text "FOR" <+> listOf roles
+
+instance Pretty a => Pretty (P_ObjDef a) where
+    pretty (P_Obj nm _ ctx mView msub strs) =
+        prettyLabel nm strs <+> text ":"
+                 <~> ctx <+> view mView <~> msub
+        where view Nothing  = empty
+              view (Just v) = text ("<" ++ v ++ ">")
+
+instance Pretty a => Pretty (P_SubIfc a) where
+    pretty p = case p of
+                P_Box _ c bs         -> box_type c <+> text "[" <> listOf bs <> text "]"
+                P_InterfaceRef _ isLink str -> text ((if isLink then "LINKTO "else "")++"INTERFACE") <+> maybeQuote str
+            where box_type Nothing  = text "BOX"
+                  box_type (Just x) = text x -- ROWS, COLS, TABS
+
+instance Pretty a => Pretty (P_IdentDf a) where
+    pretty (P_Id _ lbl cpt ats) =
+        text "IDENT" <+> maybeQuote lbl <+> text ":" <~> cpt <+> parens (listOf ats)
+
+instance Pretty a => Pretty (P_IdentSegmnt a) where
+    pretty (P_IdentExp (P_Obj nm _ ctx mView _ strs)) =
+              if null nm
+              then pretty ctx -- no label
+              else prettyLabel nm strs <> text ":" <~> ctx <+> view mView
+        where view Nothing  = empty
+              view (Just v) = pretty v
+
+instance Pretty a => Pretty (P_ViewD a) where
+    pretty (P_Vd _ lbl cpt True Nothing ats) = -- legacy syntax
+        text "VIEW" <+> maybeQuote lbl   <+> text ":"
+                    <~> cpt <+> parens (listOf ats)
+    pretty (P_Vd _ lbl cpt isDefault html ats) = -- new syntax
+        text "VIEW" <+> maybeQuote lbl  <+> text ":"
+                    <~> cpt <+> (if isDefault then text "DEFAULT" else empty)
+                    <+> braces (listOf ats) <~> html <+> text "ENDVIEW"
+
+instance Pretty ViewHtmlTemplate where
+    pretty (ViewHtmlTemplateFile str) = text "HTML" <+> text "TEMPLATE" <+> quote str
+
+instance Pretty a => Pretty (P_ViewSegmt a) where
+    pretty (P_ViewExp _ (P_Obj nm _ ctx _ _ _))
+                              = maybeQuote nm <+> text ":" <~> ctx
+    pretty (P_ViewText _ txt) = text "TXT" <+> quote txt
+    pretty (P_ViewHtml _ htm) = text "PRIMHTML" <+> quote htm
+                        
+instance Pretty PPurpose where
+    pretty (PRef2 _ obj markup refIds) =
+             text "PURPOSE" <~> obj <~> lang <+> refs refIds
+             <+\> quotePurpose (mString markup)
+        where lang = mFormat markup
+              refs rs = if null rs then empty
+                        else text "REF" <+> quote (intercalate "; " rs)
+
+instance Pretty PRef2Obj where
+    pretty p = case p of
+        PRef2ConceptDef str       -> text "CONCEPT"   <+> quoteConcept str
+        PRef2Declaration namedRel -> text "RELATION"  <~> namedRel
+        PRef2Rule str             -> text "RULE"      <+> maybeQuote str
+        PRef2IdentityDef str      -> text "IDENT"     <+> maybeQuote str
+        PRef2ViewDef str          -> text "VIEW"      <+> maybeQuote str
+        PRef2Pattern str          -> text "PATTERN"   <+> maybeQuote str
+        PRef2Interface str        -> text "INTERFACE" <+> maybeQuote str
+        PRef2Context str          -> text "CONTEXT"   <+> maybeQuote str
+
+instance Pretty PMeaning where
+    pretty (PMeaning markup) = text "MEANING" <~> markup
+
+instance Pretty PMessage where
+    pretty (PMessage markup) = text "MESSAGE" <~> markup
+
+instance Pretty P_Concept where
+    pretty (PCpt name) = quoteConcept name
+    pretty P_Singleton = text "ONE"
+
+instance Pretty P_Sign where
+    pretty (P_Sign src tgt) = brackets (pretty src <> maybeTgt)
+        where maybeTgt = if src `equal` tgt then empty
+                         else text "*" <> pretty tgt
+              equal (PCpt x) (PCpt y) = x == y
+              equal P_Singleton P_Singleton = True
+              equal _ _ = False
+
+instance Pretty P_Gen where
+    pretty p = case p of
+            PGen _ spc gen -> text "CLASSIFY" <~> spc <+> text "ISA" <~> gen
+            P_Cy _ spc rhs -> text "CLASSIFY" <~> spc <+> text "IS"  <+> separate "/\\" rhs
+
+instance Pretty Lang where
+    pretty Dutch   = text "IN DUTCH"
+    pretty English = text "IN ENGLISH"
+
+instance Pretty P_Markup where
+    pretty (P_Markup lang format str) =
+        pretty lang <~> format <+\> quotePurpose str
+
+instance Pretty PandocFormat where
+    pretty p = case p of
+        ReST     -> text "REST"
+        HTML     -> text "HTML"
+        LaTeX    -> text "LATEX"
+        Markdown -> text "MARKDOWN"
+
+instance Pretty Prop where
+    pretty p = text $ case p of
+                Uni -> "UNI"
+                Inj -> "INJ"
+                Sur -> "SUR"
+                Tot -> "TOT"
+                Sym -> "SYM"
+                Asy -> "ASY"
+                Trn -> "TRN"
+                Rfx -> "RFX"
+                Irf -> "IRF"
+                Aut -> "AUT"
+                Prop -> "PROP"
+
+instance Pretty PAtomPair where
+    pretty (PPair _ l r) = text "(" <+> pretty l 
+                       <~> text "," <+> pretty r 
+                       <~> text ")"
+
+instance Pretty PAtomValue where
+    pretty pav =  
+      case pav of 
+       PSingleton   _ _ mav -> case mav of
+                                Nothing  -> fatal 405 $ "The singleton "++show pav++" has no type, so it cannot be accuratly prettyprinted in a population statement."
+                                Just val -> pretty val
+       ScriptString   _ s -> text . show $ s
+       XlsxString     _ s -> text . show $ s
+       ScriptInt      _ i -> text . show $ i
+       ScriptFloat    _ d -> text . show $ d
+       XlsxDouble     _ _ -> fatal 267 $ "We got a value from an .xlsx file, which has to be shown in an expression, however the technicaltype is not known"
+       ComnBool       _ b -> text . map toUpper . show $ b
+       ScriptDate     _ x -> text . show $ x
+       ScriptDateTime _ x -> text . show $ x
+
+
+
+
src/Database/Design/Ampersand/ADL1/Rule.hs view
@@ -1,11 +1,9 @@ module Database.Design.Ampersand.ADL1.Rule 
-  (consequent, antecedent, rulefromProp, ruleviolations, conjunctViolations, hasantecedent) where
+  (consequent, antecedent, rulefromProp, 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"
@@ -14,36 +12,22 @@ hasantecedent r
  = case rrexp r of
      EEqu{} -> True
-     EImp{} -> True
+     EInc{} -> True
      _      -> False
 antecedent :: Rule -> Expression
 antecedent r
  = case rrexp r of
      EEqu (le,_) -> le
-     EImp (le,_) -> le
+     EInc (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
+     EInc (_,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
@@ -80,7 +64,8 @@                      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 (
+                     Prop -> fatal 78 "Prop should have been converted by the parser"
+        explain isPositive prop = [ A_Markup English (string2Blocks ReST (
                               case prop of
                                 Sym-> state isPositive English (name d++"["++s++"]") "symmetric"
                                 Asy-> state isPositive English (name d++"["++s++"]") "antisymmetric"
@@ -92,8 +77,9 @@                                 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"
+                                Prop -> fatal 90 "Prop should have been converted by the parser"
                                 ))
-                       ,   A_Markup Dutch ReST (string2Blocks ReST (
+                       ,   A_Markup Dutch (string2Blocks ReST (
                               case prop of
                                 Sym-> state isPositive Dutch (name d++"["++s++"]") "symmetrisch."
                                 Asy-> state isPositive Dutch (name d++"["++s++"]") "antisymmetrisch."
@@ -105,6 +91,7 @@                                 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"
+                                Prop -> fatal 103 "Prop should have been converted by pattern the parser"
                                 ))
                       ]
src/Database/Design/Ampersand/Basics/BuildInfo_Generated.hs view
@@ -4,13 +4,13 @@ 
 {-# NOINLINE cabalVersionStr #-}
 cabalVersionStr :: String
-cabalVersionStr = "3.0.3"
+cabalVersionStr = "3.1.0"
 
 {-# NOINLINE gitInfoStr #-}
 gitInfoStr :: String
-gitInfoStr = "master:5d85663*"
+gitInfoStr = "master:9683681*"
 
 {-# NOINLINE buildTimeStr #-}
 buildTimeStr :: String
-buildTimeStr = "30-Apr-15 10:43:19 West-Europa (zomertijd)"
+buildTimeStr = "11-Oct-15 20:42:12 West-Europa (zomertijd)"
src/Database/Design/Ampersand/Classes.hs view
@@ -1,11 +1,8 @@ module Database.Design.Ampersand.Classes
-   ( module Database.Design.Ampersand.Classes.Populated
-   , module Database.Design.Ampersand.Classes.ConceptStructure
+   ( 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
src/Database/Design/Ampersand/Classes/ConceptStructure.hs view
@@ -31,15 +31,15 @@   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)
+  mp1Pops :: ContextInfo -> a -> [Population]
+  mp1Pops ci struc
+   = [ ACptPopu{ 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"
+     where cpt (EMp1 _ c)   = c
+           cpt _            = fatal 31 "cpt error"
+           atm (EMp1 val c) = safePSingleton2AAtomVal ci c val
+           atm _            = fatal 31 "atm error"
            
 prim2rel :: Expression -> Declaration
 prim2rel e
@@ -64,7 +64,7 @@   expressionsIn = foldr ((uni) . expressionsIn) []
 
 instance ConceptStructure A_Context where
-  concs ctx = foldr uni []
+  concs ctx = foldr uni [ONE, PlainConcept "SESSION"]  -- ONE and [SESSION] are allways in any context. (see https://github.com/AmpersandTarski/ampersand/issues/70)
               [ (concs.ctxpats) ctx
               , (concs.ctxrs) ctx
               , (concs.ctxds) ctx
@@ -95,8 +95,8 @@   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]
+  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]
@@ -116,7 +116,7 @@                     ]
   expressionsIn _ = []
 
-instance ConceptStructure Sign where
+instance ConceptStructure Signature where
   concs (Sign s t) = nub [s,t]
   expressionsIn _  = []
 
@@ -129,10 +129,10 @@ 
 -- 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 _) = []
+  concs (Box _ _ objs)         = concs objs
+  concs InterfaceRef{}         = []
+  expressionsIn (Box _ _ objs) = expressionsIn objs
+  expressionsIn InterfaceRef{} = []
 
 instance ConceptStructure Pattern where
   concs pat = foldr uni []
@@ -172,8 +172,8 @@   expressionsIn (PairView ps) = expressionsIn ps
 
 instance ConceptStructure Population where
-  concs pop@PRelPopu{} = concs (popdcl pop)
-  concs pop@PCptPopu{} = concs (popcpt pop)
+  concs pop@ARelPopu{} = concs (popdcl pop)
+  concs pop@ACptPopu{} = concs (popcpt pop)
   expressionsIn _    = []
 
 instance ConceptStructure Purpose where
− src/Database/Design/Ampersand/Classes/Populated.hs 
@@ -1,99 +0,0 @@-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
@@ -125,7 +125,7 @@  isTrue expr
   = case expr of
      EEqu (l,r) -> l == r
-     EImp (l,_) -> isTrue l
+     EInc (l,_) -> isTrue l
      EIsc (l,r) -> isTrue l && isTrue r
      EUni (l,r) -> isTrue l || isTrue r
      EDif (l,r) -> isTrue l && isFalse r
@@ -150,7 +150,7 @@  isFalse expr
   = case expr of
      EEqu (l,r) -> l == notCpl r
-     EImp (_,r) -> isFalse r
+     EInc (_,r) -> isFalse r
      EIsc (l,r) -> isFalse r || isFalse l
      EUni (l,r) -> isFalse r && isFalse l
      EDif (l,r) -> isFalse l || isTrue r
@@ -173,8 +173,8 @@  --    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?
+     EEqu (l,r) -> isIdent (EIsc (EInc (l,r), EInc (r,l)))    -- TODO: maybe derive something better?
+     EInc (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
@@ -194,8 +194,8 @@                 _      -> 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?
+     EEqu (l,r) -> isImin (EIsc (EInc (l,r), EInc (r,l)))       -- TODO: maybe derive something better?
+     EInc (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
src/Database/Design/Ampersand/Classes/ViewPoint.hs view
@@ -49,8 +49,8 @@             , 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)
+                         [ A_Markup English (string2Blocks ReST meaningEN)
+                         , A_Markup Dutch (string2Blocks ReST meaningNL)
                          ]
             , rrmsg  = []
             , rrviol = Nothing
src/Database/Design/Ampersand/Components.hs view
@@ -5,14 +5,6 @@      makeFSpec
     -- * Generators of output
    , generateAmpersandOutput
---   , doGenADL
---   , doGenProofs
---   , doGenHaskell
---   , doGenXML
---   , doGenUML
---   , doGenDocument
---   , doGenFPAExcel
-    -- * etc...
   )
 where
 import Prelude hiding (putStr,readFile,writeFile)
@@ -22,10 +14,12 @@ 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.Graphic.Graphics (writePicture)
 import Database.Design.Ampersand.Output
 import Control.Monad
 import System.FilePath
+import System.Time
+import qualified Data.ByteString.Lazy as L
 
 fatal :: Int -> String -> a
 fatal = fatalMsg "Components"
@@ -34,12 +28,12 @@ --    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
+ do { 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 (genPOPExcel (getOpts fSpec)) $ doGenPopsXLSX 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)
@@ -81,14 +75,6 @@     }
  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..."
@@ -106,7 +92,7 @@  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) $
+    ; when (not(null thePictures) && fspecFormat (getOpts fSpec)/=FPandoc) $
         mapM_ (writePicture (getOpts fSpec)) thePictures
      -- postProcessing of the generated output file depends on the format:
     ; postProcessor
@@ -122,7 +108,20 @@ -- | 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))
+ do { verboseLn (getOpts fSpec) "Generating Excel containing FPA..."
+    ; writeFile outputFile $ fspec2FPA_Excel fSpec
     }
    where outputFile = combine (dirOutput (getOpts fSpec)) $ replaceExtension ("FPA_"++baseName (getOpts fSpec)) ".xml"  -- Do not use .xls here, because that generated document contains xml.
+
+doGenPopsXLSX :: FSpec -> IO()
+doGenPopsXLSX fSpec =
+ do { verboseLn (getOpts fSpec) "Generating .xlsx file containing the population "
+    ; ct <- getClockTime
+    ; L.writeFile outputFile $ fSpec2PopulationXlsx ct fSpec
+    ; Prelude.putStrLn $ "Generated file: " ++ outputFile
+    }
+   where outputFile = combine (dirOutput (getOpts fSpec)) $ replaceExtension (baseName (getOpts fSpec)++ "_generated_pop") ".xlsx"
+
+    
+   
+
+ src/Database/Design/Ampersand/Core/A2P_Converters.hs view
@@ -0,0 +1,346 @@+module Database.Design.Ampersand.Core.A2P_Converters (
+  aCtx2pCtx
+  , aAtomValue2pAtomValue
+) 
+where
+import Database.Design.Ampersand.ADL1.Expression
+import Database.Design.Ampersand.Basics
+import Database.Design.Ampersand.Core.ParseTree
+import Database.Design.Ampersand.Core.AbstractSyntaxTree
+import Data.Maybe
+
+fatal :: Int -> String -> a
+fatal = fatalMsg "A2P_Converters"
+
+
+
+aCtx2pCtx :: A_Context -> P_Context
+aCtx2pCtx ctx = 
+ PCtx { ctx_nm     = ctxnm ctx
+      , ctx_pos    = ctxpos ctx
+      , ctx_lang   = ctxlang ctx
+      , ctx_markup = Just $ ctxmarkup ctx
+      , ctx_thms   = ctxthms ctx 
+      , ctx_pats   = map aPattern2pPattern . ctxpats $ ctx
+      , ctx_rs     = map aRule2pRule . ctxrs $ ctx
+      , ctx_ds     = map aDeclaration2pDeclaration . ctxds $ ctx
+      , ctx_cs     = ctxcds ctx
+      , ctx_ks     = map aIdentityDef2pIdentityDef . ctxks $ ctx
+      , ctx_rrules = map aRoleRule2pRoleRule  .ctxrrules $ ctx
+      , ctx_rrels  = map aRoleRelation2pRoleRelation . ctxRRels $ ctx
+      , ctx_reprs  = ctxreprs ctx
+      , ctx_vs     = map aViewDef2pViewDef . ctxvs $ ctx
+      , ctx_gs     = map aGen2pGen . ctxgs $ ctx
+      , ctx_ifcs   = map aInterface2pInterface . ctxifcs $ ctx
+      , ctx_ps     = catMaybes . map aPurpose2pPurpose . ctxps $ ctx
+      , ctx_pops   = map aPopulation2pPopulation . ctxpopus $ ctx
+      , ctx_sql    = map aObjectDef2pObjectDef . ctxsql $ ctx
+      , ctx_php    = map aObjectDef2pObjectDef . ctxphp $ ctx
+      , ctx_metas  = ctxmetas ctx
+      }
+
+aPattern2pPattern :: Pattern -> P_Pattern
+aPattern2pPattern pat = 
+ P_Pat { pt_pos   = ptpos pat
+       , pt_nm    = ptnm pat
+       , pt_rls   = map aRule2pRule (ptrls pat)
+       , pt_gns   = map aGen2pGen (ptgns pat)
+       , pt_dcs   = map aDeclaration2pDeclaration (ptdcs pat)
+       , pt_RRuls = [] --TODO: should this be empty? There is nothing in the A-structure
+       , pt_RRels = [] --TODO: should this be empty? There is nothing in the A-structure
+       , pt_cds   = [] --TODO: should this be empty? There is nothing in the A-structure
+       , pt_Reprs = [] --TODO: should this be empty? There is nothing in the A-structure
+       , pt_ids   = map aIdentityDef2pIdentityDef (ptids pat)
+       , pt_vds   = map aViewDef2pViewDef (ptvds pat)
+       , pt_xps   = catMaybes . map aPurpose2pPurpose . ptxps $ pat
+       , pt_pop   = map aPopulation2pPopulation . ptups $ pat
+       , pt_end   = ptend pat
+       }
+
+aRule2pRule :: Rule -> P_Rule TermPrim
+aRule2pRule rul =
+ P_Ru { rr_fps  = rrfps rul
+      , rr_nm   = rrnm rul
+      , rr_exp  = aExpression2pTermPrim (rrexp rul)
+      , rr_mean = aMeaning2pMeaning (rrmean rul)
+      , rr_msg  = map aMarkup2pMessage (rrmsg rul)
+      , rr_viol = fmap aPairView2pPairView (rrviol rul)
+      }
+
+aDeclaration2pDeclaration :: Declaration -> P_Declaration
+aDeclaration2pDeclaration dcl = 
+ P_Sgn { dec_nm     = decnm dcl
+       , dec_sign   = aSign2pSign (decsgn dcl)
+       , dec_prps   = decprps dcl
+       , dec_pragma = [decprL dcl, decprM dcl, decprR dcl]
+       , dec_Mean   = aMeaning2pMeaning (decMean dcl)
+       , dec_popu   = [] --TODO: should this be empty? There is nothing in the A-structure
+       , dec_fpos   = decfpos dcl
+       , dec_plug   = decplug dcl
+       }
+
+aDeclaration2pNamedRel :: Declaration -> P_NamedRel
+aDeclaration2pNamedRel dcl =
+ PNamedRel (decfpos dcl) (decnm dcl) (Just (aSign2pSign (decsgn dcl)))
+ 
+aIdentityDef2pIdentityDef :: IdentityDef -> P_IdentDf TermPrim -- P_IdentDef
+aIdentityDef2pIdentityDef iDef =
+ P_Id { ix_pos = idPos iDef
+      , ix_lbl = idLbl iDef
+      , ix_cpt = aConcept2pConcept (idCpt iDef)
+      , ix_ats = map aIdentitySegment2pIdentSegmnt (identityAts iDef)
+      }
+
+aRoleRule2pRoleRule :: A_RoleRule -> P_RoleRule
+aRoleRule2pRoleRule rr =
+ Maintain { mPos   = arPos rr
+          , mRoles = arRoles rr
+          , mRules = arRules rr
+          }
+
+aRoleRelation2pRoleRelation :: A_RoleRelation -> P_RoleRelation
+aRoleRelation2pRoleRelation rr =
+ P_RR { rr_Pos   = rrPos rr
+      , rr_Roles = rrRoles rr
+      , rr_Rels  = map aDeclaration2pNamedRel (rrRels rr)
+      }
+
+aViewDef2pViewDef :: ViewDef -> P_ViewDef
+aViewDef2pViewDef vDef =
+ P_Vd { vd_pos       = vdpos vDef
+      , vd_lbl       = vdlbl vDef
+      , vd_cpt       = aConcept2pConcept (vdcpt vDef)
+      , vd_isDefault = vdIsDefault vDef
+      , vd_html      = vdhtml vDef
+      , vd_ats       = map aViewSegment2pViewSegmt (vdats vDef)
+      }
+
+aGen2pGen :: A_Gen -> P_Gen
+aGen2pGen gen =
+ case gen of
+  Isa{} -> PGen { gen_fp  = fatal 115 "Origin is not present in A_Gen"
+                , gen_spc = aConcept2pConcept (genspc gen)
+                , gen_gen = aConcept2pConcept (gengen gen)
+                }
+  IsE{} -> P_Cy { gen_fp  = fatal 119 "Origin is not present in A_Gen"
+                , gen_spc = aConcept2pConcept (genspc gen)
+                , gen_rhs = map aConcept2pConcept (genrhs gen)
+                }
+
+aInterface2pInterface :: Interface -> P_Interface
+aInterface2pInterface ifc =
+ P_Ifc { ifc_Name   = name ifc
+       , ifc_Class  = ifcClass ifc
+       , ifc_Params = map aDeclaration2pNamedRel (ifcParams ifc)
+       , ifc_Args   = ifcArgs ifc
+       , ifc_Roles  = ifcRoles ifc
+       , ifc_Obj    = aObjectDef2pObjectDef (ifcObj ifc)
+       , ifc_Pos    = ifcPos ifc
+       , ifc_Prp    = ifcPrp ifc
+       }
+
+
+aSign2pSign :: Signature -> P_Sign
+aSign2pSign sgn =
+ P_Sign { pSrc = aConcept2pConcept (source sgn)
+        , pTgt = aConcept2pConcept (target sgn)
+        }
+
+aConcept2pConcept :: A_Concept -> P_Concept
+aConcept2pConcept cpt =
+ case cpt of
+   ONE            -> P_Singleton
+   PlainConcept{} -> PCpt { p_cptnm = cptnm cpt
+                          }
+
+aPurpose2pPurpose :: Purpose -> Maybe PPurpose 
+aPurpose2pPurpose p = 
+ if explUserdefd p
+ then Just $
+   PRef2 { pexPos    = explPos p
+         , pexObj    = aExplObj2PRef2Obj (explObj p)
+         , pexMarkup = aMarkup2pMarkup (explMarkup p)
+         , pexRefIDs = explRefIds p
+         }
+ else Nothing 
+
+aPopulation2pPopulation :: Population -> P_Population
+aPopulation2pPopulation p =
+ case p of 
+  ARelPopu{} -> P_RelPopu { p_orig  = fatal 174 "Origin is not present in Population"
+                          , p_nmdr  = aDeclaration2pNamedRel (popdcl p)
+                          , p_popps = map aAtomPair2pAtomPair (popps p)
+                          }
+  ACptPopu{} -> P_CptPopu { p_orig  = fatal 178 "Origin is not present in Population"
+                          , p_cnme  = name (popcpt p)
+                          , p_popas = map aAtomValue2pAtomValue (popas p)
+                          }
+
+aObjectDef2pObjectDef :: ObjectDef -> P_ObjectDef
+aObjectDef2pObjectDef oDef =
+ P_Obj { obj_nm    = objnm oDef
+       , obj_pos   = objpos oDef
+       , obj_ctx   = aExpression2pTermPrim (objctx oDef)
+       , obj_mView = objmView oDef
+       , obj_msub  = fmap aSubIfc2pSubIfc (objmsub oDef)
+       , obj_strs  = objstrs oDef
+       }
+
+aExpression2pTermPrim :: Expression -> Term TermPrim
+aExpression2pTermPrim expr = 
+  case expr of
+    EEqu (l,r)   -> PEqu o (aExpression2pTermPrim l) (aExpression2pTermPrim r)  
+    EInc (l,r)   -> PInc o (aExpression2pTermPrim l) (aExpression2pTermPrim r)
+    EIsc (l,r)   -> PIsc o (aExpression2pTermPrim l) (aExpression2pTermPrim r)
+    EUni (l,r)   -> PUni o (aExpression2pTermPrim l) (aExpression2pTermPrim r)
+    EDif (l,r)   -> PDif o (aExpression2pTermPrim l) (aExpression2pTermPrim r)
+    ELrs (l,r)   -> PLrs o (aExpression2pTermPrim l) (aExpression2pTermPrim r)
+    ERrs (l,r)   -> PRrs o (aExpression2pTermPrim l) (aExpression2pTermPrim r)
+    EDia (l,r)   -> PDia o (aExpression2pTermPrim l) (aExpression2pTermPrim r)
+    ECps (l,r) 
+      | isEEps l  -> aExpression2pTermPrim r
+      | isEEps r  -> aExpression2pTermPrim l
+      | otherwise -> PCps o (aExpression2pTermPrim l) (aExpression2pTermPrim r)
+    ERad (l,r)   -> PRad o (aExpression2pTermPrim l) (aExpression2pTermPrim r)
+    EPrd (l,r)   -> PPrd o (aExpression2pTermPrim l) (aExpression2pTermPrim r)
+    EEps _ _     -> fatal 217 $ "EEps is only expected inside an ECps."
+    EKl0 e       -> PKl0 o (aExpression2pTermPrim e)
+    EKl1 e       -> PKl1 o (aExpression2pTermPrim e)
+    EFlp e       -> PFlp o (aExpression2pTermPrim e)
+    ECpl e       -> PCpl o (aExpression2pTermPrim e)
+    EBrk e       -> PBrk o (aExpression2pTermPrim e)
+    EDcD dcl     -> Prim . PNamedR . PNamedRel (origin dcl) (name dcl) . Just . aSign2pSign . sign $ dcl
+    EDcI cpt     -> Prim . Pid o . aConcept2pConcept $ cpt
+    EDcV sgn     -> Prim . Pfull o (aConcept2pConcept . source $ sgn) . aConcept2pConcept . target $ sgn
+    EMp1 val cpt -> Prim . Patm o val . Just . aConcept2pConcept $ cpt
+  where 
+   o = fatal 199 "Origin is not present in Expression"
+
+
+aMeaning2pMeaning :: AMeaning -> [PMeaning]
+aMeaning2pMeaning m = map (PMeaning . aMarkup2pMarkup) (ameaMrk m)
+
+aMarkup2pMessage :: A_Markup -> PMessage
+aMarkup2pMessage m = (PMessage . aMarkup2pMarkup) m
+
+aMarkup2pMarkup :: A_Markup -> P_Markup
+aMarkup2pMarkup markup =
+ P_Markup  { mLang   = Just $ amLang markup
+           , mFormat = Just ReST
+           , mString = aMarkup2String  ReST markup
+           } 
+
+aPairView2pPairView :: PairView Expression -> PairView (Term TermPrim)
+aPairView2pPairView pv =
+ PairView { ppv_segs = map aPairViewSegment2pPairViewSegment (ppv_segs pv)
+          }
+
+aPairViewSegment2pPairViewSegment :: PairViewSegment Expression -> PairViewSegment (Term TermPrim)
+aPairViewSegment2pPairViewSegment segment =
+ case segment of 
+  PairViewText{} -> PairViewText{ pvsOrg = pvsOrg segment
+                                , pvsStr = pvsStr segment
+                                }
+  PairViewExp{}  -> PairViewExp { pvsOrg = pvsOrg segment
+                                , pvsSoT = pvsSoT segment
+                                , pvsExp = aExpression2pTermPrim (pvsExp segment)
+                                }
+
+aIdentitySegment2pIdentSegmnt :: IdentitySegment -> P_IdentSegmnt TermPrim
+aIdentitySegment2pIdentSegmnt (IdentityExp oDef) =
+ P_IdentExp  { ks_obj = aObjectDef2pObjectDef oDef
+             }
+
+aViewSegment2pViewSegmt :: ViewSegment -> P_ViewSegmt TermPrim
+aViewSegment2pViewSegmt segment =
+ case segment of
+  ViewExp{}  -> P_ViewExp  { vs_nr  = vsgmNr segment
+                           , vs_obj = aObjectDef2pObjectDef (vsgmObj segment)
+                           }
+  ViewText{} -> P_ViewText { vs_nr  = vsgmNr segment
+                           , vs_txt = vsgmTxt segment
+                           }
+  ViewHtml{} -> P_ViewHtml { vs_nr  = vsgmNr segment
+                           , vs_htm = vsgmHtml segment
+                           }
+
+aExplObj2PRef2Obj :: ExplObj -> PRef2Obj
+aExplObj2PRef2Obj obj =
+ case obj of
+  ExplConceptDef cd   -> PRef2ConceptDef (name cd)
+  ExplDeclaration d   -> PRef2Declaration (aDeclaration2pNamedRel d)
+  ExplRule str        -> PRef2Rule str
+  ExplIdentityDef str -> PRef2IdentityDef str
+  ExplViewDef str     -> PRef2ViewDef str
+  ExplPattern str     -> PRef2Pattern str
+  ExplInterface str   -> PRef2Interface str
+  ExplContext str     -> PRef2Context str
+
+aAtomPair2pAtomPair :: AAtomPair -> PAtomPair
+aAtomPair2pAtomPair pr =
+ PPair { pppos   = fatal 280 "Origin is not present in AAtomPair"
+       , ppLeft  = aAtomValue2pAtomValue (apLeft pr)
+       , ppRight = aAtomValue2pAtomValue (apRight pr)
+       }
+
+aAtomValue2pAtomValue :: AAtomValue -> PAtomValue
+aAtomValue2pAtomValue AtomValueOfONE = fatal 286 "Unexpected AtomValueOfONE in convertion to P-structure"
+aAtomValue2pAtomValue val =
+  case aavtyp val of
+    Alphanumeric     -> case val of 
+                          AAVString{} -> ScriptString o (aavstr val)
+                          _         -> fatal 291 "Unexpected combination of value types"
+    BigAlphanumeric  -> case val of 
+                          AAVString{} -> ScriptString o (aavstr val)
+                          _         -> fatal 294 "Unexpected combination of value types"
+    HugeAlphanumeric -> case val of 
+                          AAVString{} -> ScriptString o (aavstr val)
+                          _         -> fatal 297 "Unexpected combination of value types"
+    Password         -> case val of 
+                          AAVString{} -> ScriptString o (aavstr val)
+                          _         -> fatal 300 "Unexpected combination of value types"
+    Binary           -> fatal 293 $ show (aavtyp val) ++ " cannot be represented in P-structure currently."
+    BigBinary        -> fatal 294 $ show (aavtyp val) ++ " cannot be represented in P-structure currently."
+    HugeBinary       -> fatal 295 $ show (aavtyp val) ++ " cannot be represented in P-structure currently."
+    Date             -> case val of
+                          AAVDate{} -> --TODO: Needs rethinking. A string or a double?
+                                       ScriptString o (showValADL val)
+                          _         -> fatal 307 "Unexpected combination of value types"
+    DateTime         -> case val of
+                          AAVDateTime{} -> --TODO: Needs rethinking. A string or a double?
+                                       ScriptString o (showValADL val)
+                          _         -> fatal 311 "Unexpected combination of value types"
+    Integer          -> case val of
+                          AAVInteger{} -> XlsxDouble o (fromInteger (aavint val))
+                          _            -> fatal 314 "Unexpected combination of value types"
+    Float            -> case val of
+                          AAVFloat{}   -> XlsxDouble o (aavflt val)
+                          _            -> fatal 317 "Unexpected combination of value types"
+    Boolean          -> case val of 
+                          AAVBoolean{} -> ComnBool o (aavbool val)
+                          _            -> fatal 320 "Unexpected combination of value types"
+    Object           -> case val of 
+                          AAVString{} -> ScriptString o (aavstr val)
+                          _         -> fatal 323 "Unexpected combination of value types"
+    TypeOfOne        -> fatal 324 "Unexpected combination of value types"
+  where
+   o = fatal 289 "Origin is not present in AAtomValue"
+
+aSubIfc2pSubIfc :: SubInterface -> P_SubIfc TermPrim
+aSubIfc2pSubIfc sub =
+ case sub of
+  Box _ mStr objs  
+    -> P_Box          { si_ori   = fatal 295 "Origin is not present in SubInterface"
+                      , si_class = mStr
+                      , si_box   = map aObjectDef2pObjectDef objs
+                      }
+  InterfaceRef isLinkto str 
+    -> P_InterfaceRef { si_ori    = fatal 295 "Origin is not present in SubInterface"
+                      , si_isLink = isLinkto
+                      , si_str    = str
+                      }
+
+
+
+
+
src/Database/Design/Ampersand/Core/AbstractSyntaxTree.hs view
@@ -3,6 +3,7 @@ {-# LANGUAGE DeriveGeneric #-}
 module Database.Design.Ampersand.Core.AbstractSyntaxTree (
    A_Context(..)
+ , Typology(..)
  , Meta(..)
  , Pattern(..)
  , PairView(..)
@@ -32,34 +33,42 @@  , AMeaning(..)
  , A_RoleRule(..)
  , A_RoleRelation(..)
- , Sign(..)
+ , Representation(..), TType(..), contextInfoOf
+ , unsafePAtomVal2AtomValue, safePSingleton2AAtomVal
+ , Signature(..)
  , Population(..)
- , GenR
  , Association(..)
  , PAclause(..), Event(..), ECArule(..), InsDel(..), Conjunct(..), DnfClause(..)
+ , AAtomPair(..), AAtomValue(..), mkAtomPair, ContextInfo(..), representationOf, PAtomValue(..)
+ , showValADL,showValPHP,showValSQL
   -- (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)
+                                                , PairView(..),PairViewSegment(..),Prop(..),Lang, PandocFormat, P_Markup(..), PMeaning(..)
+                                                , SrcOrTgt(..), isSrc , Representation(..), TType(..), PAtomValue(..), PSingleton, makePSingleton
+                                                )
+import Database.Design.Ampersand.Core.Poset (Poset(..), Sortable(..),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.List (intercalate)
 import Data.Typeable
 import GHC.Generics (Generic)
+import Data.Data
 import Data.Hashable
+import Data.Char (toUpper,toLower)
+import Data.Maybe
+import Data.Time.Calendar
+import Data.Time.Clock
+import qualified System.Locale as SL (defaultTimeLocale)
+import qualified Data.Time.Format as DTF (formatTime,readTime)
 
 fatal :: Int -> String -> a
 fatal = fatalMsg "Core.AbstractSyntaxTree"
@@ -78,6 +87,7 @@          , 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)
+         , ctxreprs :: [Representation]
          , 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
@@ -115,7 +125,7 @@            , 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
+           }   deriving (Typeable)    -- Show for debugging purposes
 instance Eq Pattern where
   p==p' = ptnm p==ptnm p'
 instance Unique Pattern where
@@ -128,31 +138,30 @@ 
 
 data A_RoleRule = A_RoleRule { arRoles :: [Role]
-                             , arRules  :: [String] -- the names of the rules 
-                             , arPos   :: Origin 
+                             , 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)
+             } deriving (Show, Eq, Prelude.Ord, Typeable, Data)
 
 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
+                | 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
+     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 ::    Signature                   -- ^ Allocated signature
+        , 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'
@@ -178,12 +187,12 @@                              -- 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 RuleType = Inclusion | Equivalence | Truth  deriving (Eq,Show)
 
-data Conjunct = Cjct { rc_id         :: String -- string that identifies this conjunct ('id' rather than 'name', because 
+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_orgRules ::   [Rule] -- All rules this conjunct originates from
+                     , rc_conjunct ::   Expression
                      , rc_dnfClauses :: [DnfClause]
                      } deriving (Show,Typeable)
 
@@ -191,6 +200,10 @@                      , conss :: [Expression]
                      }  deriving (Show, Eq) -- Show is for debugging purposes only.
 
+{- The intended semantics of |Dnf ns ps| is the disjunction |foldr1 ( .\/. ) (map notCpl ns ++ ps)|. 
+   The list |ns| and |ps| are not guaranteed to be sorted or duplicate-free.
+-}
+ 
 instance Eq Conjunct where
   rc==rc' = rc_id rc==rc_id rc'
 instance Unique Conjunct where
@@ -199,33 +212,49 @@   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
+  Sgn { decnm :: String              -- ^ the name of the declaration
+      , decsgn :: Signature          -- ^ 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 :: [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.
+      , 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)
+      , 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.
+      , 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)
+      { decsgn :: Signature
+      } deriving (Typeable, Data)
 
 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 Ord Declaration where
+  compare a b =
+    case a of
+      Sgn{} -> case b of
+                Sgn{} -> if name a == name b 
+                         then Prelude.compare (sign a) (sign b)
+                         else Prelude.compare (name a) (name b)
+                Isn{} -> GT
+                Vs{}  -> GT
+      Isn{} -> case b of
+                Sgn{} -> LT
+                Isn{} -> Prelude.compare (sign a) (sign b)
+                Vs{}  -> GT
+      Vs{}  -> case b of 
+                Sgn{} -> LT
+                Isn{} -> LT
+                Vs{}  -> Prelude.compare (sign a) (sign b)
 instance Unique Declaration where
   showUnique d = 
     case d of
@@ -247,25 +276,14 @@                   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)
+aMarkup2String :: PandocFormat -> A_Markup -> String
+aMarkup2String fmt a = blocks2String fmt False (amPandoc a)
 
-data AMeaning = AMeaning { ameaMrk ::[A_Markup]} deriving (Show, Eq, Prelude.Ord)
+data AMeaning = AMeaning { ameaMrk ::[A_Markup]} deriving (Show, Eq, Prelude.Ord, Typeable, Data)
 
 instance Named Declaration where
   name d@Sgn{}   = decnm d
@@ -306,7 +324,15 @@ instance Traced ViewDef where
   origin = vdpos
 
-data ViewSegment = ViewExp ObjectDef | ViewText String | ViewHtml String deriving (Eq, Show)
+data ViewSegment = ViewExp { vsgmNr   :: Integer
+                           , vsgmObj  :: ObjectDef
+                           }
+                 | ViewText{ vsgmNr   :: Integer
+                           , vsgmTxt  :: String
+                           } 
+                 | ViewHtml{ vsgmNr   :: Integer
+                           , vsgmHtml :: String
+                           } deriving (Eq, Show)
 
 
 -- | data structure A_Gen contains the CLASSIFY statements from an Ampersand script
@@ -330,39 +356,15 @@      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]
+data Interface = Ifc { ifcParams ::   [Declaration] -- all relations that can be edited in this interface
                      , 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
+                     , ifcRoles ::    [Role]        -- all roles for which an interface is available (empty means: available for all roles)
+                     , ifcObj ::      ObjectDef     -- NOTE: this top-level ObjectDef is contains the interface itself (ie. name and expression)
+                     , ifcEcas ::     [ECArule]     -- All ECArules that are needed to perform computations for maintaining rules
+                     , ifcControls :: [Conjunct]    -- All conjuncts that must be evaluated after a transaction
+                     , ifcPos ::      Origin        -- The position in the file (filename, line- and column number)
+                     , ifcPrp ::      String        -- The purpose of the interface
                      } deriving Show
 
 instance Eq Interface where
@@ -383,7 +385,7 @@ objAts obj
   = case objmsub obj of
      Nothing       -> []
-     Just (InterfaceRef _) -> []
+     Just (InterfaceRef _ _) -> []
      Just (Box _ _ objs)     -> objs
 
 class Object a where
@@ -396,19 +398,21 @@  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)
+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 SubInterface = Box A_Concept (Maybe String) [ObjectDef] 
+                  | InterfaceRef Bool -- is LINKTO? 
+                                 String deriving (Eq, Show)
 
 data InsDel   = Ins | Del
                  deriving (Show,Eq)
@@ -444,11 +448,11 @@                     , paMotiv :: [(Expression,[Rule] )]
                     }
               | New { paCpt :: A_Concept                  -- make a new instance of type c
-                    , paCl :: String->PAclause            -- to be done after creating the concept
+                    , paCl :: PSingleton ->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
+                    , paCl :: PSingleton->PAclause            -- to be done afteremoving the concept
                     , paMotiv :: [(Expression,[Rule] )]
                     }
               | Nop { paMotiv :: [(Expression,[Rule] )]   -- tells which conjunct from whichule is being maintained
@@ -491,13 +495,81 @@   origin = explPos
 
 data Population -- The user defined populations
-  = PRelPopu { popdcl :: Declaration
-             , popps ::  Pairs     -- The user-defined pairs that populate the relation
+  = ARelPopu { popdcl :: Declaration
+             , popps ::  [AAtomPair]     -- The user-defined pairs that populate the relation
+             , popsrc :: A_Concept -- potentially more specific types than the type of Declaration
+             , poptgt :: A_Concept
              }
-  | PCptPopu { popcpt :: A_Concept
-             , popas ::  [String]  -- The user-defined atoms that populate the concept
-             } deriving (Show, Eq)
+  | ACptPopu { popcpt :: A_Concept
+             , popas ::  [AAtomValue]  -- The user-defined atoms that populate the concept
+             } deriving (Eq)
 
+data AAtomPair 
+  = APair { apLeft  :: AAtomValue
+          , apRight :: AAtomValue
+          }deriving(Eq,Prelude.Ord)
+mkAtomPair :: AAtomValue -> AAtomValue -> AAtomPair
+mkAtomPair = APair
+data AAtomValue
+  = AAVString  { aavtyp :: TType
+               , aavstr :: String
+               }
+  | AAVInteger { aavtyp :: TType
+               , aavint :: Integer
+               }
+  | AAVFloat   { aavtyp :: TType
+               , aavflt :: Double
+               }
+  | AAVBoolean { aavtyp :: TType
+               , aavbool :: Bool
+               }
+  | AAVDate { aavtyp :: TType
+            , aadateDay ::  Day
+            }
+  | AAVDateTime { aavtyp :: TType
+                , aadatetime ::  UTCTime
+                }
+  | AtomValueOfONE deriving (Eq,Prelude.Ord)
+showValPHP :: AAtomValue -> String
+showValPHP val =
+  case val of
+   AAVString{}  -> "'"++f (aavstr val)++"'" 
+     where 
+        f str'= 
+          case str' of
+            []        -> []
+            ('\'':cs) -> "\\\'"++ f cs  --This is required to ensure that the result of showValue will be a proper singlequoted string.
+            ('\\':s') -> "\\\\" ++ f s'
+            (c:cs)    -> c : f cs
+   AAVInteger{} -> show (aavint val)
+   AAVBoolean{} -> show (aavbool val)
+   AAVDate{}    -> "'"++showGregorian (aadateDay val)++"'"
+   AAVDateTime {} -> "'"++DTF.formatTime SL.defaultTimeLocale "%F %T" (aadatetime val)++"'" --NOTE: MySQL 5.5 does not comply to ISO standard. This format is MySQL specific
+     --formatTime SL.defaultTimeLocale "%FT%T%QZ" (aadatetime val)
+   AAVFloat{}   -> show (aavflt val)
+   AtomValueOfONE{} -> "1"
+showValSQL :: AAtomValue -> String
+showValSQL val =
+  case val of
+   AAVString{}  -> aavstr val 
+   AAVInteger{} -> show (aavint val)
+   AAVBoolean{} -> show (aavbool val)
+   AAVDate{}    -> showGregorian (aadateDay val)
+   AAVDateTime {} -> "'"++DTF.formatTime SL.defaultTimeLocale "%F %T" (aadatetime val)++"'" --NOTE: MySQL 5.5 does not comply to ISO standard. This format is MySQL specific
+     --formatTime SL.defaultTimeLocale "%FT%T%QZ" (aadatetime val)
+   AAVFloat{}   -> show (aavflt val)
+   AtomValueOfONE{} -> "1"
+showValADL :: AAtomValue -> String
+showValADL val = 
+  case val of
+   AAVString{}  ->      (aavstr val)
+   AAVInteger{} -> show (aavint val)
+   AAVBoolean{} -> show (aavbool val)
+   AAVDate{}    -> showGregorian (aadateDay val)
+   AAVDateTime {} -> DTF.formatTime SL.defaultTimeLocale "%FT%T%QZ" (aadatetime val)
+   AAVFloat{}   -> show (aavflt val)
+   AtomValueOfONE{} -> "1"
+ 
 data ExplObj = ExplConceptDef ConceptDef
              | ExplDeclaration Declaration
              | ExplRule String
@@ -521,7 +593,7 @@      
 data Expression
       = EEqu (Expression,Expression)   -- ^ equivalence             =
-      | EImp (Expression,Expression)   -- ^ implication             |-
+      | EInc (Expression,Expression)   -- ^ inclusion               |-
       | EIsc (Expression,Expression)   -- ^ intersection            /\
       | EUni (Expression,Expression)   -- ^ union                   \/
       | EDif (Expression,Expression)   -- ^ difference              -
@@ -538,20 +610,47 @@       | 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)
+      | EEps A_Concept Signature       -- ^ Epsilon relation (introduced by the system to ensure we compare concepts by equality only.
+      | EDcV Signature                 -- ^ Cartesian product relation
+      | EMp1 PSingleton A_Concept      -- ^ constant PAtomValue, because when building the Expression, the TType of the concept isn't known yet. 
+      deriving (Eq, Prelude.Ord, Show, Typeable, Generic, Data)
 instance Unique Expression where
   showUnique = show
-(.==.), (.|-.), (./\.), (.\/.), (.-.), (./.), (.\.), (.<>.), (.:.), (.!.), (.*.) :: Expression -> Expression -> Expression
-instance Hashable Expression
+instance Hashable Expression where
+   hashWithSalt s expr = 
+     s `hashWithSalt` 
+       case expr of
+        EEqu (a,b) -> ( 0::Int) `hashWithSalt` a `hashWithSalt` b
+        EInc (a,b) -> ( 1::Int) `hashWithSalt` a `hashWithSalt` b
+        EIsc (a,b) -> ( 2::Int) `hashWithSalt` a `hashWithSalt` b
+        EUni (a,b) -> ( 3::Int) `hashWithSalt` a `hashWithSalt` b
+        EDif (a,b) -> ( 4::Int) `hashWithSalt` a `hashWithSalt` b
+        ELrs (a,b) -> ( 5::Int) `hashWithSalt` a `hashWithSalt` b
+        ERrs (a,b) -> ( 6::Int) `hashWithSalt` a `hashWithSalt` b
+        EDia (a,b) -> ( 7::Int) `hashWithSalt` a `hashWithSalt` b
+        ECps (a,b) -> ( 8::Int) `hashWithSalt` a `hashWithSalt` b
+        ERad (a,b) -> ( 9::Int) `hashWithSalt` a `hashWithSalt` b
+        EPrd (a,b) -> (10::Int) `hashWithSalt` a `hashWithSalt` b
+        EKl0 e     -> (11::Int) `hashWithSalt` e
+        EKl1 e     -> (12::Int) `hashWithSalt` e
+        EFlp e     -> (13::Int) `hashWithSalt` e
+        ECpl e     -> (14::Int) `hashWithSalt` e
+        EBrk e     -> (15::Int) `hashWithSalt` e
+        EDcD d     -> (16::Int) `hashWithSalt` d
+        EDcI c     -> (17::Int) `hashWithSalt` c
+        EEps c sgn -> (18::Int) `hashWithSalt` c `hashWithSalt` sgn
+        EDcV sgn   -> (19::Int) `hashWithSalt` sgn
+        EMp1 val c -> (21::Int) `hashWithSalt` show val `hashWithSalt` c        
+
 instance Unique (PairView Expression) where
   showUnique = show
 instance Unique (PairViewSegment Expression) where
   showUnique = show
+
+
+(.==.), (.|-.), (./\.), (.\/.), (.-.), (./.), (.\.), (.<>.), (.:.), (.!.), (.*.) :: Expression -> Expression -> Expression
 infixl 1 .==.   -- equivalence
-infixl 1 .|-.   -- implication
+infixl 1 .|-.   -- inclusion
 infixl 2 ./\.   -- intersection
 infixl 2 .\/.   -- union
 infixl 4 .-.    -- difference
@@ -566,7 +665,7 @@ 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)
+           EInc (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
@@ -594,7 +693,7 @@ 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)
+               EInc (l,r) -> EInc (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)
@@ -617,7 +716,7 @@ 
 instance Association Expression where
  sign (EEqu (l,r)) = Sign (source l) (target r)
- sign (EImp (l,r)) = Sign (source l) (target r)
+ sign (EInc (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)
@@ -684,7 +783,7 @@    = 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)
+    deriving (Prelude.Ord,Typeable,Data)
 
 instance Eq A_Concept where
    PlainConcept{cptnm=a} == PlainConcept{cptnm=b} = a==b
@@ -705,53 +804,259 @@ 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
+data Signature = Sign A_Concept A_Concept deriving (Eq, Prelude.Ord, Typeable, Generic, Data)
+instance Hashable Signature
+instance Show Signature where
   showsPrec _ (Sign s t) =
      showString (   "[" ++ show s ++ "*" ++ show t ++ "]" )
-instance Unique Sign where
+instance Unique Signature where
   showUnique (Sign s t) = "[" ++ uniqueShow False s ++ "*" ++ uniqueShow False t ++ "]"
-instance Association Sign where
+instance Association Signature where
   source (Sign s _) = s
   target (Sign _ t) = t
   sign sgn = sgn
 
-instance Flippable Sign where
+instance Flippable Signature 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
+  sign :: rel -> Signature
   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   "
+-- Convenient data structure to hold information about concepts and their representations
+--  in a context. 
+data ContextInfo =
+  CI { ctxiGens       :: [A_Gen]      -- The generalisation relations in the context
+     , ctxiRepresents :: [Representation] -- a list containing all user defined Representations in the context
+     }
+representationOf :: ContextInfo -> A_Concept -> TType
+representationOf ci cpt = 
+-- TODO: Fix this function, to take care of classifications
+  case cpt of 
+    ONE -> TypeOfOne
+    PlainConcept{}
+        ->  case eqCl reprdom . filter isAboutThisCpt . ctxiRepresents $ ci of
+              [] ->  Object  --The default value, when no representation is specified
+              [rs] -> case rs of   
+                         []  -> fatal 498 "This should be impossible with eqClass"
+                         r: _ ->reprdom r
+              _ -> fatal 500 $ "There are multiple Types for "++show cpt++". That should have been checked earlier!"
+  where
+    isAboutThisCpt :: Representation -> Bool 
+    isAboutThisCpt rep = cptnm cpt `elem` reprcpts rep                 
+contextInfoOf :: A_Context -> ContextInfo
+contextInfoOf context 
+  = CI { ctxiGens       = concatMap ptgns (ctxpats context) ++ ctxgs context
+       , ctxiRepresents = ctxreprs context
+       }
+-- | This function is meant to convert the PSingleton inside EMp1 to an AAtomValue,
+--   after the expression has been built inside an A_Context. Only at that time
+--   the TType is known, enabling the correct transformation. 
+--   To ensure that this function is not used too early, ContextInfo is required, 
+--   which only exsists after disambiguation.
+safePSingleton2AAtomVal :: ContextInfo -> A_Concept -> PSingleton -> AAtomValue
+safePSingleton2AAtomVal ci c val = 
+   case unsafePAtomVal2AtomValue typ (Just c) val of
+     Left _ -> fatal 855 $ "This should be impossible: after checking everything an unhandled singleton value found!\n  "
+                     ++ show val
+     Right x -> x 
+  where typ = representationOf ci c
+
+unsafePAtomVal2AtomValue :: TType -> Maybe A_Concept -> PAtomValue -> Either String AAtomValue
+unsafePAtomVal2AtomValue typ mCpt pav =
+  case unsafePAtomVal2AtomValue' typ mCpt pav of
+    Left err -> Left err
+    Right rawVal -> Right roundedVal
+      where roundedVal =
+             case rawVal of
+              AAVDateTime t x -> -- Rounding is needed, to maximize the number of databases
+                                 -- on wich this runs. (MySQL 5.5 only knows seconds)  
+                                 AAVDateTime t (truncateByFormat x)
+                                  where
+                                    truncateByFormat :: UTCTime  -> UTCTime
+                                    truncateByFormat = f DTF.readTime . f DTF.formatTime
+                                      where
+                                        format = iso8601DateFormat (Just "%H:%M:%S")
+                                        f fun = fun SL.defaultTimeLocale format
+              _          -> rawVal
+             
+unsafePAtomVal2AtomValue' :: TType -> Maybe A_Concept -> PAtomValue -> Either String AAtomValue
+unsafePAtomVal2AtomValue' typ mCpt pav
+  = case pav of
+      PSingleton _ str mval 
+         -> case typ of 
+             Alphanumeric     -> Right (AAVString typ str) 
+             BigAlphanumeric  -> Right (AAVString typ str)
+             HugeAlphanumeric -> Right (AAVString typ str)
+             Password         -> Right (AAVString typ str)
+             Object           -> Right (AAVString typ str) 
+             _                -> case mval of
+                                   Nothing -> message str
+                                   Just x -> unsafePAtomVal2AtomValue typ mCpt x
+      ScriptString _ str 
+         -> case typ of
+             Alphanumeric     -> Right (AAVString typ str) 
+             BigAlphanumeric  -> Right (AAVString typ str)
+             HugeAlphanumeric -> Right (AAVString typ str)
+             Password         -> Right (AAVString typ str)
+             Binary           -> Left "Binary cannot be populated in an ADL script"
+             BigBinary        -> Left "Binary cannot be populated in an ADL script"
+             HugeBinary       -> Left "Binary cannot be populated in an ADL script"
+             Date             -> message str
+             DateTime         -> message str
+             Boolean          -> message str
+             Integer          -> message str
+             Float            -> message str
+             TypeOfOne        -> Left "ONE has a population of it's own, that cannot be modified"
+             Object           -> Right (AAVString typ str) 
+      XlsxString _ str
+         -> case typ of
+             Alphanumeric     -> Right (AAVString typ str) 
+             BigAlphanumeric  -> Right (AAVString typ str)
+             HugeAlphanumeric -> Right (AAVString typ str)
+             Password         -> Right (AAVString typ str)
+             Binary           -> Left "Binary cannot be populated in an ADL script"
+             BigBinary        -> Left "Binary cannot be populated in an ADL script"
+             HugeBinary       -> Left "Binary cannot be populated in an ADL script"
+             Date             -> message str
+             DateTime         -> message str
+             Boolean          -> let table =
+                                        [("TRUE", True), ("FALSE" , False)
+                                        ,("YES" , True), ("NO"    , False)
+                                        ,("WAAR", True), ("ONWAAR", False)
+                                        ,("JA"  , True), ("NEE"   , False)
+                                        ,("WEL" , True), ("NIET"  , False)
+                                        ]
+                                 in case lookup (map toUpper str) table of
+                                    Just b -> Right (AAVBoolean typ b)
+                                    Nothing -> Left $ "permitted Booleans: "++(show . map (camelCase . fst)) table  
+                                   where camelCase []     = []
+                                         camelCase (c:xs) = toUpper c: map toLower xs 
+                                    
+             Integer          -> case maybeRead str  of
+                                   Just i  -> Right (AAVInteger typ i)
+                                   Nothing -> message str
+             Float         -> case maybeRead str of 
+                                   Just r  -> Right (AAVFloat typ r)
+                                   Nothing -> message str
+             TypeOfOne        -> Left "ONE has a population of it's own, that cannot be modified"
+             Object           -> Right (AAVString typ str) 
+      ScriptInt _ i
+         -> case typ of
+             Alphanumeric     -> message i 
+             BigAlphanumeric  -> message i 
+             HugeAlphanumeric -> message i 
+             Password         -> message i 
+             Binary           -> Left "Binary cannot be populated in an ADL script"
+             BigBinary        -> Left "Binary cannot be populated in an ADL script"
+             HugeBinary       -> Left "Binary cannot be populated in an ADL script"
+             Date             -> message i 
+             DateTime         -> message i 
+             Boolean          -> message i 
+             Integer          -> Right (AAVInteger typ i)
+             Float            -> Right (AAVFloat typ (fromInteger i)) -- must convert, because `34.000` is lexed as Integer
+             TypeOfOne        -> Left "ONE has a population of it's own, that cannot be modified"
+             Object           -> message i 
+      ScriptFloat _ x
+         -> case typ of
+             Alphanumeric     -> message x
+             BigAlphanumeric  -> message x 
+             HugeAlphanumeric -> message x 
+             Password         -> message x 
+             Binary           -> Left "Binary cannot be populated in an ADL script"
+             BigBinary        -> Left "Binary cannot be populated in an ADL script"
+             HugeBinary       -> Left "Binary cannot be populated in an ADL script"
+             Date             -> message x 
+             DateTime         -> message x 
+             Boolean          -> message x 
+             Integer          -> message x
+             Float            -> Right (AAVFloat typ x)
+             TypeOfOne        -> Left "ONE has a population of it's own, that cannot be modified"
+             Object           -> message x
+      XlsxDouble _ d
+         -> case typ of
+             Alphanumeric     -> message d 
+             BigAlphanumeric  -> message d 
+             HugeAlphanumeric -> message d 
+             Password         -> message d 
+             Binary           -> Left "Binary cannot be populated in an ADL script"
+             BigBinary        -> Left "Binary cannot be populated in an ADL script"
+             HugeBinary       -> Left "Binary cannot be populated in an ADL script"
+             Date             -> Right (AAVDate {aavtyp = typ
+                                                ,aadateDay = addDays (floor d) dayZeroExcel
+                                                })
+             DateTime         -> Right (AAVDateTime {aavtyp = typ
+                                                    ,aadatetime = UTCTime (addDays daysSinceZero dayZeroExcel)
+                                                                          (picosecondsToDiffTime.floor $ fractionOfDay*picosecondsPerDay)
+                                                              
+                                                })
+                                     where picosecondsPerDay = 24*60*60*1000000000000
+                                           (daysSinceZero, fractionOfDay) = properFraction d 
+             Boolean          -> message d 
+             Integer          -> if frac == 0
+                                 then Right (AAVInteger typ int)
+                                 else message d
+                                  where
+                                    (int,frac) = properFraction d
+             Float            -> Right (AAVFloat typ d)
+             TypeOfOne        -> Left "ONE has a population of it's own, that cannot be modified"
+             Object           -> message d 
+      ComnBool _ b
+         -> if typ == Boolean 
+            then Right (AAVBoolean typ b)
+            else message b
+      ScriptDate _ x
+         -> if typ == Date  
+            then Right (AAVDate typ x)
+            else message x
+      ScriptDateTime _ x
+         -> if typ == DateTime  
+            then Right (AAVDateTime typ x)
+            else message x
+         
+   where
+     message :: Show x => x -> Either String a
+     message x = Left . intercalate "\n    " $
+                 ["Representation mismatch"
+                 , "Found: `"++show x++"`,"
+                 , "as representation of an atom in concept `"++name c++"`."
+                 , "However, the representation-type of that concept is "++implicitly
+                 , "defined as "++show expected++". The found value does not match that type."
+                 ]
+        where
+          c = fromMaybe (fatal 1004 $ "Representation mismatch without concept known should not happen.") mCpt
+          expected = if typ == Object then Alphanumeric else typ
+          implicitly = if typ == Object then "(implicitly) " else ""
+     dayZeroExcel = addDays (-2) (fromGregorian 1900 1 1) -- Excel documentation tells that counting starts a jan 1st, however, that isn't totally true.
+     maybeRead :: Read a => String -> Maybe a
+     maybeRead = fmap fst . listToMaybe . reads
+
+-- Awaiting use of time package 1.5, we copy from there:
+
+{- | Construct format string according to <http://en.wikipedia.org/wiki/ISO_8601 ISO-8601>.
+
+The @Maybe String@ argument allows to supply an optional time specification. E.g.:
+
+@
+'iso8601DateFormat' Nothing            == "%Y-%m-%d"           -- i.e. @/YYYY-MM-DD/@
+'iso8601DateFormat' (Just "%H:%M:%S")  == "%Y-%m-%dT%H:%M:%S"  -- i.e. @/YYYY-MM-DD/T/HH:MM:SS/@
+@
 -}
 
-  
+iso8601DateFormat :: Maybe String -> String
+iso8601DateFormat mTimeFmt =
+    "%Y-%m-%d" ++ case mTimeFmt of
+             Nothing  -> ""
+             Just fmt -> 'T' : fmt
+
+-- | The typology of a context is the partioning of the concepts in that context into sets such that (isa\/isa~)*;typology |- typology
+data Typology = Typology { tyroot :: [A_Concept] -- the most generic concepts in the typology (allways non-empty, mostly one concept)
+                         , tyCpts :: [A_Concept]
+                         } deriving Show
+
+
src/Database/Design/Ampersand/Core/ParseTree.hs view
@@ -1,7 +1,7 @@ {-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DeriveGeneric  #-}
 module Database.Design.Ampersand.Core.ParseTree (
-     P_Context(..), mergeContexts
+     P_Context(..), mergeContexts, mkContextOfPopsOnly
    , Meta(..)
    , MetaObj(..)
    , P_RoleRelation(..)
@@ -14,8 +14,9 @@    , SrcOrTgt(..), isSrc
    , P_Rule(..)
    , ConceptDef(..)
+   , Representation(..), TType(..)
    , P_Population(..)
-
+   , PAtomPair(..), PAtomValue(..), mkPair, PSingleton, makePSingleton
    , P_ObjectDef, P_SubInterface, P_Interface(..), P_IClass(..), P_ObjDef(..), P_SubIfc(..)
 
    , P_IdentDef, P_IdentDf(..) , P_IdentSegment, P_IdentSegmnt(..)
@@ -33,24 +34,25 @@ 
    , PandocFormat(..)
 
-   , Label(..)
-
-   , Prop(..), Props
+   , Prop(..), Props, normalizeProps
    -- 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 Data.Foldable hiding (concat)
+import Data.List (nub)
+import Prelude hiding (foldr, sequence, foldl, concatMap)
 import Control.Applicative
 import Data.Typeable
+import Data.Data
 import GHC.Generics (Generic)
 import Data.Hashable
+import Data.Time.Calendar
+import Data.Time.Clock
+import Data.Time.LocalTime() -- for instance Show UTCTime
 
 fatal :: Int -> String -> a
 fatal = fatalMsg "Core.ParseTree"
@@ -62,13 +64,13 @@          , 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_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_reprs ::  [Representation]
          , 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
@@ -77,7 +79,7 @@          , 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
+         } deriving (Show) --For QuickCheck error messages only!
 
 instance Eq P_Context where
   c1 == c2  =  name c1 == name c2
@@ -95,9 +97,9 @@ 
 -- | 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
+   = P_RR { rr_Pos :: Origin      -- ^ position in the Ampersand script
+          , 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
@@ -106,34 +108,40 @@  -- | 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
+     { mPos :: Origin      -- ^ position in the Ampersand script
+     , mRoles :: [Role]    -- ^ name of a role
+     , mRules :: [String]  -- ^ name of a Rule
+     } 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
+data Role = Role String 
+          | Service String
+           deriving (Show, Typeable, Data )   -- deriving (Eq, Show) is just for debugging
+instance Eq Role where
+ r == r' = name r == name r' 
 instance Named Role where
  name (Role nm) = nm
+ name (Service 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.
+   = P_Pat { pt_pos :: Origin           -- ^ the starting position in the file in which this pattern was declared.
+           , pt_nm :: String            -- ^ Name of this pattern
            , 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_Reprs :: [Representation] -- ^ The type into which concepts is represented
            , 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
+           , pt_end :: Origin           -- ^ the end position in the file in which this pattern was declared.
+           } deriving (Show) --For QuickCheck error messages only!
 
 instance Named P_Pattern where
  name = pt_nm
@@ -146,7 +154,6 @@          , 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)
@@ -158,18 +165,48 @@ instance Named ConceptDef where
  name = cdcpt
 
+data Representation
+  = Repr { reprpos  :: Origin
+         , reprcpts  :: [String]  -- ^ the concepts 
+         , reprdom :: TType     -- the type of the concept the atom is in
+         } deriving (Show)
+instance Traced Representation where
+ origin = reprpos
+         
+data TType 
+  = Alphanumeric | BigAlphanumeric | HugeAlphanumeric | Password
+  | Binary | BigBinary | HugeBinary 
+  | Date | DateTime 
+  | Boolean | Integer | Float | Object  
+  | TypeOfOne --special type for the special concept ONE.
+     deriving (Eq, Ord)
+instance Show TType where
+  show tt = case tt of
+    Alphanumeric      ->   "ALPHANUMERIC"
+    BigAlphanumeric   ->   "BIGALPHANUMERIC"
+    HugeAlphanumeric  ->   "HUGEALPHANUMERIC"   
+    Password          ->   "PASSWORD"           
+    Binary            ->   "BINARY"             
+    BigBinary         ->   "BIGBINARY"          
+    HugeBinary        ->   "HUGEBINARY"         
+    Date              ->   "DATE"               
+    DateTime          ->   "DATETIME"           
+    Boolean           ->   "BOOLEAN"            
+    Integer           ->   "INTEGER"            
+    Float             ->   "FLOAT"              
+    Object            ->   "OBJECT"             
+    TypeOfOne         ->   "TYPEOFONE"   
 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_pragma :: [String]  -- ^ Three strings, which form the pragma. E.g. if pragma consists of the three strings: "Person ", " is married to person ", and " in Vegas."
+                                      -- ^    then a tuple ("Peter","Jane") in the list of links means that Person Peter is married to person Jane in Vegas.
             , dec_Mean :: [PMeaning]  -- ^ the optional meaning of a declaration, possibly more than one for different languages.
-            , dec_popu :: Pairs     -- ^ the list of tuples, of which the relation consists.
+            , dec_popu :: [PAtomPair]     -- ^ 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
+            } deriving (Show) --For QuickCheck error messages only!
 instance Eq P_Declaration where
  decl==decl' = origin decl==origin decl'
 instance Prelude.Ord P_Declaration where
@@ -179,6 +216,125 @@ instance Traced P_Declaration where
  origin = dec_fpos
 
+data PAtomPair 
+  = PPair { pppos :: Origin
+          , ppLeft  :: PAtomValue
+          , ppRight :: PAtomValue
+          } deriving (Show) --For QuickCheck error messages only!
+instance Traced PAtomPair where
+  origin = pppos
+instance Flippable PAtomPair where
+  flp pr = pr{ppLeft = ppRight pr
+             ,ppRight = ppLeft pr}
+--data PSingleton
+--  = PSingleton { psOrig :: Origin
+--               , psRaw  :: String 
+--               , psInterprets :: [PAtomValue]
+--               }
+--instance Show PSingleton where
+-- show = psRaw
+--instance Eq PSingleton where
+-- a == b = psRaw a == psRaw b 
+--instance Ord PSingleton where
+-- compare a b = compare (psRaw a) (psRaw b)
+--instance Traced PSingleton where
+-- origin = psOrig
+type PSingleton = PAtomValue
+makePSingleton :: String -> PSingleton
+makePSingleton s = PSingleton (Origin "ParseTree.hs") s Nothing
+--   PSingleton { psOrig =Origin "ParseTree.hs"
+--              , psRaw = s
+--              , psInterprets = fatal 241 "Probably no need to make something up..." 
+--              }
+data PAtomValue
+  = PSingleton Origin String (Maybe PAtomValue)
+  | ScriptString Origin String -- string from script char to enquote with when printed
+  | XlsxString Origin String
+  | ScriptInt Origin Integer
+  | ScriptFloat Origin Double
+  | XlsxDouble Origin Double
+  | ComnBool Origin Bool
+  | ScriptDate Origin Day
+  | ScriptDateTime Origin UTCTime
+   deriving (Typeable, Data)
+instance Show PAtomValue where -- Used for showing in Expressions as PSingleton
+ show pav =
+  case pav of 
+    PSingleton   _ s _ -> singleQuote s
+    ScriptString   _ s -> singleQuote s
+    XlsxString     _ s -> singleQuote s
+    ScriptInt      _ i -> singleQuote (show i)
+    ScriptFloat    _ d -> singleQuote (show d)
+    XlsxDouble     _ _ -> fatal 267 $ "We got a value from an .xlsx file, which has to be shown in an expression, however the technicaltype is not known"
+    ComnBool       _ b -> singleQuote (show b)
+    ScriptDate     _ x -> singleQuote (show x)
+    ScriptDateTime _ x -> singleQuote (show x)
+   where 
+     singleQuote :: String -> String
+     singleQuote str = "\'" ++concatMap f str++"\'"
+     f :: Char -> String
+     f '\'' = "\\'"
+     f c    = [c] 
+instance Eq PAtomValue where
+  PSingleton _ s _ == PSingleton _ s' _ = s == s'
+  PSingleton _ _ _ == _                 = False
+  ScriptString _ s == ScriptString _ s' = s == s'
+  ScriptString _ _ == _                 = False
+  XlsxString   _ s == XlsxString   _ s' = s == s'
+  XlsxString   _ _ == _                 = False
+  ScriptInt    _ i == ScriptInt    _ i' = i == i'
+  ScriptInt    _ _ == _                 = False
+  ScriptFloat  _ x == ScriptFloat  _ x' = x == x'
+  ScriptFloat  _ _ == _                 = False
+  XlsxDouble   _ d == XlsxDouble   _ d' = d == d'
+  XlsxDouble   _ _ == _                 = False
+  ScriptDate   _ d == ScriptDate   _ d' = d == d'
+  ScriptDate   _ _ == _                 = False
+  ScriptDateTime _ d == ScriptDateTime _ d' = d == d'
+  ScriptDateTime _ _ == _               = False
+  ComnBool     _ b == ComnBool     _ b' = b == b'
+  ComnBool     _ _ == _                 = False
+
+instance Ord PAtomValue where
+  compare a b = 
+   case (a,b) of
+    (PSingleton  _ x _ , PSingleton   _ x' _) -> compare x x'
+    (PSingleton  _ _ _ , _                  ) -> GT
+    (ScriptString   _ x, ScriptString   _ x') -> compare x x'
+    (ScriptString   _ _, _                  ) -> GT
+    (XlsxString     _ x, XlsxString     _ x') -> compare x x'
+    (XlsxString     _ _, _                  ) -> GT
+    (ScriptInt      _ x, ScriptInt      _ x') -> compare x x'
+    (ScriptInt      _ _, _                  ) -> GT
+    (ScriptFloat    _ x, ScriptFloat    _ x') -> compare x x'
+    (ScriptFloat    _ _, _                  ) -> GT
+    (XlsxDouble     _ x, XlsxDouble     _ x') -> compare x x'
+    (XlsxDouble     _ _, _                  ) -> GT
+    (ScriptDate     _ x, ScriptDate     _ x') -> compare x x'
+    (ScriptDate     _ _, _                  ) -> GT
+    (ScriptDateTime _ x, ScriptDateTime _ x') -> compare x x'
+    (ScriptDateTime _ _, _                  ) -> GT
+    (ComnBool       _ x, ComnBool       _ x') -> compare x x'
+    (ComnBool       _ _, _                  ) -> GT
+instance Traced PAtomValue where
+  origin pav =
+   case pav of 
+    PSingleton   o _ _ -> o
+    ScriptString   o _ -> o
+    XlsxString     o _ -> o
+    ScriptInt      o _ -> o
+    ScriptFloat    o _ -> o
+    XlsxDouble     o _ -> o
+    ComnBool       o _ -> o
+    ScriptDate     o _ -> o
+    ScriptDateTime o _ -> o
+
+mkPair :: Origin -> PAtomValue -> PAtomValue -> PAtomPair
+mkPair o l r 
+   = PPair { pppos   = o
+           , ppLeft  = l
+           , ppRight = r}
+
 data TermPrim
    = PI Origin                              -- ^ identity element without a type
                                             --   At parse time, there may be zero or one element in the list of concepts.
@@ -186,14 +342,19 @@                                             --   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
+   | Patm Origin PSingleton (Maybe P_Concept)   -- ^ a singleton atom, possibly with a type. The list contains denotational equivalent values 
+                                                  --   eg, when `123` is found by the parser, the list will contain both interpretations as 
+                                                  --   the String "123" or as Integer 123.  
+                                                  --   Since everything between the single quotes can allways be interpretated as a String, 
+                                                  --   it is quaranteed that the list contains the interpretation as String, and thus cannot
+                                                  --   be empty.    
    | 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
+   deriving (Show) --For QuickCheck error messages only!
 
-data P_NamedRel = PNamedRel Origin String (Maybe P_Sign)
+data P_NamedRel = PNamedRel { p_nrpos :: Origin, p_nrnm :: String, p_mbSign :: Maybe P_Sign }
    deriving Show
 
 {- For whenever it may turn out to be useful
@@ -212,7 +373,7 @@ data Term a
    = Prim a
    | PEqu Origin (Term a) (Term a)  -- ^ equivalence             =
-   | PImp Origin (Term a) (Term a)  -- ^ implication             |-
+   | PInc Origin (Term a) (Term a)  -- ^ inclusion               |-
    | PIsc Origin (Term a) (Term a)  -- ^ intersection            /\
    | PUni Origin (Term a) (Term a)  -- ^ union                   \/
    | PDif Origin (Term a) (Term a)  -- ^ difference              -
@@ -221,7 +382,7 @@    | 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       *
+   | 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)  ~
@@ -234,29 +395,29 @@  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)
+    PEqu o a b -> PEqu o <$> f a <*> f b
+    PInc o a b -> PInc 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)
+  traverse _ (P_InterfaceRef o a b) = pure (P_InterfaceRef o 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
@@ -277,15 +438,15 @@    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 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
 
@@ -296,7 +457,7 @@  origin e = case e of
    Prim a         -> origin a
    PEqu orig _ _  -> orig
-   PImp orig _ _  -> orig
+   PInc orig _ _  -> orig
    PIsc orig _ _  -> orig
    PUni orig _ _  -> orig
    PDif orig _ _  -> orig
@@ -364,9 +525,9 @@ 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
+   P_Ru { rr_fps ::  Origin            -- ^ Position in the Ampersand file
+        , rr_nm ::   String            -- ^ Name of this rule
+        , rr_exp ::  Term a            -- ^ The rule expression
         , 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
@@ -377,8 +538,8 @@ 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
+ traverse f (P_Ru fps nm expr mean msg viol)
+  = (\e v -> P_Ru fps nm e mean msg v) <$> traverse f expr <*> traverse (traverse (traverse f)) viol
 
 instance Named (P_Rule a) where
  name = rr_nm
@@ -388,30 +549,27 @@ newtype PMessage = PMessage P_Markup
          deriving Show
 data P_Markup =
-    P_Markup  { mLang ::   Maybe Lang
+    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
+  = P_RelPopu { p_src   :: Maybe String -- a separate src and tgt instead of "Maybe Sign", such that it is possible to specify only one of these.
+              , p_tgt   :: Maybe String -- these src and tgt must be more specific than the P_NamedRel
+              , p_orig  :: Origin  -- the origin
+              , p_nmdr  :: P_NamedRel  -- the named relation
+              , p_popps :: [PAtomPair]   -- the contents
               }
-    deriving Show
+  | P_CptPopu { p_orig  :: Origin  -- the origin
+              , p_cnme  :: String  -- the name of a concept
+              , p_popas :: [PAtomValue]  -- atoms in the initial population of that concept
+              } 
+   deriving (Show) --For QuickCheck error messages only!
+  
 
 instance Named P_Population where
- name P_RelPopu{p_rnme = nm} = nm
- name P_TRelPop{p_rnme = nm} = nm
+ name P_RelPopu{p_nmdr = nr} = name nr
  name P_CptPopu{p_cnme = nm} = nm
 
 instance Traced P_Population where
@@ -426,7 +584,7 @@            , ifc_Obj :: P_ObjectDef       -- ^ the context expression (mostly: I[c])
            , ifc_Pos :: Origin
            , ifc_Prp :: String
-           } deriving Show
+           } deriving (Show) --For QuickCheck error messages only!
 
 instance Named P_Interface where
  name = ifc_Name
@@ -442,6 +600,7 @@                                , si_class :: Maybe String
                                , si_box :: [P_ObjDef a] }
               | P_InterfaceRef { si_ori :: Origin
+                               , si_isLink :: Bool --True iff LINKTO is used. (will display as hyperlink)
                                , si_str :: String }
                 deriving (Eq, Show)
 
@@ -505,9 +664,9 @@  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 }
+data P_ViewSegmt a  = P_ViewExp  { vs_nr ::Integer, vs_obj :: P_ObjDef a }
+                    | P_ViewText { vs_nr ::Integer, vs_txt :: String }
+                    | P_ViewHtml { vs_nr ::Integer, vs_htm :: String }
                       deriving (Eq, Show)
 
 data ViewHtmlTemplate = ViewHtmlTemplateFile String
@@ -523,9 +682,9 @@ 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)
+ traverse f (P_ViewExp i a) = P_ViewExp i <$> traverse f a
+ traverse _ (P_ViewText i a) = pure (P_ViewText i a)
+ traverse _ (P_ViewHtml i a) = pure (P_ViewHtml i a)
 
 instance Traced (P_ViewD a) where
  origin = vd_pos
@@ -542,7 +701,6 @@               | PRef2Pattern String
               | PRef2Interface String
               | PRef2Context String
-              | PRef2Fspc String
               deriving Show -- only for fatal error messages
 
 instance Named PRef2Obj where
@@ -555,7 +713,6 @@      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
@@ -588,14 +745,18 @@ instance Show P_Sign where
   showsPrec _ sgn =
       showString (   "[" ++ show (pSrc sgn)++"*"++show (pTgt sgn) ++ "]" )
+instance Flippable P_Sign where
+  flp sgn = P_Sign { pSrc = pTgt sgn
+                   , pTgt = pSrc sgn
+                   }
 
-data P_Gen =  P_Cy{ gen_spc :: P_Concept         -- ^ Left hand side concept expression
+data P_Gen =  P_Cy{ gen_fp ::  Origin            -- ^ Position in the Ampersand file
+                  , 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
+            | PGen{ gen_fp  :: Origin         -- ^ the position of the GEN-rule
+                  , 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
@@ -608,7 +769,7 @@ instance Traced P_Gen where
  origin = gen_fp
 
-data Lang = Dutch | English deriving (Show, Eq, Ord)
+data Lang = Dutch | English deriving (Show, Eq, Ord,Typeable, Data)
 
 data PandocFormat = HTML | ReST | LaTeX | Markdown deriving (Eq, Show, Ord)
 
@@ -624,7 +785,8 @@                | Rfx          -- ^ reflexive
                | Irf          -- ^ irreflexive
                | Aut          -- ^ automatically computed (NOTE: this is a hacky way to denote these until we have appropriate syntax)
-                 deriving (Eq,Ord)
+               | Prop         -- ^ PROP keyword, later replaced by [Sym, Asy]
+                 deriving (Eq, Ord, Enum, Bounded,Typeable, Data)
 instance Show Prop where
  showsPrec _ Uni = showString "UNI"
  showsPrec _ Inj = showString "INJ"
@@ -636,6 +798,7 @@  showsPrec _ Rfx = showString "RFX"
  showsPrec _ Irf = showString "IRF"
  showsPrec _ Aut = showString "AUT"
+ showsPrec _ Prop = showString "PROP"
 
 instance Flippable Prop where
  flp Uni = Inj
@@ -644,12 +807,14 @@  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'
+normalizeProps :: [Prop] -> [Prop]
+normalizeProps = nub.conv.rep
+    where -- replace PROP by SYM, ASY
+          rep (Prop:ps) = [Sym, Asy] ++ rep ps
+          rep (p:ps) = (p:rep ps)
+          rep [] = []
+          -- add Uni and Inj if ps has neither Sym nor Asy
+          conv ps = ps ++ concat [[Uni, Inj] | null ([Sym, Asy]>-ps)]
 
 mergeContexts :: P_Context -> P_Context -> P_Context
 mergeContexts ctx1 ctx2 =
@@ -661,13 +826,13 @@       , 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_reprs  = concatMap ctx_reprs contexts
       , ctx_vs     = concatMap ctx_vs contexts
       , ctx_gs     = concatMap ctx_gs contexts
       , ctx_ifcs   = concatMap ctx_ifcs contexts
@@ -679,6 +844,30 @@       }
     where contexts = [ctx1,ctx2]
 
+mkContextOfPopsOnly :: [P_Population] -> P_Context
+mkContextOfPopsOnly pops = 
+  PCtx{ ctx_nm     = ""
+      , ctx_pos    = []
+      , ctx_lang   = fatal 686 "No language because of excel import hack. Please report this as a bug"
+      , ctx_markup = Nothing
+      , ctx_thms   = []
+      , ctx_pats   = []
+      , ctx_rs     = []
+      , ctx_ds     = []
+      , ctx_cs     = []
+      , ctx_ks     = []
+      , ctx_rrules = []
+      , ctx_rrels  = []
+      , ctx_reprs  = []
+      , ctx_vs     = []
+      , ctx_gs     = []
+      , ctx_ifcs   = []
+      , ctx_ps     = []
+      , ctx_pops   = pops
+      , ctx_sql    = []
+      , ctx_php    = []
+      , ctx_metas  = []
+      }
 -- | Left-biased choice on maybes
 orElse :: Maybe a -> Maybe a -> Maybe a
 x `orElse` y = case x of
src/Database/Design/Ampersand/Core/ToMeta.hs view
@@ -41,13 +41,13 @@          , 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_reprs = makeMeta f (ctx_reprs ctx)
          , ctx_vs    = makeMeta f (ctx_vs ctx)
          , ctx_gs    = makeMeta f (ctx_gs ctx)
          , ctx_ifcs  = makeMeta f (ctx_ifcs ctx)
@@ -60,44 +60,48 @@ 
 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)
+   = P_Pat { pt_pos = makeMeta f (pt_pos p)
+           , pt_nm  =            (pt_nm 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_Reprs = makeMeta f (pt_Reprs 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)
+           , pt_end = makeMeta f (pt_end p)
            }
 
+instance MakeMeta Representation where
+  makeMeta f rep
+   = Repr { reprpos  = makeMeta f (reprpos rep)
+          , reprcpts =      map f (reprcpts rep)
+          , reprdom  =            (reprdom rep)
+          } 
 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)
+   = P_Sgn { dec_nm     =          f (dec_nm d)
+           , dec_sign   = makeMeta f (dec_sign d)
+           , dec_prps   = makeMeta f (dec_prps d)
+           , dec_pragma =          (dec_pragma 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
@@ -114,9 +118,9 @@         
 instance MakeMeta a => MakeMeta (P_Rule a) where
   makeMeta f rul
-   = P_Ru { rr_nm   =            (rr_nm rul)
+   = P_Ru { rr_fps  = makeMeta f (rr_fps rul)
+          , 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)
@@ -125,15 +129,15 @@ instance MakeMeta P_RoleRule where
   makeMeta f rr
    = Maintain
-          { mRoles =            (mRoles rr)
+          { mPos   = makeMeta f (mPos rr)
+          , 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)
+   = P_RR { rr_Pos   = makeMeta f (rr_Pos 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
@@ -161,7 +165,8 @@ 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_ViewExp{}  -> P_ViewExp { vs_nr  = vs_nr vs
+                                , vs_obj = makeMeta f (vs_obj vs)
                                 }
       P_ViewText{} -> vs
       P_ViewHtml{} -> vs
@@ -169,13 +174,13 @@ instance MakeMeta P_Gen where
   makeMeta f gen
    = case gen of 
-      P_Cy{} -> P_Cy { gen_spc = makeMeta f (gen_spc gen)
+      P_Cy{} -> P_Cy { gen_fp  = makeMeta f (gen_fp gen)
+                     , 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)
+      PGen{} -> PGen { gen_fp  = makeMeta f (gen_fp gen)
+                     , 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
@@ -214,7 +219,6 @@       PRef2Pattern _     -> ref 
       PRef2Interface _   -> ref 
       PRef2Context _     -> ref 
-      PRef2Fspc _        -> ref
 
 instance MakeMeta PMeaning where
   makeMeta f (PMeaning m) = PMeaning (makeMeta f m)
@@ -223,16 +227,13 @@ 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_RelPopu{} -> P_RelPopu { p_src   =            (p_src pop)
+                               , p_tgt   =            (p_tgt pop)
+                               , p_nmdr  = makeMeta f (p_nmdr 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_CptPopu{} -> P_CptPopu { p_cnme  =          f (p_cnme pop)
                                , p_orig  = makeMeta f (p_orig pop)
                                , p_popas =            (p_popas pop)
                                }
@@ -262,6 +263,7 @@                                         , si_box   = makeMeta f (si_box sub)
                                         }
       P_InterfaceRef{} -> P_InterfaceRef{ si_ori   = makeMeta f (si_ori sub)
+                                        , si_isLink =            si_isLink sub
                                         , si_str   =            (si_str sub)
                                         }
 
@@ -279,7 +281,7 @@    = 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)
+       PInc o a b -> PInc 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)
@@ -310,7 +312,7 @@   makeMeta f (PNamedRel o nm      sgn)
             = PNamedRel o (f nm) (makeMeta f sgn)
    
-instance MakeMeta Paire where
+instance MakeMeta PAtomPair where
   makeMeta _ = id
 instance MakeMeta Origin where
   makeMeta _ = id
src/Database/Design/Ampersand/FSpec.hs view
@@ -5,8 +5,6 @@    , 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
@@ -15,9 +13,9 @@    )
 where
 import Database.Design.Ampersand.FSpec.FSpec
-       (FSpec(..), concDefs, ECArule(..), plugFields, lookupCpt, metaValues)
+       (FSpec(..), concDefs, ECArule(..), plugFields, lookupCpt, metaValues,AAtomValue, showValADL,showValPHP,showValSQL,A_Concept,Declaration,A_Gen)
 import Database.Design.Ampersand.FSpec.Plug
-       (PlugInfo(..), PlugSQL(..), SqlField(..), SqlFieldUsage(..), SqlType(..), tblcontents,
+       (PlugInfo(..), PlugSQL(..), SqlField(..), SqlFieldUsage(..), SqlTType(..),
         Plugable(..),
         showSQL, fldauto)
 import Database.Design.Ampersand.FSpec.ShowHS
@@ -25,12 +23,8 @@ 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')
+       (showProof,showPrf, commaEngPandoc, commaNLPandoc, commaEngPandoc', commaNLPandoc', commaPandocAnd,commaPandocOr)
 import Database.Design.Ampersand.FSpec.ToFSpec.ADL2FSpec
        (makeFSpec)
 import Database.Design.Ampersand.FSpec.ToFSpec.NormalForms
@@ -38,5 +32,5 @@ import Database.Design.Ampersand.FSpec.Motivations
        (Meaning(..),Motivated(..))
 import Database.Design.Ampersand.FSpec.ToFSpec.CreateFspec 
-       (createFSpec,getPopulationsFrom)
+       (createFSpec)
src/Database/Design/Ampersand/FSpec/Crud.hs view
@@ -97,7 +97,7 @@ getAllInterfaceExprs allIfcs ifc = getExprs $ ifcObj ifc
   where getExprs Obj{objctx=expr, objmsub=subObj} = 
           expr : case subObj of Nothing                -> []
-                                Just (InterfaceRef nm) ->
+                                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
src/Database/Design/Ampersand/FSpec/FSpec.hs view
@@ -11,6 +11,7 @@ module Database.Design.Ampersand.FSpec.FSpec
           ( FSpec(..), concDefs, Atom(..), A_Pair(..)
           , Fswitchboard(..), Quad(..)
+          , A_Concept, Declaration, A_Gen
           , FSid(..)
 --        , InsDel(..)
           , ECArule(..)
@@ -23,17 +24,18 @@           , SqlField(..)
           , Object(..)
           , PlugInfo(..)
-          , SqlType(..)
+          , SqlTType(..)
           , SqlFieldUsage(..)
-          , getGeneralizations, getSpecializations
-          , lookupView, getDefaultViewForConcept
           , Conjunct(..),DnfClause(..), dnf2expr, notCpl
-          , Language(..)
+          , Language(..),AAtomValue
+          , showValADL,showValPHP,showValSQL
+          , module Database.Design.Ampersand.FSpec.ToFSpec.Populated 
           ) where
-          
+-- TODO: Export module Database.Design.Ampersand.Core.AbstractSyntaxTree in the same way as is done
+--       for module Database.Design.Ampersand.Core.ParseTree in that module. Then build to a better
+--       hyrarchie to reflect the Architecture. 
 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
@@ -41,6 +43,7 @@ import Database.Design.Ampersand.FSpec.Crud
 import Database.Design.Ampersand.Misc.Options (Options)
 import Text.Pandoc.Builder (Blocks)
+import Database.Design.Ampersand.FSpec.ToFSpec.Populated
 
 fatal :: Int -> String -> a
 fatal = fatalMsg "FSpec.FSpec"
@@ -55,7 +58,7 @@                      , declsInScope :: [Declaration]
                      , concsInScope :: [A_Concept]
                      , cDefsInScope :: [ConceptDef]
-                     , gensInScope  :: [A_Gen]
+                     , 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)
@@ -78,13 +81,16 @@                                                               --   one declaration for each signal.
                    , allConcepts ::  [A_Concept]              -- ^ All concepts in the fSpec
                    , kernels ::      [[A_Concept]]            -- ^ All concepts, grouped by their classifications
+                   , cptTType :: A_Concept -> TType 
                    , vIndices ::     [IdentityDef]            -- ^ All keys that apply in the entire FSpec
                    , vviews ::       [ViewDef]                -- ^ All views that apply in the entire FSpec
+                   , getDefaultViewForConcept :: A_Concept -> Maybe ViewDef
+                   , lookupView :: String -> ViewDef          -- ^ Lookup view by id in 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)
+                   , allConjsPerConcept :: [(A_Concept, [Conjunct])]  -- ^ Maps each concept to the conjuncts it appears in (as source or target 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
@@ -93,13 +99,19 @@                    , 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
+               --    , popsOfCptWithoutSmaller :: A_Concept -> [Population]  -- ^ All user defined populations of an A_concept, WITHOUT the populations of smaller A_Concepts
+                   , atomsInCptIncludingSmaller :: A_Concept -> [AAtomValue] -- ^ All user defined populations of an A_concept, INCLUDING the populations of smaller A_Concepts
+                   , tableContents :: PlugSQL -> [[Maybe AAtomValue]] -- ^ tableContents is meant to compute the contents of an entity table.
+                                                                      --   It yields a list of records. Values in the records may be absent, which is why Maybe is used rather than String.
+                   
+                   , pairsInExpr :: Expression -> [AAtomPair]   
+                   , initialConjunctSignals :: [(Conjunct,[AAtomPair])] -- ^ All conjuncts that have process-rule violations.
+                   , allViolations ::  [(Rule,[AAtomPair])]   -- ^ All invariant rules with violations.
+                   , allExprs ::     [Expression]             -- ^ All expressions in the fSpec
+                   , allSigns ::     [Signature]              -- ^ All Signs in the fSpec
+                   , contextInfo   :: ContextInfo 
+                   , specializationsOf :: A_Concept -> [A_Concept]    
+                   , generalizationsOf :: A_Concept -> [A_Concept]
                    } deriving Typeable
 instance Eq FSpec where
  f == f' = name f == name f'
@@ -109,11 +121,11 @@ 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
+                 , atmIn ::    [A_Concept] -- all concepts the atom is in. (Based on generalizations)
+                 , atmVal   :: AAtomValue
                  } deriving (Typeable,Eq)
 instance Unique Atom where
-  showUnique a = atmVal a++" in "
+  showUnique a = showValADL (atmVal a)++" in "
          ++case atmRoots a of
              []  -> fatal 110 "an atom must have at least one root concept"
              [x] -> uniqueShow True x
@@ -193,6 +205,8 @@  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
@@ -305,7 +319,7 @@ 
 data SqlField = Fld { fldname :: String
                     , fldexpr :: Expression     -- ^ De target van de expressie geeft de waarden weer in de SQL-tabel-kolom.
-                    , fldtype :: SqlType
+                    , fldtype :: SqlTType
                     , 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)
@@ -320,40 +334,19 @@   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
+data SqlTType = SQLFloat   -- See http://dev.mysql.com/doc/refman/5.7/en/data-types.html
              | SQLVarchar Int
-             | SQLBool              -- exists y/n
+             | SQLText
+             | SQLMediumText
+             | SQLBlob
+             | SQLMediumBlob
+             | SQLLongBlob
+             | SQLDate     -- MySQL retrieves and displays DATE values in 'YYYY-MM-DD' format
+             | SQLDateTime -- MySQL retrieves and displays DATETIME values in 'YYYY-MM-DD HH:MM:SS' format
+             | SQLBool
+             | SQLBigInt
+             | SQLSerial   -- SERIAL is an alias for BIGINT UNSIGNED NOT NULL AUTO_INCREMENT UNIQUE
+             
              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/GenerateUML.hs view
@@ -1,10 +1,11 @@ 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.Core.AbstractSyntaxTree (explMarkup,aMarkup2String,Rule,Purpose(..))
+import Database.Design.Ampersand.Graphic.ClassDiagram
+import Database.Design.Ampersand.Graphic.Fspec2ClassDiagrams 
 import Database.Design.Ampersand.FSpec
-import Data.Map (Map)
+import Database.Design.Ampersand.Core.ParseTree(PandocFormat(ReST))
 import Data.List
 import qualified Data.Map as Map
 import Control.Monad.State.Lazy  (State, gets, evalState, modify)
@@ -172,7 +173,7 @@     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 count puprtxt reftxt | (count, (puprtxt, reftxt)) <- zip [0::Int ..] [(aMarkup2String ReST (explMarkup p), intercalate ";" (explRefIds p)) | p <- reqPurposes req]]
      )
     tagUML xmiId nr value reftxt = intercalate "\n"
       [ "     <thecustomprofile:"++keyMeaning++" base_Requirement="++show xmiId++" "++keyMeaning++"="++show value++"/>"
@@ -191,9 +192,9 @@     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\"/>"
+      , "      <properties documentation="++show (maybe "" (aMarkup2String ReST) (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])  ]++
+      [ "         <tag name=\"Purpose"++nr++"\" value="++show p++" modelElement="++show xmiId++"/>" | (nr ,p) <- zip ("" : map show [1::Int ..]) ([aMarkup2String ReST (explMarkup p) | p <- reqPurposes req])  ]++
       [ "      </tags>"
       , "    </element>"
       ])
@@ -228,7 +229,7 @@ -- State and Monad
 
 data UMLState = UMLState { idCounter :: Int
-                         , labelIdMap :: Map String String
+                         , labelIdMap :: Map.Map String String
                          , diagramEltIds :: [String]
                          , reqValues :: [ReqValue2]
                          }
− src/Database/Design/Ampersand/FSpec/Graphic/ClassDiagram.hs 
@@ -1,527 +0,0 @@---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 
@@ -1,514 +0,0 @@-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/Plug.hs view
@@ -6,17 +6,15 @@      (Plugable(..), PlugInfo(..)
      ,SqlField(..)
      ,SqlFieldUsage(..)
-     ,SqlType(..)
+     ,SqlTType(..)
      ,showSQL
      ,plugpath
-
-     ,tblcontents
      ,fldauto
      ,PlugSQL(..)
      )
 where
 import Database.Design.Ampersand.ADL1
-import Database.Design.Ampersand.Classes (fullContents,atomsOf,Relational(..))
+import Database.Design.Ampersand.Classes (Relational(..))
 import Database.Design.Ampersand.Basics
 import Data.List
 import GHC.Exts (sortWith)
@@ -165,20 +163,25 @@  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"
+fldauto f = case fldtype f of
+              SQLSerial -> if not (fldnull f) && flduniq f
+                           then True
+                           else fatal 171 "AutoIncrement is not allowed at this place." --TODO: build check in P2Aconverters
+              _         -> False
+              
+showSQL :: SqlTType -> String
+showSQL (SQLFloat    ) = "FLOAT"
 showSQL (SQLVarchar n) = "VARCHAR("++show n++")"
+showSQL (SQLText     ) = "TEXT"
+showSQL (SQLMediumText ) = "MEDIUMTEXT"
+showSQL (SQLBlob     ) = "BLOB"
+showSQL (SQLMediumBlob ) = "MEDIUMBLOB"
+showSQL (SQLLongBlob ) = "LONGBLOB"
+showSQL (SQLDate     ) = "DATE"
+showSQL (SQLDateTime ) = "DATETIME"
+showSQL (SQLBigInt   ) = "BIGINT"
 showSQL (SQLBool     ) = "BOOLEAN"
+showSQL (SQLSerial   ) = "SERIAL"
 
 -- 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
@@ -259,38 +262,3 @@         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
@@ -18,8 +18,9 @@ import Database.Design.Ampersand.FSpec.FSpec
 import Data.List
 import Prelude
---import Debug.Trace
+--import Data.Time.Calendar
 
+
 fatal :: Int -> String -> a
 fatal = fatalMsg "FSpec.ShowADL"
 
@@ -50,7 +51,7 @@ 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 _ _ iref@(InterfaceRef _ _) = iref
   mapexprs f l (Box o cl objs) = Box o cl $ map (mapexprs f l) objs
 instance LanguageDependent Declaration where
   mapexprs _ _ = id
@@ -61,7 +62,7 @@ --------------------------------------------------------------
 instance ShowADL (P_SubIfc a) where
   showADL (P_Box{}) = "BOX"
-  showADL (P_InterfaceRef _ nm) = " INTERFACE "++showstr nm
+  showADL (P_InterfaceRef _ isLink nm) = (if isLink then " LINKTO" else "")++" INTERFACE "++showstr nm
 
 instance ShowADL ObjectDef where
 -- WHY (HJ)? In deze instance van ShowADL worden diverse zaken gebruikt die ik hier niet zou verwachten.
@@ -74,7 +75,7 @@                recur "\n  " (objmsub obj)
   where recur :: String -> Maybe SubInterface -> String
         recur _   Nothing = ""
-        recur ind (Just (InterfaceRef nm)) = ind++" INTERFACE "++showstr nm
+        recur ind (Just (InterfaceRef isLink nm)) = ind++(if isLink then " LINKTO" else "")++" INTERFACE "++showstr nm
         recur ind (Just (Box _ cl objs))
          = ind++" BOX" ++ showClass cl ++ " [ "++
            intercalate (ind++"     , ")
@@ -98,9 +99,8 @@ 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)++"-}"
+                ++ "{+"++aMarkup2String ReST (explMarkup expl)++"-}"
 
 instance ShowADL PandocFormat where
  showADL LaTeX = "LATEX "
@@ -111,8 +111,7 @@ instance ShowADL A_Markup where
  showADL m
      = showADL (amLang m)
-    ++ " "++showADL (amFormat m)
-    ++ "{+"++aMarkup2String m++"-}"
+    ++ "{+"++aMarkup2String ReST m++"-}"
 
 instance ShowADL Lang where
  showADL Dutch   = "IN DUTCH"
@@ -210,9 +209,9 @@           ++ "(" ++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 (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
@@ -225,11 +224,11 @@    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
+     showExpr    (equiv,  inclu,  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 (EEqu (l,r)) = showchar l++equiv++showchar r
+          showchar (EInc (l,r)) = showchar l++inclu++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
@@ -246,10 +245,17 @@           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 (EEps i _)   = "I{-Eps-}"++lbr++name i++rbr
           showchar (EDcV sgn)   = "V"++lbr++name (source sgn)++star++name (target sgn)++rbr
-          showchar (EMp1 a c)   = "'"++a++"'"++lbr++name c++rbr
-
+          showchar (EMp1 val c) = "'"++showWithoutDoubleQuotes val++"'"++lbr++name c++rbr
+            
+          showWithoutDoubleQuotes str = 
+            case showADL str of
+              []  -> []
+              [c] -> [c]
+              cs  -> if head cs == '\"' && last cs == '\"'
+                     then reverse . tail . reverse .tail $ cs
+                     else cs
 instance ShowADL DnfClause where
  showADL dnfClause = showADL (dnf2expr dnfClause)
 
@@ -301,6 +307,7 @@ instance ShowADL A_Context where
  showADL context
   = "CONTEXT " ++name context
+    ++ " " ++ (showADL (ctxlang 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")
@@ -329,63 +336,100 @@  showADL pop
   = "POPULATION "++name pop
   ++ case pop of
-        P_TRelPop{} -> "["++(name.pSrc.p_type) pop++"*"++(name.pTgt.p_type) pop++"]"
+        P_RelPopu{p_nmdr = PNamedRel _ _ (Just sgn)} -> "["++(name.pSrc) sgn++"*"++(name.pTgt) sgn++"]"
         _ -> ""
   ++ " 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)++"]"
+                          P_RelPopu{} -> map showADL (p_popps pop)
+                          P_CptPopu{} -> map showADL  (p_popas pop)
+instance ShowADL PAtomPair where
+ showADL p = "("++showADL (ppLeft p)++","++ showADL (ppRight p)++")"
+instance ShowADL AAtomPair where
+ showADL p = "("++showADL (apLeft p)++","++ showADL (apRight p)++")"
   
 instance ShowADL Population where
  showADL pop
   = "POPULATION "
   ++ case pop of
-        PRelPopu{} -> (name.popdcl) pop++(show.sign.popdcl) pop
-        PCptPopu{} -> (name.popcpt) pop
+        ARelPopu{} -> (name.popdcl) pop++(show.sign.popdcl) pop
+        ACptPopu{} -> (name.popcpt) pop
   ++ " CONTAINS\n"
   ++ if (case pop of
-            PRelPopu{} -> null (popps pop)
-            PCptPopu{} -> null (popas pop)
+            ARelPopu{} -> null (popps pop)
+            ACptPopu{} -> 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)
+                          ARelPopu{} -> map showADL (popps pop)
+                          ACptPopu{} -> map showADL (popas pop)
 
--- showADL (PRelPopu r pairs)
+-- showADL (ARelPopu 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 PAtomValue where
+ showADL at = case at of
+              PSingleton _ s _ -> show s
+              ScriptString _ s -> show s
+              XlsxString _ s   -> show s
+              ScriptInt _ s    -> show s
+              ScriptFloat  _ x -> show x
+              XlsxDouble _ d   -> show d
+              ComnBool   _ b   -> show b
+              ScriptDate _ x   -> show x
+              ScriptDateTime _ x -> show x
+              
+instance ShowADL AAtomValue where
+ showADL at = case at of
+              AAVString  _ str -> show str
+              AAVInteger _ i   -> show i
+              AAVFloat   _ f   -> show f
+              AAVBoolean _ b   -> show b
+              AAVDate _ day    -> show day
+              AAVDateTime _ dt -> show dt
+              AtomValueOfONE -> "1"
 
 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
- 
+ showADL (PI _)                   = "I"
+ showADL (Pid _ c)                = "I["++showADL c++"]"
+ showADL (Patm _ val mSign)     = showSingleton
+  where
+   showSingleton =
+     "'"++
+     (case val of
+       PSingleton   _ x _ -> x 
+       ScriptString   _ x -> x
+       XlsxString     _ x -> concatMap escapeSingleQuote x
+                               where escapeSingleQuote c=
+                                       case c of
+                                         '\'' -> ['\\','\'']
+                                         _    -> [c]
+       ScriptInt      _ x -> show x
+       ScriptFloat    _ x -> show x
+       XlsxDouble     _ x -> show x
+       ComnBool       _ x -> show x
+       ScriptDate     _ x -> show x
+       ScriptDateTime _ x -> show x
+     ) ++
+     "'" ++
+     (case mSign of
+       Nothing -> ""
+       Just c  -> "["++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++"]"
@@ -394,12 +438,12 @@ 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
+    showPExpr (equiv,inclu,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 (PEqu _ l r)                             = showchar l++equiv++showchar r
+       showchar (PInc _ l r)                             = showchar l++inclu++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
@@ -422,7 +466,7 @@        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 (PInc o l r) = wrap i     0 (PInc 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))
@@ -456,10 +500,10 @@          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
+       = "NEW x:"++show c++";"++indent'++showPAclause indent' (clause (makePSingleton "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
+       = "REMOVE x:"++show c++";"++indent'++showPAclause indent' (clause (makePSingleton "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
src/Database/Design/Ampersand/FSpec/ShowHS.hs view
@@ -10,8 +10,6 @@ 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
@@ -138,10 +136,10 @@                          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++"    )"++
+                 indent++"    (\\x->"++showHS opts (indent++"        ") (paCl p (makePSingleton "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++"    )"++
+                 indent++"    (\\x->"++showHS opts (indent++"        ") (paCl p (makePSingleton "x"))++indent++"    )"++
                  wrap (if null ms then "" else indent ++"    ") (indent ++"    ") showMotiv ms
         Nop{} -> "Nop "++wrap "" (indent ++"    ") showMotiv ms
         Blk{} -> "Blk "++wrap "" (indent ++"    ") showMotiv ms
@@ -173,18 +171,8 @@  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 ShowHS SqlTType where
+ showHS _ indent sqltype = indent ++ show sqltype
 
 instance ShowHSName Quad where
  showHSName q
@@ -287,7 +275,6 @@         ,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)
         ,"}"
@@ -375,15 +362,16 @@               showAtomsOfConcept c =
                            "-- atoms: [ "++ intercalate indentC strs++"]"
                   where
-                    strs = map show (sort (atomsOf (vgens fSpec)(initialPops fSpec) c))
+                    strs = map showVal (sort (atomsInCptIncludingSmaller fSpec c))
+                      where showVal val= "`"++showValADL val++"`" 
                     indentC = if sum (map length strs) > 300
                               then indent ++ "    --        , "
                               else ", "
-              showViolatedRule :: String -> (Rule,Pairs) -> String
+              showViolatedRule :: String -> (Rule,[AAtomPair]) -> 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++")"
+                      indent'++" , "++ wrap "" (indent'++"   ") (let showPair _ p = "( "++ (show.showValADL.apLeft) p++", "++(show.showValADL.apRight) p++")"
                                                                    in showPair) ps++
                       indent'++" )"
                      ]
@@ -406,7 +394,12 @@  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
+ showHS _ ind r = ind++
+                  (case r of
+                     Role str -> "Role "++show str
+                     Service str -> "Service "++show str
+                  ) 
+ 
 instance ShowHS P_RoleRule where
  showHS opts ind rs
   = "Maintain "++show (mRoles rs)++" "++show (mRules rs)++" "++showHS opts (ind++"    ") (mPos rs)
@@ -472,7 +465,6 @@          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 =
@@ -506,7 +498,6 @@  showHS _ indent m
    = intercalate indent
      ["A_Markup{ amLang   = "++ show (amLang m)
-     ,"        , amFormat = "++ show (amFormat m)
      ,"        , amPandoc = "++ show (amPandoc m)
      ,"        }"
      ]
@@ -546,7 +537,7 @@ instance ShowHS RuleType where
   showHS _ _ Truth          = "Truth"
   showHS _ _ Equivalence    = "Equivalence"
-  showHS _ _ Implication    = "Implication"
+  showHS _ _ Inclusion      = "Inclusion"
 
 instance ShowHSName IdentityDef where
  showHSName identity = haskellIdentifier ("identity_"++name identity)
@@ -571,21 +562,23 @@ -- 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
+ showHS _     _     (ViewText i str)    = "ViewText "++show i ++show str
+ showHS _     _     (ViewHtml i str)    = "ViewHtml "++show i ++show str
+ showHS opts indent (ViewExp  i objDef) = "ViewExp " ++show i ++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))
+      ARelPopu{} -> "ARelPopu { popdcl = "++showHSName (popdcl pop)
+--TODOFIX
+--          ++indent++"         , popps  = [ "++intercalate
+--           (indent++"                    , ") (map show (popps pop))
           ++indent++"                    ]"
           ++indent++"         }"
-      PCptPopu{} -> "PCptPopu { popcpt = "++showHSName (popcpt pop)
-          ++indent++"         , popas  = [ "++intercalate
-           (indent++"                    , ") (map show (popas pop))
+      ACptPopu{} -> "ACptPopu { popcpt = "++showHSName (popcpt pop)
+--TODOFIX
+--          ++indent++"         , popas  = [ "++intercalate
+--           (indent++"                    , ") (map show (popas pop))
           ++indent++"                    ]"
           ++indent++"         }"
 
@@ -620,12 +613,12 @@         ]++indent++"    }"
 
 instance ShowHS SubInterface where
- showHS _     _      (InterfaceRef n) = "InterfaceRef "++show n
+ showHS _     _      (InterfaceRef isLink n) = "InterfaceRef "++show isLink ++" "++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 (EInc (l,r)) = "EInc ("++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++"     )"
@@ -646,7 +639,7 @@  showHS opts _      (EDcV sgn  ) = "EDcV ("++showHS opts "" sgn++")"
  showHS _    _      (EMp1 a c  ) = "EMp1 " ++show a++" "++showHSName c
 
-instance ShowHS Sign where
+instance ShowHS Signature where
  showHS _ _ sgn = "Sign "++showHSName (source sgn)++" "++showHSName (target sgn)
 
 instance ShowHS A_Gen where
@@ -659,7 +652,6 @@  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
@@ -677,7 +669,6 @@                      ,"   , 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)
@@ -690,7 +681,7 @@ 
 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)
+  = " Cd ("++showHS opts "" (cdpos cd)++") "++show (cdcpt cd)++" "++show (cdplug cd)++" "++show (cddef cd)++" "++show (cdref cd)++" "++show (cdfrom cd)
 instance ShowHSName Char where
  showHSName c = show c
 instance ShowHS Char where
@@ -714,27 +705,29 @@  showHSName Rfx = "Rfx"
  showHSName Irf = "Irf"
  showHSName Aut = "Aut"
+ showHSName Prop = "Prop"
 
 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++")"
+ showHS _ _ pos = show pos
 
 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
+   where x :: String
+         x = case ori of
+              FileLoc l sym -> "FileLoc (" ++ show l ++ " " ++ sym ++ ")"
+              DBLoc l       -> "DBLoc " ++ show l
+              Origin s      -> "Origin " ++ show s
               OriginUnknown -> "OriginUnknown"
-
+              XLSXLoc fPath sheet (a,b) -> "XLSXLoc "++fPath++" "++sheet++" "++show(a,b)
 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"
+ showHS opts indent (FileLoc l s) = "FileLoc (" ++ showHS opts indent l ++ " " ++ s ++ ")"
+ showHS _     _      (DBLoc l)    = "DBLoc "  ++ show l
+ showHS _     _      (Origin s)   = "Origin " ++ show s
+ showHS _     _    OriginUnknown  = "OriginUnknown"
+ showHS _     _    (XLSXLoc fPath sheet (a,b)) = "XLSXLoc "++fPath++" "++sheet++" "++show(a,b)  
 
 instance ShowHS Block where
  showHS _ _   = show
src/Database/Design/Ampersand/FSpec/ShowMeatGrinder.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE TypeSynonymInstances #-}
 {-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE DeriveDataTypeable #-}
 module Database.Design.Ampersand.FSpec.ShowMeatGrinder
   (makeMetaPopulationFile,MetaType(..))
 where
@@ -17,7 +18,7 @@ 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.Core.AbstractSyntaxTree hiding (RuleType(..))
 import Database.Design.Ampersand.Classes.ConceptStructure
 
 --import Data.Hashable
@@ -26,7 +27,6 @@ fatal :: Int -> String -> a
 fatal = fatalMsg "ShowMeatGrinder"
 
-data MetaType = Generics | AST deriving (Show)
 
 makeMetaPopulationFile :: MetaType -> FSpec -> (FilePath,String)
 makeMetaPopulationFile mType fSpec
@@ -89,7 +89,7 @@    filter (not.nullContent)
     (
     [Comment  " ", Comment $ "PATTERN Context: ('"++name fSpec++"')"]
-  ++[ Pop "name"   "Context" "ContextName"
+  ++[ Pop "name"   "Context" "ContextIdentifier"
            [(uri fSpec,name fSpec)]]
   ++[ Comment " ", Comment $ "PATTERN Patterns: (count="++(show.length.vpatterns) fSpec++")"]
   ++   concatMap (metaPops fSpec) ((sortBy (comparing name).vpatterns)    fSpec)
@@ -97,10 +97,10 @@   ++   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 Atoms: (count="++(show.length) (allAtoms fSpec)++")"]
+--  ++   concatMap (metaPops fSpec) (allAtoms fSpec)
+  ++[ Comment " ", Comment $ "PATTERN Signature: (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++")"]
@@ -109,8 +109,8 @@   ++   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)
+--  ++[ Comment " ", Comment $ "[Initial pairs]--: (count="++(show.length.allLinks) fSpec++")"]
+--  ++   concatMap (metaPops fSpec) (allLinks fSpec)
   )
    where
 
@@ -120,7 +120,7 @@    , Comment $ " Pattern `"++name pat++"` "
    , Pop "patterns" "Context" "Pattern"
           [(uri fSpec,uri pat)]
-   , Pop "name"    "Pattern" "PatternName"
+   , Pop "name"    "Pattern" "PatternIdentifier"
           [(uri pat, name pat)]
    , Pop "rules"   "Pattern" "Rule"
           [(uri pat,uri x) | x <- ptrls pat]
@@ -133,9 +133,9 @@  metaPops fSpec gen =
   [ Pop "gens" "Context" "Gen"
           [(uri fSpec,uri gen)]
-  , Pop "genspc"  "Gen" "PlainConcept"
+  , Pop "genspc"  "Gen" "Concept"
           [(uri gen,uri(genspc gen))]
-  , Pop "gengen"  "Gen" "PlainConcept"
+  , Pop "gengen"  "Gen" "Concept"
           [(uri gen,uri c) | c<- case gen of
                                    Isa{} -> [gengen gen]
                                    IsE{} -> genrhs gen
@@ -150,7 +150,7 @@       , Comment $ " Concept `"++name cpt++"` "
       , Pop "allConcepts" "Context" "Concept"
              [(uri fSpec,uri cpt)]
-      , Pop "name" "Concept" "ConceptName"
+      , Pop "name" "Concept" "Identifier"
              [(uri cpt, name cpt)]
       , Pop "affectedInvConjunctIds" "Concept" "ConjunctID"
              [(uri cpt, uri conj) | conj <- filterFrontEndInvConjuncts affConjs]
@@ -159,25 +159,38 @@       , Pop "conceptTableFields" "Concept" "TableColumn"
              [(uri cpt, uri fld) | fld <- tablesAndFields]
       ]
-     ONE -> [
-            ]
+     ONE -> 
+      [ Comment " "
+      , Comment $ " Concept ONE "
+      , Pop "allConcepts" "Context" "Concept"
+             [(uri fSpec,uri cpt)]
+      , Pop "name" "Concept" "Identifier"
+             [(uri cpt, name cpt)]
+      , Pop "conceptTableFields" "Concept" "TableColumn"
+             [(uri cpt, uri fld) | fld <- tablesAndFields]
+      ]
   where
-   affConjs = fromMaybe [] (lookup cpt $ allConjsPerConcept fSpec)
-   tablesAndFields = nub . concatMap (lookupCpt fSpec) $ cpt : largerConcepts (vgens fSpec) cpt
+    affConjs = nub [ conj  
+                   | Just conjs<-[lookup cpt (allConjsPerConcept fSpec)]
+                   , conj<-conjs
+                   ]
+    largerConcs = largerConcepts (vgens fSpec) cpt++[cpt]
+    tablesAndFields = nub . concatMap (lookupCpt fSpec) $ largerConcs
+
 instance MetaPopulations A_Concept where
  metaPops fSpec cpt =
    case cpt of
      PlainConcept{} ->
       [ Comment " "
       , Comment $ " Concept `"++name cpt++"` "
-      , Pop "concs" "Context" "PlainConcept"
+      , Pop "concs" "Context" "Concept"
            [(uri fSpec,uri cpt)]
-      , Pop "name" "PlainConcept" "ConceptName"
+      , Pop "name" "Concept" "Identifier"
              [(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) ]
+--      , Pop "cptdf" "Concept" "ConceptDefinition"
+--             [(uri cpt,showADL cdef) | cdef <- conceptDefs  fSpec, name cdef == name cpt]
+--      , Pop "cptpurpose" "Concept" "Purpose"
+--             [(uri cpt,showADL x) | lang <- allLangs, x <- fromMaybe [] (purposeOf fSpec lang cpt) ]
       ]
      ONE -> [
             ]
@@ -206,7 +219,7 @@       [ Comment $ "Role: '"++name rol++"'"
       , Pop "allRoles" "Context" "Role"
                  [(uri fSpec, uri rol) ]
-      , Pop "name" "Role" "RoleName"
+      , Pop "name" "Role" "TEXT"
                  [(uri rol, name rol) ]
       , Pop "maintains" "Role" "Rule"
                  [(uri rol, uri rul) | (rol',rul) <-  fRoleRuls fSpec, rol==rol' ]
@@ -214,18 +227,19 @@ 
 instance MetaPopulations Atom where
  metaPops _ atm =
-   [ Pop "key" "Atom" "AtomID" 
-          [(uri atm, uri atm)]
-   , Pop "atomvalue"  "Atom" "AtomValue"
-          [(uri atm,(show.atmVal) atm)]
+   [ Pop "pop" "Atom" "Concept" 
+          [(uri atm, uri cpt)
+          |cpt <- atmRoots atm]
+   , Pop "repr"  "Atom" "Representation"
+          [(uri atm, (showValADL.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 MetaPopulations Signature where
+ metaPops _ sgn =
+      [ Pop "src" "Signature" "Concept"
+             [(uri sgn, uri (source sgn))]
+      , Pop "tgt" "Signature" "Concept"
+             [(uri sgn, uri (target sgn))]
+      ]
 
 instance GenericPopulations Declaration where
  generics fSpec dcl =
@@ -263,31 +277,31 @@      Sgn{} ->
       [ Comment " "
       , Comment $ " Declaration `"++name dcl++" ["++(name.source.decsgn) dcl++" * "++(name.target.decsgn) dcl++"]"++"` "
-      , Pop "allDeclarations" "Context" "Declaration"
+      , Pop "allDeclarations" "Context" "Relation"
              [(uri fSpec,uri dcl)] 
-      , Pop "name" "Declaration" "DeclarationName"
+      , Pop "name" "Relation" "Identifier"
              [(uri dcl, name dcl)]
---      , Pop "sign" "Declaration" "Sign"
+--      , Pop "sign" "Declaration" "Signature"
 --             [(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]
+--      , 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"
+--      , Pop "sign" "Declaration" "Signature"
 --             [(uri dcl,uri (sign dcl))]
       , Pop "source" "Relation" "Concept"
              [(uri dcl,uri (source dcl))]
@@ -307,11 +321,68 @@       ]
 
 instance MetaPopulations Expression where
- metaPops _ e =
-      [ Pop "exprvalue" "ExpressionID" "Expression"
-             [(uri e, showADL e)]
-      ]
+ metaPops fSpec expr =
+  case expr of 
+    EBrk e -> metaPops fSpec e
+    _      ->
+      [ Pop "src" "Term" "Concept"
+             [(uri expr, uri (source expr))]
+      , Pop "tgt" "Term" "Concept"
+             [(uri expr, uri (target expr))]
+      ]++
+      ( case expr of
+            (EEqu (l,r)) -> makeBinaryTerm Equivalence l r
+            (EInc (l,r)) -> makeBinaryTerm Inclusion l r
+            (EIsc (l,r)) -> makeBinaryTerm Intersection l r
+            (EUni (l,r)) -> makeBinaryTerm Union l r
+            (EDif (l,r)) -> makeBinaryTerm Difference l r
+            (ELrs (l,r)) -> makeBinaryTerm LeftResidu l r   
+            (ERrs (l,r)) -> makeBinaryTerm RightResidu l r
+            (EDia (l,r)) -> makeBinaryTerm Diamond l r
+            (ECps (l,r)) -> makeBinaryTerm Composition l r
+            (ERad (l,r)) -> makeBinaryTerm RelativeAddition l r
+            (EPrd (l,r)) -> makeBinaryTerm CartesionProduct l r
+--            (EKl0 e)     -> 
+--            (EKl1 e)     -> 
+--            (EFlp e)     -> 
+--            (ECpl e)     -> 
+            (EBrk _)     -> fatal 348 "This should not happen, because EBrk has been handled before"
+            (EDcD dcl)   -> [Pop "bind" "Term" "Relation" [(uri expr,uri dcl)]
+                            ]
+--            EDcI{}       -> 
+--            EEps{}       -> 
+--            EDcV{}       -> 
+--            EMp1{}       -> 
+            _            -> [Comment $ "TODO: "++showADL expr]
+-- TODO: Work on the rest of the expressions (get rid of the statement above) 
+       ) 
+  where
+    makeBinaryTerm :: BinOp -> Expression -> Expression -> [Pop]
+    makeBinaryTerm bop lhs rhs = 
+      [ Pop "lhs"  "BinaryTerm" "Term"
+             [(uri expr,uri lhs)]
+      , Pop "rhs"  "BinaryTerm" "Term"
+             [(uri expr,uri rhs)]
+      , Pop "operator"  "BinaryTerm" "Operator"
+             [(uri expr,uri bop)]
+      ]++metaPops fSpec lhs
+       ++metaPops fSpec rhs
+       
+data BinOp = CartesionProduct
+           | Composition
+           | Diamond
+           | Difference
+           | Equivalence 
+           | Inclusion 
+           | Intersection 
+           | LeftResidu
+           | RightResidu
+           | RelativeAddition 
+           | Union deriving (Eq, Show, Typeable)
+instance Unique BinOp where
+  showUnique = show
 
+
 instance GenericPopulations Rule where
  generics fSpec rul =
       [ Comment " "
@@ -325,9 +396,9 @@       , Pop "origin"  "Rule" "Origin"
              [(uri rul,(show.origin) rul)]
       , Pop "meaning"  "Rule" "Meaning"
-             [(uri rul,aMarkup2String m) | m <- (maybeToList . meaning (fsLang fSpec)) rul ]
+             [(uri rul,aMarkup2String ReST m) | m <- (maybeToList . meaning (fsLang fSpec)) rul ]
       , Pop "message"  "Rule" "Message"
-             [(uri rul,aMarkup2String m) | m <- rrmsg rul, amLang m == fsLang fSpec ]
+             [(uri rul,aMarkup2String ReST m) | m <- rrmsg rul, amLang m == fsLang fSpec ]
       , Pop "srcConcept"  "Rule" "Concept"
              [(uri rul,(uri.source.rrexp) rul)]
       , Pop "tgtConcept"  "Rule" "Concept"
@@ -383,6 +454,8 @@       , Comment $ " Rule `"++name rul++"` "
       , Pop "name"  "Rule" "RuleName"
              [(uri rul,name rul)]
+      , Pop "term"  "Rule" "Term"
+             [(uri rul,uri (rrexp rul))]
       , Pop "rrexp"  "Rule" "ExpressionID"
              [(uri rul,uri (rrexp rul))]
       , Pop "rrmean"  "Rule" "Meaning"
@@ -390,7 +463,7 @@       , Pop "rrpurpose"  "Rule" "Purpose"
              [(uri rul,showADL x) | x <- explanations rul]
       , -- The next population is from the adl pattern 'Plugs':
-        Pop "sign" "Rule" "Sign"
+        Pop "sign" "Rule" "Signature"
              [(uri rul,uri (sign rul))]
       , Pop "declaredthrough" "PropertyRule" "Property"
              [(uri rul,show prp) | Just(prp,_) <- [rrdcl rul]]
@@ -404,7 +477,7 @@  metaPops _ plug = 
       [ Comment $ " Plug `"++name plug++"` "
       , Pop "maintains" "Plug" "Rule" [{-STILL TODO. -}] --HJO, 20150205: Waar halen we deze info vandaan??
-      , Pop "in" "PlainConcept" "Plug"                 
+      , Pop "in" "Concept" "Plug"                 
              [(uri cpt,uri plug)| cpt <- concs plug]  
       , Pop "in" "Declaration" "Plug"
              [(uri dcl,uri plug)| dcl <- relsMentionedIn plug]
@@ -462,6 +535,7 @@ instance AdlId ConceptDef
 instance AdlId Declaration
 instance AdlId Expression
+instance AdlId BinOp
 instance AdlId FSpec
 instance AdlId A_Pair
 instance AdlId Pattern
@@ -471,7 +545,7 @@ instance AdlId Purpose
 instance AdlId Rule
 instance AdlId Role
-instance AdlId Sign
+instance AdlId Signature
 instance AdlId Conjunct
 instance AdlId (PairView Expression)
   where uri x = show (typeOf x)++show (hash x)
− src/Database/Design/Ampersand/FSpec/ShowXMLtiny.hs 
@@ -1,312 +0,0 @@-{-# 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
@@ -58,8 +58,8 @@                              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 "")
+                             New{} -> evs (paCl clause (makePSingleton ""))
+                             Rmv{} -> evs (paCl clause (makePSingleton ""))
                              Nop{} -> []
                              Blk{} -> []
                              Let{} -> fatal 305 "events for let undetermined"
@@ -218,7 +218,7 @@ 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 (EInc (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)
src/Database/Design/Ampersand/FSpec/ToFSpec/ADL2FSpec.hs view
@@ -7,7 +7,6 @@ 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
@@ -19,6 +18,7 @@ import Database.Design.Ampersand.FSpec.ToFSpec.Calc
 import Database.Design.Ampersand.FSpec.ToFSpec.NormalForms 
 import Database.Design.Ampersand.FSpec.ShowADL
+import qualified Data.Set as Set
 
 fatal :: Int -> String -> a
 fatal = fatalMsg "FSpec.ToFSpec.ADL2FSpec"
@@ -83,69 +83,62 @@               , allDecls     = fSpecAllDecls
               , allConcepts  = fSpecAllConcepts
               , kernels      = constructKernels
+              , cptTType     = (\cpt -> representationOf contextinfo cpt)
               , fsisa        = concatMap genericAndSpecifics (gens context)
               , vpatterns    = patterns context
               , vgens        = gens context
               , vIndices     = identities context
               , vviews       = viewDefs context
+              , lookupView   = lookupView'
+              , getDefaultViewForConcept = getDefaultViewForConcept'
               , conceptDefs  = ctxcds context
               , fSexpls      = ctxps context
               , metas        = ctxmetas context
               , crudInfo     = mkCrudInfo fSpecAllConcepts fSpecAllDecls fSpecAllInterfaces
-              , initialPops  = initialpops
-              , allAtoms     = allatoms
-              , allLinks     = alllinks
+              , atomsInCptIncludingSmaller = atomValuesOf contextinfo initialpopsDefinedInScript
+              , tableContents = tblcontents contextinfo initialpopsDefinedInScript
+              , pairsInExpr  = pairsinexpr
               , allViolations  = [ (r,vs)
-                                 | r <- allrules, not (isSignal r)
-                                 , let vs = ruleviolations (gens context) initialpops r, not (null vs) ]
+                                 | r <- allrules -- Removed following, because also violations of invariant rules are violations.. , not (isSignal r)
+                                 , let vs = ruleviolations 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
+                                         , let viols = conjunctViolations conj
                                          , not $ null viols
                                          ]
+              , contextInfo = contextinfo
+              , specializationsOf = smallerConcepts (gens context)
+              , generalizationsOf = largerConcepts  (gens context)
               }
    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
+     pairsinexpr  :: Expression -> [AAtomPair]
+     pairsinexpr = fullContents contextinfo initialpopsDefinedInScript
+     ruleviolations :: Rule -> [AAtomPair]
+     ruleviolations r = case rrexp r of
+          EEqu{} -> (cra >- crc) ++ (crc >- cra)
+          EInc{} -> cra >- crc
+          _      -> pairsinexpr (EDcV (sign (consequent r))) >- crc  --everything not in con
+          where cra = pairsinexpr (antecedent r)
+                crc = pairsinexpr (consequent r)
+     conjunctViolations :: Conjunct -> [AAtomPair]
+     conjunctViolations conj =
+       let vConts    = Set.fromList $ pairsinexpr (EDcV (sign (rc_conjunct conj)))
+           conjConts = Set.fromList $ pairsinexpr (rc_conjunct conj)
+       in  Set.toList $ vConts `Set.difference` conjConts 
 
+     contextinfo = contextInfoOf context
 
-     fSpecAllConcepts = concs context -- `uni` [ONE]
+     fSpecAllConcepts = concs context
      fSpecAllDecls = relsDefdIn context
-     fSpecAllInterfaces = map enrichIfc (ctxifcs context) 
+     fSpecAllInterfaces :: [Interface]
+     fSpecAllInterfaces = map enrichIfc (ctxifcs context)
+       where
+          enrichIfc :: Interface -> Interface
+          enrichIfc ifc
+           = ifc{ ifcEcas = fst . assembleECAs opts context $ ifcParams ifc
+                , ifcControls = makeIfcControls (ifcParams ifc) allConjs
+                }
      
      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)
@@ -157,35 +150,36 @@      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)
+     initialpopsDefinedInScript = 
+                   [ let dcl = popdcl (head eqclass)
+                     in ARelPopu{ popsrc = source dcl
+                                , poptgt = target dcl
+                                , popdcl = dcl
+                                , popps  = (nub.concat) [ popps pop | pop<-eqclass ]
+                                }
+                   | eqclass<-eqCl popdcl [ pop | pop@ARelPopu{}<-populations ] ] ++
+                   [ ACptPopu{ popcpt = popcpt (head eqclass)
                              , popas  = (nub.concat) [ popas pop | pop<-eqclass ]
                              }
-                   | eqclass<-eqCl popcpt [ pop | pop@PCptPopu{}<-populations ] ]
+                   | eqclass<-eqCl popcpt [ pop | pop@ACptPopu{}<-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 ] 
+     fSpecAllConjsPerConcept = converse [ (conj, smaller (source r) `uni` smaller (target r)) | conj <- allConjs, r <- relsMentionedIn $ rc_conjunct conj ]
+                               where smaller :: A_Concept -> [A_Concept]
+                                     smaller cpt = [cpt] `uni` smallerConcepts (gens context) cpt
      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
-         ]
+       = concatMap arRoles . filter forThisRule . ctxrrules $ context
+         where
+          forThisRule :: A_RoleRule -> Bool
+          forThisRule x = name r `elem` arRules x
      isUserDefined rul =
        case r_usr rul of
          UserDefined  -> True
@@ -218,6 +212,24 @@             -- 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]
                  ]
+  -- Lookup view by id in fSpec.
+     lookupView' :: String -> ViewDef
+     lookupView'  viewId =
+       case filter (\v -> vdlbl v == viewId) $ viewDefs context 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' :: A_Concept -> Maybe ViewDef
+     getDefaultViewForConcept' concpt =
+       case [ vd 
+            | vd@Vd{vdcpt = c, vdIsDefault = True} <- viewDefs context
+            ,  c `elem` (concpt : largerConcepts (gens context) concpt) 
+            ] of
+         []     -> Nothing
+         (vd:_) -> Just vd
 
      --------------
      --making plugs
@@ -285,23 +297,23 @@ --  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]
+     cRels = [     EDcD d  | d@Sgn{}<-fSpecAllDecls, isTot d, not$decplug d]++
+             [flp (EDcD d) | d@Sgn{}<-fSpecAllDecls, 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]
+     dRels = [     EDcD d  | d@Sgn{}<-fSpecAllDecls, isInj d, not$decplug d]++
+             [flp (EDcD d) | d@Sgn{}<-fSpecAllDecls, 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
+     maxTotPaths = map (:[]) cRels   -- note: instead of computing the longest sequence, we take sequences of length 1, the function clos1 below is too slow!
+     maxInjPaths = map (:[]) dRels   -- note: instead of computing the longest sequence, we take sequences of length 1, the function clos1 below is too slow!
      --    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)]
+--     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]
@@ -440,7 +452,6 @@                       , 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
@@ -449,7 +460,6 @@                                     ,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
@@ -486,13 +496,14 @@                       [(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).
-                                ]
+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
@@ -508,3 +519,38 @@ 
 instance Rename PlugSQL where
  rename p x = p{sqlname=x}
+     
+
+tblcontents :: ContextInfo -> [Population] -> PlugSQL -> [[Maybe AAtomValue]]
+tblcontents ci ps plug
+   = case plug of
+     ScalarSQL{} -> [[Just x] | x<-atomValuesOf ci ps (cLkp plug)]
+     BinSQL{}    -> [[(Just . apLeft) p,(Just . apRight) p] |p<-fullContents ci ps (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` atomValuesOf ci ps c then Just a else Nothing | a<-cAtoms ]
+                       _      -> [ (lkp a . fullContents ci ps) fExp | a<-cAtoms ]
+                   | fld<-fs, let fExp=fldexpr fld
+                   ]
+                 )
+                 where
+                   cAtoms = (atomValuesOf ci ps. source . fldexpr) f
+                   lkp a pairs
+                    = case [ p | p<-pairs, a==apLeft p ] of
+                       [] -> Nothing
+                       [p] -> Just (apRight p)
+                       _ -> fatal 428 ("(this could happen when using --dev flag, when there are violations)\n"++
+                               "Looking for: '"++showValADL a++"'.\n"++
+                               "Multiple values in one field. \n"
+                               )
+                        
+
src/Database/Design/Ampersand/FSpec/ToFSpec/ADL2Plug.hs view
@@ -2,14 +2,12 @@   (showPlug
   ,makeGeneratedSqlPlugs
   ,makeUserDefinedSqlPlug
-  )
+  ,representationOf)
 where
 import Database.Design.Ampersand.Core.AbstractSyntaxTree hiding (sortWith)
-import Database.Design.Ampersand.Core.Poset as Poset hiding (sortWith)
-import Prelude hiding (Ord(..))
+import GHC.Exts (sortWith)
 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
@@ -17,8 +15,6 @@ 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"
@@ -56,7 +52,7 @@         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
+        gLinkTables = [ makeLinkTable (contextInfoOf context) dcl totsurs
                       | dcl<-entityDcls
                       , Inj `notElem` multiplicities dcl
                       , Uni `notElem` multiplicities dcl]
@@ -76,8 +72,8 @@ -- 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 =
+makeLinkTable :: ContextInfo -> Declaration -> [Expression] -> PlugSQL
+makeLinkTable ci dcl totsurs =
   case dcl of
     Sgn{}
      | isInj dcl || isUni dcl
@@ -88,8 +84,8 @@              , 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))
+                               , fldtype = tType2SqlType . representationOf ci . source $ srcExpr
+                               , flduse  = if suitableAsKey . representationOf ci . source $ srcExpr
                                            then ForeignKey (target srcExpr)
                                            else PlainAttr
                                , fldnull = isTot trgExpr
@@ -98,8 +94,8 @@                          , -- 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))
+                               , fldtype = tType2SqlType . representationOf ci . target $ trgExpr
+                               , flduse  = if suitableAsKey . representationOf ci . target $ trgExpr
                                            then ForeignKey (target trgExpr)
                                            else PlainAttr
                                , fldnull = isSur trgExpr
@@ -125,25 +121,27 @@      | otherwise                = EDcD dcl
 unquote :: String -> String
 unquote str 
-  | length str < 2 = str
+  | length str Prelude.< 2 = str
   | head str == '"' && last str == '"' = reverse . tail . reverse .tail $ str 
   | otherwise = str
       
-suitableAsKey :: SqlType -> Bool
+suitableAsKey :: TType -> 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
-
+    Alphanumeric     -> True
+    BigAlphanumeric  -> False
+    HugeAlphanumeric -> False
+    Password         -> False
+    Binary           -> False
+    BigBinary        -> False
+    HugeBinary       -> False
+    Date             -> True
+    DateTime         -> True
+    Boolean          -> True
+    Integer          -> True
+    Float            -> False
+    Object           -> True
+    TypeOfOne      -> fatal 143 $ "ONE has no key at all. does it?"
 -----------------------------------------
 --rel2fld
 -----------------------------------------
@@ -162,22 +160,22 @@ -- (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
+rel2fld :: ContextInfo
         -> [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
+rel2fld ci
         kernel
         plugAtts
         e
  = Fld { fldname = fldName
        , fldexpr = e
-       , fldtype = sqlTypeOf context (target e)
+       , fldtype = tType2SqlType (representationOf ci (target e))
        , flduse  =
           let f expr =
                  case expr of
-                    EDcI c   -> if suitableAsKey (sqlTypeOf context c)
+                    EDcI c   -> if suitableAsKey (representationOf ci c)
                                 then TableKey ((not.maybenull) e) c
                                 else PlainAttr
                     EDcD _   -> PlainAttr
@@ -206,7 +204,7 @@        
        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' isFlipped (EDcD d) = (if isFlipped then "src" else "tgt")++"_"++(unquote . name) d  --TODO: This has to be made more generic, to enable writing of populations from tables. (Excell spreadsheets)
                 mkColumnName' _         (EDcI c) = (unquote . name) c
                 mkColumnName' _ rel = fatal 162 ( "Unexpected relation found:\n"++
                                                   intercalate "\n  "
@@ -227,7 +225,7 @@    -- 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))
+    | length(map target kernel) Prelude.> 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
@@ -301,7 +299,7 @@                 -> [PlugSQL]
 makeEntityTables opts context allDcls isas conceptss exclusions
  = sortWith ((0-).length.plugFields)
-    (map kernel2Plug kernelsWithAttributes)
+    (map (kernel2Plug (contextInfoOf context)) kernelsWithAttributes)
    where
     diagnostics
       = "\nallDcls:" ++     concat ["\n  "++showHSName r           | r<-allDcls]++
@@ -343,8 +341,8 @@            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)
+    kernel2Plug :: ContextInfo -> ([A_Concept],[Expression]) -> PlugSQL
+    kernel2Plug ci (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.
@@ -357,14 +355,22 @@                   isISA _        = False
           mainkernel = map EDcI kernel
           plugMors :: [Expression]
-          plugMors = mainkernel++atts
+          plugMors = let exprs = mainkernel++atts in
+                     if (suitableAsKey . representationOf ci . target . head) exprs || True --TODO: This check might not be required here. 
+                     then exprs
+                     else -- TODO: make a nice user error of the following:
+                          fatal 360 $ "The concept `"++(name .target .head) exprs++"` would be used as primary key of its table. \n"
+                                     ++"  However, its representation ("
+                                     ++(show . representationOf ci . target . head) exprs
+                                     ++") is not suitable as a key." 
+                     
           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
+          fld a                 = rel2fld (contextInfoOf 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.
@@ -403,7 +409,7 @@ makeUserDefinedSqlPlug context obj
  | null(attributes obj) && isIdent(objctx obj)
     = ScalarSQL { sqlname   = unquote . name $ obj
-                , sqlColumn = rel2fld context [EDcI c] [] (EDcI c)
+                , sqlColumn = rel2fld (contextInfoOf context) [EDcI c] [] (EDcI c)
                 , cLkp      = c
                 }
  | null(attributes obj) --TODO151210 -> assuming objctx obj is Rel{} if it is not I{}
@@ -439,34 +445,28 @@      = (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
+   fld r tp              = (rel2fld (contextInfoOf 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]
+   sqltp :: ObjectDef -> SqlTType
+   sqltp _ = fatal 448 "The Sql type of a user defined plug has bitrotteted. The syntax should support a Representation."
 
-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)
+tType2SqlType :: TType -> SqlTType
+tType2SqlType dom 
+ = case dom of
+     Alphanumeric     -> SQLVarchar 255
+     BigAlphanumeric  -> SQLText
+     HugeAlphanumeric -> SQLMediumText
+     Password         -> SQLVarchar 255
+     Binary           -> SQLBlob
+     BigBinary        -> SQLMediumBlob
+     HugeBinary       -> SQLLongBlob
+     Date             -> SQLDate
+     DateTime         -> SQLDateTime
+     Boolean          -> SQLBool
+     Integer          -> SQLBigInt
+     Float            -> SQLFloat
+     Object           -> SQLVarchar 255
+     TypeOfOne        -> fatal 461 $ "ONE is not represented in SQL" 
 
-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
@@ -2,7 +2,7 @@ module Database.Design.Ampersand.FSpec.ToFSpec.Calc
             ( deriveProofs
             , showProof, showPrf, assembleECAs, conjuncts, genPAclause
-            , commaEngPandoc, commaNLPandoc, commaEngPandoc', commaNLPandoc'
+            , commaEngPandoc, commaNLPandoc, commaEngPandoc', commaNLPandoc', commaPandocAnd ,commaPandocOr--TODO: this shouldt be here!
             , quadsOfRules
           --  , testInterface
             ) where
@@ -312,8 +312,8 @@                                     , 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.
+                                               [A_Markup Dutch   (string2Blocks ReST "Waarom wordt deze regel hier aangemaakt? (In Calc.hs, regel 402)")
+                                               ,A_Markup English (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) -}
@@ -326,8 +326,8 @@                                     , 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.
+                                               [A_Markup Dutch   (string2Blocks ReST "Waarom wordt deze regel hier aangemaakt? (In Calc.hs, regel 332)")
+                                               ,A_Markup English (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) -}
@@ -338,7 +338,7 @@                                     }
   showOp expr' = case expr' of
                   EEqu{} -> "="
-                  EImp{} -> "|-"
+                  EInc{} -> "|-"
                   EIsc{} -> "/\\"
                   EUni{} -> "\\/"
                   EDif{} -> "-"
@@ -459,7 +459,7 @@ ruleType :: Rule -> RuleType
 ruleType r = case rrexp r of
               EEqu{} -> Equivalence
-              EImp{} -> Implication
+              EInc{} -> Inclusion
               _      -> Truth
 
 -- | Action semantics for inserting a delta into a relation dcl.
@@ -659,7 +659,7 @@    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])]
+       (_  , EInc{})     -> 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
@@ -679,25 +679,25 @@                                 , 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)
+       (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)
+       (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)
+       (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)
+       (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
@@ -708,8 +708,8 @@        (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)
+       (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
@@ -737,6 +737,9 @@                                       if null motive then "null motive" else ""
                                       )
 -}
+      where
+       (a,b) = (makePSingleton "a", makePSingleton "b")
+         
 
    deltaK0 :: t -> InsDel -> t1 -> t
    deltaK0 delta' Ins _ = delta'  -- error! (tijdelijk... moet berekenen welke paren in x gezet moeten worden zodat delta |- x*)
@@ -770,7 +773,13 @@ commaNLPandoc s (a:as) = [a, Str ", "]++commaNLPandoc s as
 commaNLPandoc  _  []   = []
    
-   
+commaPandocAnd :: Lang -> [Inlines] -> Inlines
+commaPandocAnd Dutch = commaNLPandoc' "en"
+commaPandocAnd English = commaEngPandoc' "and"
+commaPandocOr :: Lang -> [Inlines] -> Inlines
+commaPandocOr Dutch = commaNLPandoc' "of"
+commaPandocOr English = commaEngPandoc' "or"
+
 quadsOfRules :: Options -> [Rule] -> [Quad]
 quadsOfRules opts rules 
   = makeAllQuads (converse [ (conj, rc_orgRules conj) | conj <- makeAllConjs opts rules ])
src/Database/Design/Ampersand/FSpec/ToFSpec/CreateFspec.hs view
@@ -1,5 +1,5 @@ module Database.Design.Ampersand.FSpec.ToFSpec.CreateFspec 
-  (createFSpec,getPopulationsFrom)
+  (createFSpec)
   
 where
 import Prelude hiding (putStrLn, writeFile) -- make sure everything is UTF8
@@ -11,7 +11,6 @@ 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
@@ -27,7 +26,7 @@ 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
+  do userP_Ctx <- parseADL opts (Left (fileName opts)) -- the P_Context of the user's sourceFile
      genFiles userP_Ctx >> genTables userP_Ctx
    where
     genFiles :: Guarded P_Context -> IO(Guarded ())
@@ -59,18 +58,7 @@ 
     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...)"
-                 ]
+     = do parseADL opts (Right mType) 
     
     
     toFspec :: A_Context -> Guarded FSpec
@@ -92,15 +80,6 @@                _  -> 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 =
src/Database/Design/Ampersand/FSpec/ToFSpec/NormalForms.hs view
@@ -7,7 +7,7 @@   
 import Data.Set (Set)
 import qualified Data.Set as Set
-import Data.List (nub, intercalate, permutations)
+import Data.List (nub, intercalate, permutations,partition)
 import Database.Design.Ampersand.Basics
 import Database.Design.Ampersand.ADL1.ECArule
 import Database.Design.Ampersand.ADL1.Expression
@@ -78,7 +78,7 @@            | RFlp {rTermUny :: RTerm}
            | RId  A_Concept
            | RVee A_Concept A_Concept
-           | RAtm String A_Concept
+           | RAtm PSingleton A_Concept
            | RVar String String String  -- relation name, source name, target name.
            | RConst Expression
            deriving (Eq,Ord,Show)
@@ -320,7 +320,7 @@            flatLst :: [RTerm] -> RTerm
            flatLst = combLst rCombinator . flat isrComb
 
-  dStepSets  :: (RTerm -> Bool) -> (Set RTerm -> RTerm) -> Set RTerm -> [DerivStep]
+  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.
@@ -391,8 +391,8 @@      , let rewriteTerms = stepTerms template cl
      , not (null rewriteTerms)
      ]
-     where f (DEquR l r) = [DImpR l r, DImpR r l]
-           f implication = [implication]
+     where f (DEquiR l r) = [DInclR l r, DInclR r l]
+           f inclusion = [inclusion]
            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 ]
@@ -434,8 +434,8 @@      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)
+           PEqu o l r               -> term2rTerm (PIsc o (PInc o l r) (PInc o r l))
+           PInc 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
@@ -492,8 +492,8 @@      where
       result
        = case expr of
-          EEqu (l,r)           -> expr2RTerm (EIsc (EImp (l,r), EImp (r,l)))
-          EImp (l,r)           -> expr2RTerm (EUni (ECpl l, r))
+          EEqu (l,r)           -> expr2RTerm (EIsc (EInc (l,r), EInc (r,l)))
+          EInc (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
@@ -595,7 +595,6 @@             , 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"
@@ -630,7 +629,7 @@           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
+          RAtm val c -> showADL val++lbr++name c++rbr
      wrap :: Int -> Int -> String -> String
      wrap i j e' = if i<=j then e' else lpar++e'++rpar
 
@@ -660,16 +659,16 @@ vars (RConst{})    = Set.empty
 vars  RAtm{}       = Set.empty
 
-data DerivRule = DEquR { lTerm :: RTerm
-                       , rTerm :: RTerm
-                       }
-               | DImpR { lTerm :: RTerm
-                       , rTerm :: RTerm
-                       }
+data DerivRule = DEquiR { lTerm :: RTerm  -- equivalence rule
+                        , rTerm :: RTerm
+                        }
+               | DInclR { lTerm :: RTerm  -- inclusion rule
+                        , 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))
+  showsPrec _ r@DEquiR{}  = showString (showADL (lTerm r)++" = " ++showADL (rTerm r))
+  showsPrec _ r@DInclR{}  = showString (showADL (lTerm r)++" |- "++showADL (rTerm r))
 
 -- For documentation purposes, the derivation rule which proves the step is included.
 
@@ -684,9 +683,9 @@ 
 
 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)
+dRule (PEqu _ l r) = [DEquiR { lTerm=term2rTerm l, rTerm=term2rTerm r }]
+dRule (PInc _ l r) = [DInclR { lTerm=term2rTerm l, rTerm=term2rTerm r }]
+dRule term         = fatal 279 ("Illegal use of dRule with term "++showADL term)
 
 slideDown :: (RTerm -> Integer) -> RTerm -> [(Integer,DerivStep)]
 slideDown weight term
@@ -855,8 +854,8 @@    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
+   , 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.
@@ -982,7 +981,9 @@  , "-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[C*D] = r[A*B]-s[C*D]"                          --  Avoid complement
  , "r[A*B]~/\\s[A*B]~ = (r[A*B]/\\s[A*B])~"                    --  Distribute flip
+ , "r[A*B]~/\\-s[C*D]~ = (r[A*B]-s[C*D])~"                     --  Avoid complement
  , "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
@@ -1008,11 +1009,11 @@  , "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]"                     --  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*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]+"
@@ -1021,7 +1022,7 @@  ]
 
 {-
--- Type conserving implications: The following implications have an identical signature on either side.
+-- Type conserving inclusions: The following inclusions 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
@@ -1054,7 +1055,7 @@ head (a:_) = a
 
 -- | This delta is meant to be used as a placeholder for inserting or removing links from expressions.
-delta :: Sign -> Expression
+delta :: Signature -> Expression
 delta sgn
  = EDcD   Sgn { decnm   = "Delta"
               , decsgn  = sgn
@@ -1063,11 +1064,10 @@               , 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.")
+              , decMean = AMeaning [ --   A_Markup Dutch   (string2Blocks ReST "Delta is bedoeld als variabele, die de plaats in een expressie vasthoudt waar paren worden ingevoegd of verwijderd.")
+                                     -- , A_Markup English (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
@@ -1081,6 +1081,15 @@ 
 type Proof a = [(a, [String], String)]
 
+{- A proof is a list of triples (e, ss, rel), where |e| is an expression in the chain;
+   |rel| is the relation (equality, inclusion, ...) relating the |e| with the next
+   expression, and |ss| is a documentation of the hint, stating the rule that has been applied.
+   2015-09-12 Stef thinks that the end of the chain is the only triple with empty hint,
+   being supported by the base case of |proofPA| below.
+
+   WK: I typically do |(a, [(rel, hint, a)])|.
+-}
+
 proofPA :: Options -> PAclause -> Proof PAclause
 proofPA opts = {-reverse.take 3.reverse.-}pPA
  where pPA pac' = case normstepPA opts pac' of
@@ -1156,12 +1165,12 @@                                 Blk{} -> p'{paMotiv = ms}
                                 _     -> New c (\x->let (p'', _) = norm (p x) in p'') ms
                              , msgs)
-                             where (p', msgs) = norm (p "x")
+                             where (p', msgs) = norm (p (makePSingleton "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")
+                             where (p', msgs) = norm (p (makePSingleton "x"))
   norm p                   = (p, [])
 
 {- Normalization of expressions -}
@@ -1190,7 +1199,7 @@ 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.
+         eq    -- If eq==True, only equivalences are used. Otherwise, inclusions 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
@@ -1206,7 +1215,7 @@   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''])
+  nM posCpl (EInc (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 .\/.
@@ -1251,13 +1260,13 @@   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
+  nM _      (EInc (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
+  nM _      (EInc (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 _      (EInc (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"], "<=>")
@@ -1371,21 +1380,27 @@            = 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
+-- Absorb:    (x\\/-y)/\\y  =  x/\\y
       | 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
+                 (_,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'] -- this take 1 is necessary. See Ticket #398
+                 (_,ts) -> l ./\. foldr1 (.\/.) ts
+             , ["absorb "++shw t'++", using law x/\\(y\\/-x)  =  x/\\y" | (t',_)<-absor1']
              , "<=>"
              )
+-- Avoid complements: x/\\-y = x-y
+      | (not.null) negList && (not.null) posList
+           = ( foldl (.-.) (foldr1 (./\.) posList) (map notCpl negList)
+             , [ "Avoid complements, using law x/\\-y = x-y" ]
+             , "<=>"
+             )
       | otherwise = (t ./\. f, steps++steps', fEqu [equ',equ''])
       where (t,steps, equ')  = nM posCpl l []
             (f,steps',equ'') = nM posCpl r (l:rs)
@@ -1399,6 +1414,7 @@                       [(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'
+            (negList,posList) = partition isNeg (exprIsc2list l++exprIsc2list r)
             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 /\\"],"<=>")
+ src/Database/Design/Ampersand/FSpec/ToFSpec/Populated.hs view
@@ -0,0 +1,150 @@+module Database.Design.Ampersand.FSpec.ToFSpec.Populated 
+    (fullContents,atomValuesOf
+    , smallerConcepts, largerConcepts, rootConcepts, genericAndSpecifics, safePSingleton2AAtomVal, typologies
+    ) 
+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.Expression                 (notCpl)
+import Database.Design.Ampersand.Core.AbstractSyntaxTree
+import Database.Design.Ampersand.Basics hiding (empty)
+import Data.Map hiding (null, unions,delete)
+   -- 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,delete)
+import Database.Design.Ampersand.Classes.ConceptStructure
+import Database.Design.Ampersand.Classes.ViewPoint
+fatal :: Int -> String -> a
+fatal = fatalMsg "Classes.Populated"
+
+      
+       
+       
+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 gs cpt
+  = nub$ oneSmaller ++ concatMap (smallerConcepts gs) oneSmaller
+  where oneSmaller = delete cpt. nub $ [ genspc g | g@Isa{}<-gs, gengen g==cpt ]++[ genspc g | g@IsE{}<-gs, 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 gs cpt
+ = nub$ oneLarger ++ concatMap (largerConcepts gs) oneLarger
+  where oneLarger  = delete cpt. nub $[ gengen g | g@Isa{}<-gs, genspc g==cpt ]++[ c | g@IsE{}<-gs, 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 gs cpts = [ root | root<-nub $ [ c | cpt<-cpts, c<-largerConcepts gs cpt ] `uni` cpts
+                                , root `notElem` [ genspc g | g@Isa{}<-gs]++[c | g@IsE{}<-gs, c<-genrhs g ]
+                                ]
+
+
+-- | This function returns the atoms of a concept (like fullContents does for relation-like things.)
+atomValuesOf :: ContextInfo -- the relevant info of the context
+        -> [Population] 
+        -> A_Concept    -- the concept from which the population is requested
+        -> [AAtomValue]     -- the elements in the concept's set of atoms
+atomValuesOf ci pt c
+ = case c of
+     ONE -> [AtomValueOfONE]
+     PlainConcept{}
+         -> let smallerconcs = c:smallerConcepts (ctxiGens ci) c in
+            nub$ [apLeft p  | pop@ARelPopu{} <- pt, source (popdcl pop) `elem` smallerconcs, p <- popps pop]
+               ++[apRight p | pop@ARelPopu{} <- pt, target (popdcl pop) `elem` smallerconcs, p <- popps pop]
+               ++[a         | pop@ACptPopu{} <- pt, popcpt pop `elem` smallerconcs, a <- popas pop]
+pairsOf :: ContextInfo -> [Population] -> Declaration -> Map AAtomValue [AAtomValue]
+pairsOf ci ps dcl
+ = case dcl of
+     Isn c  -> fromList [ (a,[a] )   | a  <-atomValuesOf ci ps c]
+     Vs sgn -> fromList [ (sa, atomValuesOf ci ps (target sgn)) | sa <-atomValuesOf ci ps (source sgn)]
+     Sgn{}  -> unionsWith uni
+                      [ fromListWith uni [ (apLeft p,[apRight p]) | p<-popps pop]
+                      | pop@ARelPopu{} <- ps
+                      , name dcl==name (popdcl pop)
+                      , let s=source (popdcl pop) in s `elem` source dcl:smallerConcepts (ctxiGens ci) (source dcl)
+                      , let t=target (popdcl pop) in t `elem` target dcl:smallerConcepts (ctxiGens ci) (target dcl)
+                      ]
+
+fullContents :: ContextInfo -> [Population] -> Expression -> [AAtomPair]
+fullContents ci ps e = [ mkAtomPair 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 AAtomValue [AAtomValue]
+   contents expr
+    = let aVals = atomValuesOf ci ps 
+          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))
+         EInc (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<-aVals (source l), y<-aVals (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<-aVals (target l), y<-aVals (target r)
+                                , null (lkp x (contents (EFlp l)) >- lkp y (contents (EFlp r)))
+                                ]
+         EDia (l,r) -> fromListWith (++)
+                       [(x,[y]) | x<-aVals (source l), y<-aVals (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<-aVals (source l), y<-aVals (target r)
+                                , null (aVals (target l) >- (lkp x (contents l) `uni` lkp y (contents (EFlp r))))
+                                ]
+         EPrd (l,r) -> fromList $
+                       [ (a,cod) | a <- aVals (source l), let cod=aVals (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 ci ps dcl
+         EDcI c     -> fromList [(a,[a]) | a <- aVals c]
+         EEps i _   -> fromList [(a,[a]) | a <- aVals i]
+         EDcV sgn   -> fromList [(s, cod) | s <- aVals (source sgn), let cod=aVals (target sgn), not (null cod) ]
+         EMp1 val c -> fromList $ if name c == "SESSION" -- prevent populating SESSION
+                                  then []
+                                  else [(av,[av])]
+                         where 
+                           av = safePSingleton2AAtomVal ci c val
+
+typologies :: A_Context -> [Typology]
+typologies context = Prelude.map mkTypology (conceptSets (concs context))
+  where
+    allGens = gens context
+    mkTypology :: [A_Concept] -> Typology
+    mkTypology cs = Typology { tyroot = rootConcepts allGens cs
+                             , tyCpts = cs
+                             } 
+    conceptSets :: [A_Concept] -> [[A_Concept]]
+    conceptSets []     = []
+    conceptSets (c:cs) = let theSet = [c] `uni` largerConcepts allGens c `uni` smallerConcepts allGens c 
+                         in theSet : conceptSets (Prelude.filter (\x -> x `notElem` theSet) cs)
+
+ src/Database/Design/Ampersand/Graphic/ClassDiag2Dot.hs view
@@ -0,0 +1,199 @@+module Database.Design.Ampersand.Graphic.ClassDiag2Dot ( 
+  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.Misc
+import Data.String
+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
+import Database.Design.Ampersand.Graphic.ClassDiagram
+
+-- | 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))
+                                                      ]
+                                   }
+
+---- 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)
+
+-------------------------------
+--        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 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 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)
+
+ src/Database/Design/Ampersand/Graphic/ClassDiagram.hs view
@@ -0,0 +1,114 @@+module Database.Design.Ampersand.Graphic.ClassDiagram
+         (ClassDiag(..), Class(..), CdAttribute(..), Association(..),
+          Aggregation(..), Generalization(..), Deleting(..), Method(..),
+          Multiplicities(..) , MinValue(..), MaxValue(..)
+           ) where
+import Data.List
+import Database.Design.Ampersand.Basics
+import Database.Design.Ampersand.FSpec --  hiding (Association,Box)
+
+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) -- ^ 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
+                               , assmdcl ::    Maybe Declaration -- ^ the declarations that caused this association , if any.
+                               } 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/Graphic/Fspec2ClassDiagrams.hs view
@@ -0,0 +1,217 @@+module Database.Design.Ampersand.Graphic.Fspec2ClassDiagrams (
+  clAnalysis, cdAnalysis, tdAnalysis
+) 
+where
+import Data.List
+import Database.Design.Ampersand.ADL1
+import Database.Design.Ampersand.Classes
+import Database.Design.Ampersand.Basics
+import Database.Design.Ampersand.FSpec
+import Database.Design.Ampersand.FSpec.FSpec(getConceptTableFor)
+import Data.Maybe
+import Data.Either
+import Database.Design.Ampersand.Graphic.ClassDiagram
+
+fatal :: Int -> String -> a
+fatal = fatalMsg "Fspec2ClassDiagrams"
+
+
+-- | 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
+                                         , 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
+                              , 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)
+   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] ++ specializationsOf fSpec c ++ generalizationsOf 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
+             , assmdcl = Just 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 = (catMaybes.map primKey) tables
+   primKey :: PlugSQL -> Maybe A_Concept
+   primKey TblSQL{fields=(f:_)} = Just (source (fldexpr f))
+   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 (map relOf (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 = ""
+                               , assmdcl = Nothing
+                               }
+                     , OOAssoc { assSrc = sqlname t
+                               , assSrcPort = fldname b
+                               , asslhm = Mult MinZero MaxMany
+                               , asslhr = ""
+                               , assTgt = getConceptTableFor fSpec . target . fldexpr $ b
+                               , assrhm = Mult MinOne MaxOne
+                               , assrhr = ""
+                               , assmdcl = Nothing
+                               }
+                     ]
+           _  -> 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) -> Database.Design.Ampersand.Graphic.ClassDiagram.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"
+                    , assmdcl = Nothing
+                    }
+
+----             
+mults :: Relational r => r -> Multiplicities
+mults r = let minVal = if isTot r then MinOne else MinZero
+              maxVal = if isUni r then MaxOne else MaxMany
+          in  Mult minVal maxVal
+
+ src/Database/Design/Ampersand/Graphic/Graphics.hs view
@@ -0,0 +1,515 @@+module Database.Design.Ampersand.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.Graphic.Fspec2ClassDiagrams
+import Database.Design.Ampersand.Graphic.ClassDiag2Dot
+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.6"
+            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)) ]++
+      [writeDot Canon  | genFSpec opts ]++  --Pretty-printed Dot output with no layout performed.
+      [writeDot (XDot Nothing)   | genFSpec opts  ]++ --Reproduces the input along with layout information, and provides even more information on how the graph is drawn.
+      [writeDot Png    | genFSpec 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 =
+     ( 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 "sans")
+                           --    , 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 "sans")
+                               , 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 directionArrow            else
+                                    directionArrow
+                                  )
+                      , ArrowTail ( if crowfoot opts   then crowfootArrowType False r else
+                                    if isFunction r    then noArrow                   else
+                                    if isInvFunction r then normal                    else
+                                    noArrow
+                                  )
+                      ,HeadClip False
+                      ]
+      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)]
+                                  )
+                      ,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}
+
+directionArrow :: ArrowType
+directionArrow = AType [(open,Vee)]
src/Database/Design/Ampersand/Input/ADL1/CtxError.hs view
@@ -1,16 +1,20 @@-{-# OPTIONS_GHC -XFlexibleInstances #-}
+{-# OPTIONS_GHC -Wall -Werror #-}
+{-# LANGUAGE FlexibleInstances #-}
 module Database.Design.Ampersand.Input.ADL1.CtxError
   ( CtxError(PE)
-  , showErr
+  , showErr, makeError, addError
   , cannotDisamb, cannotDisambRel
   , mustBeOrdered, mustBeOrderedLst, mustBeOrderedConcLst
   , mustBeBound
-  , GetOneGuarded(..), uniqueNames, mkDanglingPurposeError
+  , GetOneGuarded(..), uniqueNames
+  , mkDanglingPurposeError
   , mkUndeclaredError, mkMultipleInterfaceError, mkInterfaceRefCycleError, mkIncompatibleInterfaceError
   , mkMultipleDefaultError, mkDanglingRefError
   , mkIncompatibleViewError, mkOtherAtomInSessionError
+  , mkMultipleRepresentationsForConceptError, mkIncompatibleAtomValueError
+  , mkTypeMismatchError
   , Guarded(..)
-  , whenCheckedIO
+  , whenCheckedIO, whenChecked, whenError
   , unguard
   )
 -- SJC: I consider it ill practice to export CTXE
@@ -18,38 +22,48 @@ -- 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
+-- Although I also consider it ill practice to export PE
+-- for the same reasons, 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 Data.List  (intercalate,nub)
 import GHC.Exts (groupWith)
-import Database.Design.Ampersand.Input.ADL1.UU_Scanner (Token)
-import UU.Parsing (Message(..),Action(..))
 import Database.Design.Ampersand.Core.ParseTree
+import Text.Parsec.Error (Message(..), messageString)
+import Database.Design.Ampersand.Input.ADL1.FilePos()
 
 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
+-- The function is a bit more compositional than the previously 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 <$> pure 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
+              | PE Message
 
+instance Show CtxError where
+    show (CTXE o s) = "CTXE " ++ show o ++ " " ++ show s
+    show (PE msg)   = "PE " ++ messageString msg
+
 errors :: Guarded t -> [CtxError]
 errors (Checked _) = []
 errors (Errors lst) = lst
 
+makeError :: String -> Guarded a
+makeError msg = Errors [PE (Message msg)]
+
+addError :: String -> Guarded a -> Guarded b
+addError msg guard = Errors (PE (Message msg):errors guard)
+
 class GetOneGuarded a where
   getOneExactly :: (Traced a1, ShowADL a1) => a1 -> [a] -> Guarded a
   getOneExactly _ [a] = Checked a
@@ -69,8 +83,16 @@ 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]]
+  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]]
 
+mkTypeMismatchError :: (ShowADL t, Association t, Traced a2, Named a) => a2 -> t -> SrcOrTgt -> a -> Guarded a1
+mkTypeMismatchError o decl sot conc
+ = Errors [CTXE (origin o) message]
+ where
+  message = "The "++show sot++" concept for the population pairs, namely "++show (name conc)
+            ++"\n  must be more specific or equal to that of the relation you wish to populate, namely: "++showEC (sot,decl)
+
+
 cannotDisambRel :: TermPrim -> [Expression] -> Guarded Expression
 cannotDisambRel o exprs
  = Errors [CTXE (origin o) message]
@@ -131,6 +153,19 @@   CTXE (origin ifc) $ "Multiple interfaces named " ++ show (name ifc) ++ " for role " ++ show role ++ ":" ++ 
                       concatMap (("\n    "++ ) . show . origin) (ifc:duplicateIfcs)       
 
+mkMultipleRepresentationsForConceptError :: String -> [Representation] -> CtxError
+mkMultipleRepresentationsForConceptError cpt rs =
+  case rs of 
+    _:r:_  
+      -> CTXE (origin r)
+          $ "Multiple representations for concept "++show cpt++". ("
+               ++(intercalate ", " . map show . nub . map reprdom) rs ++
+                  concatMap (("\n    "++ ) . show . origin ) rs
+    _ -> fatal 142 "There are no multiple representations."
+
+mkIncompatibleAtomValueError :: PAtomValue -> String -> CtxError
+mkIncompatibleAtomValueError pav msg= CTXE (origin pav) msg
+    
 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
@@ -155,10 +190,10 @@   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 :: AAtomValue -> CtxError
 mkOtherAtomInSessionError atomValue =
-  CTXE OriginUnknown $ "The special concept `SESSION` must not contain anything else then `_SESSION`. However it is populated with `"++atomValue++"`."
-  
+  CTXE OriginUnknown $ "The special concept `SESSION` must not contain anything else then `_SESSION`. However it is populated with `"++showADL atomValue++"`."
+    
 class ErrorConcept a where
   showEC :: a -> String
   showMini :: a -> String
@@ -240,7 +275,7 @@ data Guarded a = Errors [CtxError] | Checked a deriving Show
 
 instance Functor Guarded where
- fmap _ (Errors a) = (Errors a)
+ fmap _ (Errors a)  = Errors a
  fmap f (Checked a) = Checked (f a)
 
 instance Applicative Guarded where
@@ -256,34 +291,34 @@ -- 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
-             }
-    }
+   do gA <- ioGA 
+      case gA of
+         Errors err -> return (Errors err)
+         Checked a  -> fIOGB a
 
+whenChecked :: Guarded a -> (a -> Guarded b) -> Guarded b
+whenChecked ga fgb =
+      case ga of
+         Checked a  -> fgb a
+         Errors err -> Errors err
+
+whenError :: Guarded a -> Guarded a -> Guarded a
+whenError (Errors _) a = a
+whenError a@(Checked _) _ = a
+
+
 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"                
- 
+showErr (PE msg)   = messageString msg
 
 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 (FileLoc (FilePos filename line column) t)
+              = "Error at symbol " ++ t ++
+                " in file " ++ filename ++
+                " at line " ++ show line ++
+                " : " ++ show column
+
 showFullOrig x = show x
 showMinorOrigin :: Origin -> String
-showMinorOrigin (FileLoc (FilePos (_,Database.Design.Ampersand.ADL1.Pos l c,_))) = "line " ++ show l++" : "++show c
+showMinorOrigin (FileLoc (FilePos _ line column) _) = "line " ++ show line ++" : "++show column
 showMinorOrigin v = show v
src/Database/Design/Ampersand/Input/ADL1/FilePos.hs view
@@ -1,54 +1,96 @@ {-# LANGUAGE DeriveDataTypeable #-}
 {-# LANGUAGE DeriveGeneric #-}
-module Database.Design.Ampersand.Input.ADL1.FilePos
-         (FilePos(..), Origin(..), Pos(Pos) , Traced(..)) where
+module Database.Design.Ampersand.Input.ADL1.FilePos (
+    FilePos(..), Origin(..), Traced(..),
+    addPos, initPos, updatePos
+) 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
-
+import Data.Data
+import Codec.Xlsx.Types
+import qualified Data.Text as T
 --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)
+-- | The line number
+type Line = Int
+-- | The column number
+type Column = Int
+-- | The name of a symbol
+type SymbolName = String
+
+-- | Makes the initial position for a file
+initPos :: FilePath -- ^ The file path
+        -> FilePos  -- ^ The initial position
+initPos fn = FilePos fn 1 1
+
+-- | Increases the position of a lexer monad with the given character
+updatePos :: FilePos -- ^ The file position
+          -> Char    -- ^ The character to add
+          -> FilePos -- ^ The new position
+updatePos pos '\n' = addLn 1 pos
+updatePos pos '\t' = addTab pos
+updatePos pos   _  = addPos 1 pos
+
+-- | Adds a tab character to the given position
+addTab :: FilePos -- ^ The old position
+       -> FilePos -- ^ The new position
+addTab pos@(FilePos _ _ col) = addPos tabWidth pos
+    where tabWidth = 8 - ((col-1) `mod` 8)
+
+-- | Adds one column to the file position
+addPos :: Int -> FilePos -> FilePos 
+addPos n (FilePos fn line col) = FilePos fn line (col + n)
+
+-- | Adds one line to the file position, resetting the column number
+addLn :: Int -> FilePos -> FilePos 
+addLn n (FilePos fn line _) = FilePos fn (line+n) 1
+
+-- | Represents a position within a file, including the file path, line and column numbers
+data FilePos = FilePos FilePath Line Column deriving (Eq, Ord, Generic,Typeable, Data)
+
 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)
+  hashWithSalt s (FilePos fn l c) = s `hashWithSalt` fn `hashWithSalt` l `hashWithSalt` c
+
+data Origin = OriginUnknown
+            | Origin String 
+            | FileLoc FilePos SymbolName 
+            | XLSXLoc FilePath String (Int,Int) 
+            | DBLoc String
+    deriving (Eq, Ord, Typeable, Generic, Data)
+
 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
+  show (FilePos fn l c) = "line " ++ show l ++ ":" ++ show c ++ ", file " ++ fn
 
 instance Show Origin where
-  show (FileLoc pos) = show pos
-  show (DBLoc str)   = "Database location: "++str
-  show (Origin str)  = str
-  show OriginUnknown = "Unknown origin"
+  show (FileLoc pos _) = show pos
+  show (XLSXLoc filePath sheet (row,col)) 
+                       = show filePath++":"++
+                         "\n   Sheet: "++sheet++", "++T.unpack (int2col col)++show row
+  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
+               FileLoc (FilePos nm _ _) _ -> nm
                _ -> ""
   linenr x = case origin x of
-               FileLoc (FilePos (_,Pos l _,_)) -> l
+               FileLoc (FilePos _ l _) _ -> l
                _ -> 0
   colnr x  = case origin x of
-               FileLoc (FilePos (_,Pos _ c,_)) -> c
+               FileLoc (FilePos _ _ c) _ -> c
                _ -> 0
 
 instance Traced Origin where
+ src/Database/Design/Ampersand/Input/ADL1/Lexer.hs view
@@ -0,0 +1,439 @@+{-# OPTIONS_GHC -fno-warn-unused-do-bind #-}
+module Database.Design.Ampersand.Input.ADL1.Lexer
+    ( keywords
+    , operators
+    , symbols
+    , lexer
+    -- LexerMessage
+    , LexerError(..)
+    , LexerErrorInfo(..)
+    , LexerWarning(..)
+    , LexerWarningInfo(..)
+    , keepOneTabWarning
+    , showLexerErrorInfo
+    , showLexerWarningInfo
+    -- LexerToken
+    , Token(..)
+    , Lexeme(..)
+    , lexemeText
+    , initPos
+    , FilePos(..)
+) where
+
+import Database.Design.Ampersand.Input.ADL1.FilePos(updatePos)
+import Database.Design.Ampersand.Input.ADL1.LexerToken
+import Database.Design.Ampersand.Input.ADL1.LexerMonad
+import Database.Design.Ampersand.Input.ADL1.LexerMessage
+import Data.Char hiding(isSymbol)
+import Data.Set (member, fromList)
+import Database.Design.Ampersand.Basics (fatalMsg)
+import Database.Design.Ampersand.Misc
+import Data.Time.Calendar
+import Data.Time.Clock
+import Numeric
+
+fatal :: Int -> String -> a
+fatal = fatalMsg "Lexer"
+
+-- | Retrieves a list of keywords accepted by the ampersand language
+keywords :: [String] -- ^ The keywords
+keywords      = [ "INCLUDE"
+                , "CONTEXT", "ENDCONTEXT", "EXTENDS", "THEMES"
+                , "META"
+                , "PATTERN", "ENDPATTERN"
+                , "PROCESS", "ENDPROCESS"
+                , "INTERFACE", "CLASS", "FOR", "BOX", "ROWS", "TABS", "COLS", "INITIAL", "SQLPLUG", "PHPPLUG"
+                , "REPRESENT", "TYPE", "LINKTO"
+                , "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"
+                , "IMPORT", "SPEC", "ISA", "IS", "I", "V"
+                , "CLASSIFY"
+                , "PRAGMA", "PURPOSE", "IN", "REF", "ENGLISH", "DUTCH"
+                , "REST", "HTML", "LATEX", "MARKDOWN"
+                , "ONE"
+                , "BYPLUG"
+                , "ROLE", "SERVICE", "EDITS", "MAINTAINS"
+                -- Keywords for TType:
+                , "ALPHANUMERIC", "BIGALPHANUMERIC", "HUGEALPHANUMERIC", "PASSWORD"
+                , "BINARY", "BIGBINARY", "HUGEBINARY"
+                , "DATE", "DATETIME", "BOOLEAN", "INTEGER", "FLOAT", "AUTOINCREMENT"
+                -- Keywords for values of atoms:
+                , "TRUE", "FALSE" --for booleans
+                ]
+
+-- | Retrieves a list of operators accepted by the ampersand language
+operators :: [String] -- ^ The operators
+operators = [ "|-", "-", "->", "<-", "=", "~", "+", "*", ";", "!", "#",
+              "::", ":", "\\/", "/\\", "\\", "/", "<>" , "..", "."]
+
+-- | Retrieves the list of symbols accepted by the ampersand language
+symbols :: String -- ^ The list of symbol characters / [Char]
+symbols = "()[],{}<>"
+
+--TODO: Options should be one item, not a list
+-- | Runs the lexer
+lexer :: [Options]  -- ^ The command line options
+      -> FilePath   -- ^ The file name, used for error messages
+      -> String     -- ^ The content of the file
+      -> Either LexerError ([Token], [LexerWarning]) -- ^ Either an error or a list of tokens and warnings
+lexer opt file input = case runLexerMonad opt file (mainLexer (initPos file) input) of
+                               Left err -> Left err
+                               Right (ts, ws) -> Right (ts, ws)
+
+-----------------------------------------------------------
+-- Help functions
+-----------------------------------------------------------
+
+skipLine :: String -> String
+skipLine = dropWhile (/= '\n')
+
+takeLine :: String -> String
+takeLine = takeWhile (/= '\n')
+
+-----------------------------------------------------------
+-- Lexer definition
+-----------------------------------------------------------
+
+type Lexer = FilePos -> String  -> LexerMonad [Token]
+
+mainLexer :: Lexer
+
+-----------------------------------------------------------
+-- Removing unnecessary text artifacts (comment, spaces,...)
+-----------------------------------------------------------
+
+mainLexer _ [] =  return []
+
+mainLexer p ('-':'-':s) = mainLexer p (skipLine s) --TODO: Test if we should increase line number and reset the column number
+
+mainLexer p (c:s) | isSpace c = let (spc,next) = span isSpace s
+                                in  mainLexer (foldl updatePos p (c:spc)) next
+
+mainLexer p ('-':'+':s)  = returnToken lx p mainLexer p rest
+                where lx   = LexExpl $ dropWhile isSpace (takeLine s)
+                      rest = skipLine s
+
+mainLexer p ('{':'-':s) = lexNest mainLexer (addPos 2 p) s
+mainLexer p ('{':'+':s) = lexExpl mainLexer (addPos 2 p) s
+mainLexer p ('"':ss) =
+    let (s,swidth,rest) = scanString ss
+    in if null rest || head rest /= '"'
+                              then lexerError (NonTerminatedString s) p
+                              else returnToken (LexString s) p mainLexer (addPos (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. -}
+mainLexer p ('\'':ss)
+     = let (s,swidth,rest) = scanSingletonInExpression ss
+       in if null rest || head rest /= '\''
+             then lexerError UnterminatedAtom p
+             else returnToken (LexSingleton s) p mainLexer (addPos (swidth+2) p) (tail rest)
+
+-----------------------------------------------------------
+-- looking for keywords - operators - special chars
+-----------------------------------------------------------
+
+-- Special case for < since it's the beginning of operators but also a symbol when alone
+mainLexer p ('<':d:s) = if isOperator ['<',d]
+                        then returnToken (LexOperator ['<',d]) p mainLexer (addPos 2 p) s
+                        else returnToken (LexSymbol    '<')    p mainLexer (addPos 1 p) (d:s)
+
+mainLexer p cs@(c:s)
+     | isIdStart c || isUpper c
+         = let (name', p', s')    = scanIdent (addPos 1 p) s
+               name               = c:name'
+               tokt   | iskw name = LexKeyword name
+                      | otherwise = if isIdStart c
+                                    then LexVarId name
+                                    else LexConId name
+           in returnToken tokt p mainLexer p' s'
+     | isOperatorBegin c
+         = let (name, s') = getOp cs
+           in returnToken (LexOperator name) p mainLexer (foldl updatePos p name) s'
+     | isSymbol c = returnToken (LexSymbol c) p mainLexer (addPos 1 p) s
+     | isDigit c
+         = case  getDateTime cs of
+            Just (Right (tk,_,width,s')) -> returnToken tk p mainLexer (addPos width p) s'
+            Just (Left msg) -> lexerError msg p
+            Nothing 
+              -> case getDate cs of
+                  Just (tk,_,width,s') -> returnToken tk p mainLexer (addPos width p) s'
+                  Nothing -> let (tk,_,width,s') = getNumber cs
+                             in  returnToken tk p mainLexer (addPos width p) s'
+       -- Ignore unexpected characters in the beginning of the file because of the UTF-8 BOM marker.
+       -- TODO: Find out the right way of handling the BOM marker.
+     | beginFile p = do { lexerWarning UtfChar p; mainLexer p s }
+     | otherwise  = lexerError (UnexpectedChar c) p
+    where beginFile (FilePos _ 1 1) = True
+          beginFile _ = False
+
+-----------------------------------------------------------
+-----------------------------------------------------------
+-- Supporting functions for MainLexer
+-----------------------------------------------------------
+-----------------------------------------------------------
+
+-----------------------------------------------------------
+-- Check on keywords - operators - special chars
+-----------------------------------------------------------
+
+locatein :: Ord a => [a] -> a -> Bool
+locatein es e = member e (fromList es)
+
+iskw :: String -> Bool
+iskw = locatein keywords
+
+isSymbol :: Char -> Bool
+isSymbol = locatein symbols
+
+isOperator :: String -> Bool
+isOperator  = locatein operators
+
+isOperatorBegin :: Char -> Bool
+isOperatorBegin  = locatein (map head operators)
+
+isIdStart :: Char -> Bool
+isIdStart c = isLower c || c == '_'
+
+isIdChar :: Char -> Bool
+isIdChar c =  isAlphaNum c || c == '_'
+
+-- Finds the longest prefix of cs occurring in keywordsops
+getOp :: String -> (String, String)
+getOp cs = findOper operators cs ""
+    where findOper :: [String] -> String -> String -> (String,String)
+          findOper []  _     _  = ("", cs)
+          findOper _   []    op = (op,[])
+          findOper ops (c:rest) op =
+              if null found then (op, c:rest)
+              else findOper found rest (op ++ [c])
+              where found = [s' | o:s'<-ops, c==o]
+
+-- scan ident receives a file position and the resting contents, returning the scanned identifier, the file location and the resting contents.
+scanIdent :: FilePos -> String -> (String, FilePos, String)
+scanIdent p s = let (name,rest) = span isIdChar s
+                in (name,addPos (length name) p,rest)
+
+
+-----------------------------------------------------------
+-- String clean-up functions / comments
+-----------------------------------------------------------
+
+lexNest :: Lexer -> Lexer
+lexNest c p ('-':'}':s) = c (addPos 2 p) s
+lexNest c p ('{':'-':s) = lexNest (lexNest c) (addPos 2 p) s
+lexNest c p (x:s)       = lexNest c (updatePos p x) s
+lexNest _ p []          = lexerError UnterminatedComment p
+
+--TODO: Also accept {+ ... +} as delimiters
+lexExpl :: Lexer -> Lexer
+lexExpl = lexExpl' ""
+ where lexExpl' str _ p ('-':'}':s) = returnToken (LexExpl str) p mainLexer (addPos 2 p)  s
+       lexExpl' str c p ('{':'-':s) = lexNest (lexExpl' str c) (addPos 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 (updatePos p x) s
+       lexExpl' _   _ p []          = lexerError UnterminatedPurpose p
+
+-----------------------------------------------------------
+-- iso 8601 date / time
+-----------------------------------------------------------
+-- Returns tuple with the parsed lexeme, the UTCTime, the amount of read characters and the rest of the text
+getDateTime :: String -> Maybe (Either LexerErrorInfo (Lexeme, UTCTime, Int, String) )
+getDateTime cs = 
+  case getDate cs of
+   Nothing -> Nothing
+   Just (_,day,ld,rd) -> 
+      case getTime rd of
+        Nothing -> case rd of
+                    'T':_ -> Just . Left $ ProblematicISO8601DateTime
+                    _     -> Nothing
+        Just (timeOfDay, tzoneOffset,lt,rt) -> 
+            let ucttime = addUTCTime tzoneOffset (UTCTime day timeOfDay)
+            in Just . Right $ 
+                    ( LexDateTime ucttime
+                    , ucttime
+                    , ld + lt
+                    , rt
+                    )
+getTime :: String -> Maybe (DiffTime, NominalDiffTime, Int, String)
+getTime cs =
+  case cs of
+   'T':h1:h2:':':m1:m2:rest 
+    -> if (all isDigit [h1,h2,m1,m2])
+       then let (_,Left hours,_,_) = getNumber [h1,h2]
+                (_,Left minutes,_,_) = getNumber [m1,m2]
+                (seconds,ls,rs) = getSeconds rest
+            in case getTZD rs of
+                 Nothing -> Nothing
+                 Just (offset,lo,ro)
+                   -> if hours < 24 && minutes < 60 && seconds < 60
+                      then Just (fromRational . toRational $
+                                   ( fromIntegral hours*60
+                                    +fromIntegral minutes
+                                   )*60+ seconds
+                                ,offset
+                                ,1+5+ls+lo
+                                ,ro)
+                      else Nothing
+       else Nothing
+   _ -> Nothing
+   
+getSeconds :: String -> (Float,Int,String)
+getSeconds cs =
+ case cs of
+  (':':s1:s2:rest) ->  
+     if all isDigit [s1,s2]
+     then let (fraction,lf,rf) = getFraction (s1:s2:rest)
+          in (fraction,1+lf,rf)
+     else (0,0,cs)
+  _ -> (0,0,cs)
+getFraction :: String -> (Float,Int,String)
+getFraction cs = 
+  case readFloat cs of
+   [(a,str)] -> (a, length cs - length str, str) --TODO: Make more efficient.
+   _ -> (0,0,cs)
+   
+
+
+getTZD :: String -> Maybe (NominalDiffTime, Int,String)
+getTZD cs = 
+ case cs of
+  'Z':rest -> Just (0,1,rest)
+  '+':h1:h2:':':m1:m2:rest -> mkOffset [h1,h2] [m1,m2] rest (+)
+  '-':h1:h2:':':m1:m2:rest -> mkOffset [h1,h2] [m1,m2] rest (-)
+  _ -> Nothing
+  where
+   mkOffset :: String -> String -> String -> (Int -> Int -> Int) -> Maybe (NominalDiffTime, Int,String)
+   mkOffset hs ms rest op = 
+    let (_,Left hours  ,_,_) = getNumber hs
+        (_,Left minutes,_,_) = getNumber ms
+        total = hours*60+minutes
+    in if hours <= 24 && minutes < 60
+       then Just (fromRational . toRational $ 0 `op` total
+                 ,6,rest) 
+       else Nothing 
+getDate :: String -> Maybe (Lexeme, Day, Int, String)
+getDate cs =
+  case cs of
+   y1:y2:y3:y4:'-':m1:m2:'-':d1:d2:rest ->
+      if all isDigit [y1,y2,y3,y4,m1,m2,d1,d2] 
+      then case fromGregorianValid (toInteger year) month day of
+             Nothing -> Nothing 
+             Just d -> Just (LexDate d, d, 10, rest)
+      else Nothing
+     where (_,Left year ,_,_) = getNumber [y1,y2,y3,y4]
+           (_,Left month,_,_) = getNumber [m1,m2]
+           (_,Left day  ,_,_) = getNumber [d1,d2]
+   _  -> Nothing
+     
+-----------------------------------------------------------
+-- Numbers
+-----------------------------------------------------------
+-- Returns tuple with the parsed lexeme, the integer, the amount of read characters and the rest of the text
+getNumber :: String -> (Lexeme, (Either Int Double), Int, String)
+getNumber str =
+  case readDec str of
+    [(_,('.':_))] -> case readFloat str of
+                           [(flt,rest)] -> (LexFloat flt, Right flt, length str - length rest,rest)
+                           _            -> fatal 342 "Unexpected: can read decimal, but not float???"
+    [(dec,rest)]  -> (LexDecimal dec , Left dec, length str - length rest,rest)
+    _  -> fatal 343 $ "No number to read!\n  " ++ take 40 str                    
+--getNumber :: String -> (Lexeme, (Either Int Double), Int, String)
+--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 = (LexDecimal 0, Left 0, 1, s)
+--        num10 :: (Lexeme, (Either Int Double), Int, String)
+--        num10  = let (n, rs) = span isDigit cs
+--                     (isWhole,readed,rest) = 
+--                        case rs of
+--                          '.':cs' -> let (n',rs') = span isDigit cs'
+--                                         wholeNumberString = n++"."++n'
+--                                     in (all (=='0') n',wholeNumberString,rs')
+--                          _       -> (True,n, rs)
+--                     nrInt = read n
+--                 in if isWhole
+--                    then (LexDecimal nrInt , Left nrInt, length readed,rest)
+--                    else let x = fst.head.readFloat $ readed
+--                         in (LexFloat x, Right x, length readed,rest)
+--        num16   = readIntNum isHexaDigit  16 LexHex
+--        num8    = readIntNum isOctDigit 8  LexOctal
+--        readIntNum :: (Char -> Bool) -> Int -> (Int -> Lexeme) -> (Lexeme, Either Int a , Int, String)
+--        readIntNum p base lx
+--          = let (n, rs) = span p ts
+--            in  if null n
+--                then const0
+--                else let nr = readn base n
+--                     in (lx nr, Left nr, 2 + length n, rs)
+
+-----------------------------------------------------------
+-- characters / strings
+-----------------------------------------------------------
+scanString :: String -> (String, Int, String)
+scanString = scanUpto False ['"']
+
+scanSingletonInExpression :: String -> (String, Int, String)
+scanSingletonInExpression = scanUpto True ['\'']
+
+-- | scan to some given character. The end char is scanned away too
+scanUpto :: Bool    -- Special case for Ampersand Atomvalues? (if so, both singlequote and doublequote must be escaped)
+         -> [Char]  -- non-empty list of ending characters
+         -> String 
+         -> (String, Int, String)
+scanUpto isAtomScan echrs s = 
+ case s of
+   xs       -> let (ch,cw,cr) = getchar isAtomScan echrs xs
+                   (str,w,r)  = scanUpto isAtomScan echrs cr
+               in maybe ("",0,xs) (\c -> (c:str,cw+w,r)) ch
+
+getchar :: Bool    -- Special case for Ampersand Atomvalues? (if so, both singlequote and doublequote must be escaped)
+        -> [Char]  -- non-empty list of ending characters
+        -> String  -- string to get the character from
+        -> (Maybe Char, Int, String)
+getchar isAtomScan echrs s =
+  case s of
+   []          -> (Nothing,0,[])
+   ('\n':_ )   -> (Nothing,0,s)
+   ('\t':_ )   -> (Nothing,0,s)
+   ('\\':'&':xs) -> let (str,w,r) = getchar isAtomScan echrs xs -- Special case is required because an escaped & is equal to empty string in Haskell
+                    in (str,w+2,r)
+   ('\\':xs)   -> let (c,l,r) = getEscChar xs
+                  in (c,l+1,r)
+   (x:xs)      
+    | x `elem` echrs   -> (Nothing,0,s)
+    | isAtomScan && x `elem`[doubleQuote, singleQuote]  -> (Nothing,0,s) 
+   --- | isAtomScan && ec == singleQuote && x == doubleQuote -> (Nothing,0,s) 
+    | otherwise -> (Just x,1,xs)
+  where
+    (doubleQuote,singleQuote) = ('\"','\'')
+getEscChar :: String -> (Maybe Char, Int, String)
+getEscChar [] = (Nothing,0,[])
+getEscChar s@(x:xs) | isDigit x = case readDec s of
+                                    [(val,rest)]
+                                      | val >= 0 && val <= 255 -> (Just (chr val),length s - length rest, rest)
+                                      | otherwise -> (Nothing, 1, rest)
+                                    _  -> fatal 432 $ "Impossible! first char is a digit.. "++take 40 s
+                    | x `elem` ['\"','\''] = (Just x,2,xs)
+                    | 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'),('\\','\\')]
+
+-----------------------------------------------------------
+-- Token creation function
+-----------------------------------------------------------
+
+returnToken :: Lexeme -> FilePos -> Lexer -> Lexer
+returnToken lx pos continue posi input = do
+    let token = Tok lx pos
+    tokens <- continue posi input
+    return (token:tokens)
+ src/Database/Design/Ampersand/Input/ADL1/LexerMessage.hs view
@@ -0,0 +1,95 @@+{- Based on module LexerMessage from Helium (GPL license) -}
+
+module Database.Design.Ampersand.Input.ADL1.LexerMessage
+    ( LexerError(..)
+    , LexerErrorInfo(..)
+    , LexerWarning(..)
+    , LexerWarningInfo(..)
+    , keepOneTabWarning
+    , showLexerErrorInfo
+    , showLexerWarningInfo
+    ) where
+
+import Database.Design.Ampersand.Input.ADL1.FilePos(FilePos)
+import qualified Database.Design.Ampersand.Input.ADL1.LexerTexts as Texts
+
+-- | Defines a lexer error
+data LexerError = LexerError FilePos LexerErrorInfo -- ^ The lexer file position and error information
+    deriving(Show)
+
+-- | Defines the different lexer error types
+data LexerErrorInfo
+    -- | The comment was not terminated
+    = UnterminatedComment
+    -- | The purpose statement was not terminated
+    | UnterminatedPurpose
+    -- | The atom was not terminated
+    | UnterminatedAtom
+    -- | The character was unexpected
+    | UnexpectedChar Char
+    -- | The string was not terminated
+    | NonTerminatedString String
+    -- | In UnexpectedClose, first char is the closing bracket we see, 
+    --   second char is the closing bracket we would like to see first
+    --   e.g. [(1,3]  =>  UnexpectedClose ']' ... ')'
+    | TooManyClose Char
+    -- | An unexpected closing bracket was found
+    | UnexpectedClose Char FilePos Char
+    -- | Brackets were not closed at the end of the file
+    | StillOpenAtEOF [(FilePos, Char)]
+    -- | DateTime not conforming to ISO 8601 format
+    | ProblematicISO8601DateTime
+    deriving(Show)
+
+-- | Converts the error information into a list of error messages
+showLexerErrorInfo :: LexerErrorInfo -- ^ The error information
+                   -> [String] -- ^ The error messages
+showLexerErrorInfo info =
+    case info of
+        UnterminatedComment          -> [ Texts.lexerUnterminatedComment               ]
+        UnterminatedPurpose          -> [ Texts.lexerUnterminatedPurpose               ]
+        UnterminatedAtom             -> [ Texts.lexerUnterminatedAtom                  ]
+        UnexpectedChar c             -> [ Texts.lexerUnexpectedChar c                  ]
+        NonTerminatedString _        -> [ Texts.lexerNonTerminatedString, correctStrings ]
+        TooManyClose c                 -> [ Texts.lexerTooManyClose c ]
+        UnexpectedClose c1 _ c2        ->   Texts.lexerUnexpectedClose c1 c2
+        StillOpenAtEOF [b]             -> [ Texts.lexerStillOpenAtEOF [ show (snd b) ] ]
+        StillOpenAtEOF bs              -> [ Texts.lexerStillOpenAtEOF (reverse (map (show.snd) bs)) ]
+            -- 'reverse' because positions will be sorted and brackets are
+            -- reported in reversed order
+        ProblematicISO8601DateTime   -> [ Texts.lexerProblematicISO8601DateTime        ]
+correctStrings :: String
+correctStrings = Texts.lexerCorrectStrings
+
+-- | Defines a lexer warning
+data LexerWarning =
+    LexerWarning FilePos LexerWarningInfo -- ^ The lexer file position and warning information
+
+-- | Defines the different lexer warning types
+data LexerWarningInfo
+    = TabCharacter -- ^ Tab character was encountered
+    | NestedComment FilePos  -- ^ Nested comment was encountered
+    | UtfChar -- ^ The UTF BOM character was found
+    | CommentOperator -- ^ Syntax coloring cannot handle names containing --
+
+-- | Converts the warning information into a list of warning messages
+showLexerWarningInfo :: LexerWarningInfo  -- ^ The warning information
+                     -> [String] -- ^ The warning messages
+showLexerWarningInfo info = 
+    case info of
+        TabCharacter                    -> Texts.lexerTabCharacter
+        NestedComment _                 -> Texts.lexerNestedComment
+        UtfChar                         -> Texts.lexerUtfChar
+        CommentOperator                 -> Texts.lexerCommentOperator
+
+-- | Generates a TabCharacter warning
+keepOneTabWarning :: [LexerWarning] -- ^ The old warnings
+                  -> [LexerWarning] -- ^ The new warnings
+keepOneTabWarning = keepOneTab True
+  where
+    keepOneTab isFirst (warning@(LexerWarning _ TabCharacter):rest)
+        | isFirst   = warning : keepOneTab False rest
+        | otherwise = keepOneTab isFirst rest
+    keepOneTab isFirst (warning:rest) = 
+        warning : keepOneTab isFirst rest
+    keepOneTab _ [] = []
+ src/Database/Design/Ampersand/Input/ADL1/LexerMonad.hs view
@@ -0,0 +1,89 @@+{-| Module      :  LexerMonad
+    License     :  GPL
+
+    Maintainer  :  helium@cs.uu.nl
+    Stability   :  experimental
+    Portability :  portable
+-}
+
+module Database.Design.Ampersand.Input.ADL1.LexerMonad
+    ( LexerMonad
+    , addPos
+    , lexerError, lexerWarning
+    , runLexerMonad
+    ) where
+
+import Database.Design.Ampersand.Input.ADL1.LexerMessage
+import Database.Design.Ampersand.Input.ADL1.FilePos
+import Database.Design.Ampersand.Misc
+
+import Control.Applicative
+import Control.Monad
+
+type Bracket = (FilePos, Char)
+
+-- | The type of the Lexer Monad
+--   Output monad: [LexerWarning]
+--   State monad: FilePos and [Bracket]
+newtype LexerMonad a =
+    LM ([Options]   -- The command line options
+       -> FilePos   -- The position in the file
+       -> [Bracket] -- List of brackets
+       -> Either LexerError (a, [LexerWarning], FilePos, [Bracket]) -- The result is either an error or the result with a list of warnings, a file position and a list of brackets
+       )
+
+unLM :: LexerMonad t -> [Options] -> FilePos -> [Bracket]
+          -> Either LexerError (t, [LexerWarning], FilePos, [Bracket])
+unLM (LM x) = x
+
+bindLM :: LexerMonad a -> (a -> LexerMonad b) -> LexerMonad b
+bindLM (LM f) g =
+    LM (\opts pos brackets ->
+        case f opts pos brackets of
+            Left err -> Left err
+            Right (a, warnings, pos2, brackets2) ->
+                case unLM (g a) opts pos2 brackets2 of
+                    Left err -> Left err
+                    Right (b, moreWarnings, pos3, brackets3) ->
+                        Right (b, warnings ++ moreWarnings, pos3, brackets3))
+
+returnLM :: a -> LexerMonad a
+returnLM x = LM (\_ pos brackets -> Right (x, [], pos, brackets))
+
+instance Monad LexerMonad where
+    (>>=) = bindLM
+    return = returnLM
+
+instance Functor LexerMonad where
+    -- fmap :: (a -> b) -> LexerMonad a -> LexerMonad b
+    fmap ab la = do { a <- la; return (ab a) }
+
+instance Applicative LexerMonad where
+    pure = returnLM
+    (<*>) = ap
+
+-- | Runs the lexer monad
+runLexerMonad :: [Options]    -- ^ The command line options
+              -> FilePath     -- ^ The file to be read (used for error messages)
+              -> LexerMonad a -- ^ The lexer monad to run
+              -> Either LexerError (a, [LexerWarning]) -- ^ Result is either an error or a result and a list of warnings
+runLexerMonad opts file (LM f) =
+    case f opts (initPos file) [] of
+        Left err -> Left err
+        Right (a, warnings, _, _) -> Right (a, keepOneTabWarning warnings)
+
+-- | Generates a monad with an error message
+lexerError :: LexerErrorInfo -- ^ The generated error
+           -> FilePos        -- ^ The location where the error is originated
+           -> LexerMonad a   -- ^ The resulting monad
+lexerError err pos =
+    LM (\_ _ _ -> Left (LexerError pos err))
+
+-- | Generates a monad with a warning message
+lexerWarning :: LexerWarningInfo -- ^ The generated warning
+             -> FilePos          -- ^ The location where the warning is originated
+             -> LexerMonad ()    -- ^ The resulting monad
+lexerWarning warning warningPos =
+    LM (\_ pos brackets ->
+        Right ((), [LexerWarning warningPos warning], pos, brackets))
+
+ src/Database/Design/Ampersand/Input/ADL1/LexerTexts.hs view
@@ -0,0 +1,174 @@+module Database.Design.Ampersand.Input.ADL1.LexerTexts
+    ( lexerCommentOperator
+    , lexerCorrectStrings
+    , lexerNestedComment
+    , lexerNonTerminatedString
+    , lexerStillOpenAtEOF
+    , lexerTabCharacter
+    , lexerTooManyClose
+    , lexerUnexpectedChar
+    , lexerUnexpectedClose
+    , lexerUnterminatedAtom
+    , lexerUnterminatedComment
+    , lexerUnterminatedPurpose
+    , lexerProblematicISO8601DateTime
+    , lexerUtfChar
+    ) where
+
+import Data.IORef
+import System.IO.Unsafe
+import Data.Maybe (fromMaybe)
+
+data Language = English | Dutch deriving Eq
+
+{-# NOINLINE language #-}
+language :: IORef Language
+language = unsafePerformIO (newIORef English)
+
+data Arrow a b = a :-> b
+
+infix 0 :->
+
+select :: IORef Language -> [Arrow Language msg] -> msg
+select languageRef table =
+    let lang = unsafePerformIO (readIORef languageRef)
+        convert (a :-> b) = (a, b)
+    in fromMaybe (error "Texts.select: unknown language")
+        (lookup lang (map convert table))
+
+-- | Translates 'Unterminated comment' into the chosen language
+lexerUnterminatedComment :: String -- ^ The translated string
+lexerUnterminatedComment = select language
+    [ English :-> "Unterminated comment"
+    , Dutch   :-> "Commentaar niet afgesloten"
+    ]
+
+-- | Translates 'Unterminated purpose' into the chosen language
+lexerUnterminatedPurpose:: String -- ^ The translated string
+lexerUnterminatedPurpose= select language
+    [ English :-> "Unterminated PURPOSE section"
+    , Dutch   :-> "PURPOSE sectie niet afgesloten"
+    ]
+
+-- | Translates 'Unterminated atom' into the chosen language
+lexerUnterminatedAtom :: String -- ^ The translated string
+lexerUnterminatedAtom = select language
+    [ English :-> "Unterminated Atom literal"
+    , Dutch   :-> "Atom literal niet afgesloten"
+    ]
+-- | Translates 'ProblematicISO8601DateTime' into the chosen language
+lexerProblematicISO8601DateTime:: String 
+lexerProblematicISO8601DateTime = select language
+    [ English :-> "Incorrect DATETIME value (ISO 8601 standard)"
+    , Dutch   :-> "foutieve DATETIME waarde (Zie ISO 8601)"
+    ]
+-- | Translates 'Unexpected character' into the chosen language
+lexerUnexpectedChar :: Char -> String -- ^ The translated string
+lexerUnexpectedChar c = select language
+    [ English :-> "Unexpected character '" ++ [c] ++ "'"
+    , Dutch   :-> "Onverwachte letter '" ++ [c] ++ "'"
+    ]
+
+-- | Translates 'Unterminated string' into the chosen language
+lexerNonTerminatedString :: String -- ^ The translated string
+lexerNonTerminatedString = select language
+    [ English :-> "Unterminated string literal"
+    , Dutch   :-> "String niet afgesloten"
+    ]
+
+-- | Translates 'Close bracket but no open bracket' into the chosen language
+lexerTooManyClose :: Show a => a -> String -- ^ The translated string
+lexerTooManyClose c = select language
+    [ English :-> "Close bracket " ++ show c ++ " but no open bracket"
+    , Dutch   :-> "Haakje " ++ show c ++ " wordt gesloten maar nergens geopend"
+    ]
+
+-- | Translates 'Unexpected close bracket' into the chosen language
+lexerUnexpectedClose :: Char -> Char -> [String]
+lexerUnexpectedClose c1 c2 = select language
+    [ English :-> [ "Unexpected close bracket " ++ show c1
+                  , "Expecting a close bracket for " ++ show c2
+                  ]
+    , Dutch   :-> [ "Onverwacht sluithaakje " ++ show c1
+                  , "Sluithaakje voor " ++ show c2 ++ " wordt nog verwacht"
+                  ]
+    ]
+
+-- | Translates 'Bracket is never closed' into the chosen language
+lexerStillOpenAtEOF :: [String] -- ^ The brackets
+                    -> String -- ^ The translated string
+lexerStillOpenAtEOF [s] = select language
+    [ English :-> "Bracket " ++ s ++ " is never closed"
+    , Dutch   :-> "Sluithaakje voor " ++ s ++ " wordt nog verwacht"
+    ]
+
+-- | Translates 'Brackets are never closed' into the chosen language
+lexerStillOpenAtEOF xs = select language
+    [ English :-> "The following brackets are never closed: " ++ commasAnd xs
+    , Dutch   :-> "De volgende haakjes worden nergens gesloten: " ++ kommasEn xs
+    ]
+
+-- | Gives string examples in the chosen language
+lexerCorrectStrings :: String -- ^ The translated string
+lexerCorrectStrings = select language
+    [ English :-> "Correct examples of Strings: \"Ampersand (&) is cool\" \"Helium is cool too!\" \"abc\\ndef\" \"\""
+    , Dutch   :-> "Correcte voorbeelden van teksten: \"Ampersand (&) is geweldig\" \"Helium is ook geweldig!\" \"abc\\ndef\" \"\""
+    ]
+
+-- | Translates 'Tab character encountered' into the chosen language
+lexerTabCharacter :: [String] -- ^ The translated strings
+lexerTabCharacter = select language
+    [ English :-> [ "Tab character encountered; may cause problems with the layout rule"
+                  , "Configure your editor to replace tabs by spaces"
+                  ]
+    , Dutch   :-> [ "Tab karakters kunnen problemn opleveren met de layout rule"
+                  , "Stel je editor zo in dat hij tabs vervangt door spaties"
+                  ]
+    ]
+
+-- | Translates 'Unrecognized character' into the chosen language
+lexerUtfChar :: [String] -- ^ The translated strings
+lexerUtfChar = select language
+    [ English :-> [ "Unrecognized character in the beginning of the file."
+                  , "Is it saved with encoding UTF-8 without BOM?"
+                  ]
+    , Dutch   :-> [ "Onbekend karakter in het begin van het bestand."
+                  , "Is het bestand opgeslagen met encoding UTF-8 zonder BOM?"
+                  ]
+    ]
+
+-- | Translates 'Nested comment' into the chosen language
+lexerNestedComment :: [String] -- ^ The translated strings
+lexerNestedComment = select language
+    [ English :-> [ "Syntax coloring usually can not handle nested comments"
+                  , "Some of your code may be in comments but not visibly so"
+                  ]
+    , Dutch   :-> [ "Syntax kleuring van editor kan meestal niet overweg met genest commentaar"
+                  , "Het kan zo zijn dat een deel van je code in commentaar staat maar dat je dat niet ziet"
+                  ]
+    ]
+
+-- | Translates 'Comment operator' into the chosen language
+lexerCommentOperator :: [String] -- ^ The translated strings
+lexerCommentOperator = select language
+    [ English :-> [ "Syntax coloring usually cannot handle names containing --"
+                  , "If you wanted to start a comment, write spaces around --"
+                  ]
+    , Dutch   :-> [ "Syntax kleuring van editor kan meestal niet overweg met namen die -- bevatten"
+                  , "Als je commentaar wilde beginnen schrijf dan spaties voor en na --"
+                  ]
+    ]
+
+-- | Adds commas and 'and' in between each element of the list
+commasAndLang :: String   -- ^ The word to use for 'and'
+              -> [String] -- ^ The list of items to show
+              -> String   -- ^ The result
+commasAndLang _ [] = []
+commasAndLang _ [x] = x
+commasAndLang a (x:xs) = x ++ concatMap (", " ++) (init xs) ++ " " ++ a ++ " " ++ last xs
+
+commasAnd :: [String] -> String
+commasAnd = commasAndLang "and"
+
+kommasEn :: [String] -> String
+kommasEn = commasAndLang "en"
+ src/Database/Design/Ampersand/Input/ADL1/LexerToken.hs view
@@ -0,0 +1,86 @@+module Database.Design.Ampersand.Input.ADL1.LexerToken
+    ( Token(..)
+    , Lexeme(..)
+    , lexemeText
+    , initPos
+    , FilePos(..)
+    ) where
+
+import Database.Design.Ampersand.Input.ADL1.FilePos (FilePos(..), initPos)
+import Text.Parsec()
+import Data.Time.Calendar
+import Data.Time.Clock
+import Data.Time.LocalTime() -- for instance Show UTCTime
+
+-- | The Ampersand token
+data Token = Tok { tokLex :: Lexeme  -- ^ The lexeme
+                 , tokPos :: FilePos -- ^ The position where the lexeme was found
+                 }
+
+instance Show Token where
+  show (Tok lx p) = show lx ++ " " ++ show p
+
+-- | The Ampersand Lexemes
+data Lexeme  = LexSymbol      Char    -- ^ A symbol
+             | LexOperator    String  -- ^ An operator
+             | LexKeyword     String  -- ^ A keyword
+             | LexString      String  -- ^ A quoted string
+             | LexExpl        String  -- ^ An explanation
+             | LexSingleton   String  -- ^ An atomvalue in an Expression
+             | LexDecimal     Int     -- ^ A decimal number
+             | LexFloat      Double   -- ^ A decimal floating point thing
+             | LexOctal       Int     -- ^ An octal number
+             | LexHex         Int     -- ^ A hexadecimal number
+             | LexConId       String  -- ^ An upper case identifier
+             | LexVarId       String  -- ^ A lower case identifier
+             | LexDateTime    UTCTime -- ^ A date-time
+             | LexDate        Day     -- ^ A date
+  deriving (Eq, Ord)
+
+instance Show Lexeme where
+    show x = case x of
+         LexSymbol   val -> "symbol "                ++ "'"  ++     [val] ++ "'"
+         LexOperator val -> "operator "              ++ "'"  ++      val  ++ "'"
+         LexKeyword  val -> "keyword "               ++         show val
+         LexString   val -> "string "                ++ "\"" ++      val  ++ "\""
+         LexExpl     val -> "explanation "           ++ "{+" ++      val  ++ "+}"
+         LexSingleton val -> "singleton "            ++ "'"  ++      val  ++ "'"
+         LexDecimal   _  -> "integer "               ++   lexemeText  x
+         LexFloat     _  -> "float "                 ++   lexemeText  x
+         LexOctal     _  -> "octal "                 ++   lexemeText  x
+         LexHex       _  -> "hexadecimal "           ++   lexemeText  x
+         LexVarId    val -> "lower case identifier " ++              val
+         LexConId    val -> "upper case identifier " ++              val
+         LexDateTime _   -> "iso 8601 date time "    ++   lexemeText  x
+         LexDate     _   -> "iso 8601 date "         ++   lexemeText  x
+         
+-- A Stream instance is responsible for maintaining the "position within the stream" in the stream state (Token).
+-- This is trivial unless you are using the monad in a non-trivial way.
+-- instance (Monad m) => Stream [Token] m Char where
+--  uncons :: (Monad m) => [Token] -> m (Maybe (Char, [Token]))
+--    uncons []     = return $ Nothing
+--    uncons (t:ts) = return $ Just (t,ts)
+
+-- | Retrieves the text from a lexeme
+lexemeText :: Lexeme -- ^ The lexeme
+           -> String -- ^ The text contained in the lexeme
+lexemeText l = case l of
+         LexSymbol   val -> [val]
+         LexOperator val -> val
+         LexKeyword  val -> val
+         LexString   val -> val
+         LexExpl     val -> val
+         LexSingleton val -> val
+         LexDecimal  val -> show val
+         LexFloat    val -> show val
+         LexOctal    val -> "0o" ++ toBase 8  val
+         LexHex      val -> "0x" ++ toBase 16 val
+         LexConId    val -> val
+         LexVarId    val -> val
+         LexDateTime val -> show val
+         LexDate     val -> show val
+
+toBase :: Integral a => Show a => a -> a -> String
+toBase b x = conv x ""
+       where conv 0 str = str
+             conv n str = conv (n `div` b) (show (n `mod` b) ++ str)
src/Database/Design/Ampersand/Input/ADL1/Parser.hs view
@@ -1,823 +1,771 @@ {-# 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]
+    ( AmpParser
+    , pContext
+    , pPopulations
+    , pTerm
+    , pRule
+    ) where
+
+import Database.Design.Ampersand.Basics
+import Database.Design.Ampersand.Core.ParseTree
+import Database.Design.Ampersand.Input.ADL1.ParsingLib
+import Data.List
+import Data.Maybe
+import Control.Applicative(pure)
+
+fatal :: Int -> String -> a
+fatal = fatalMsg "Input.ADL1.Parser"
+
+--- Populations ::= Population+
+-- | Parses a list of populations
+pPopulations :: AmpParser [P_Population] -- ^ The population list parser
+pPopulations = many1 pPopulation
+
+--- Context ::= 'CONTEXT' ConceptName LanguageRef TextMarkup? ContextElement* 'ENDCONTEXT'
+-- | Parses a context
+pContext :: AmpParser (P_Context, [String]) -- ^ The result is the parsed context and a list of include filenames
+pContext  = rebuild <$> posOf (pKey "CONTEXT")
+                    <*> pConceptName
+                    <*> pLanguageRef
+                    <*> pMaybe pTextMarkup
+                    <*> many 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 to be printed in the functional specification. (For partial documents.)
+            , ctx_pats   = [p | CPat p<-ces]       -- The patterns defined in this context
+            , ctx_rs     = [p | CRul p<-ces]       -- All user defined rules in this context, but outside patterns
+            , 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] ++ [y | CCfy y<-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 = [x | Cm x <-ces]        -- The MAINTAINS statements in the context
+            , ctx_rrels  = [x | Cl x <-ces]        -- The EDITS statements in the context
+            , ctx_reprs  = [r | CRep r<-ces] 
+            , 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
+       ) 
+      
+    --- ContextElement ::= Meta | PatternDef | ProcessDef | RuleDef | Classify | RelationDef | ConceptDef | GenDef | Index | ViewDef | Interface | Sqlplug | Phpplug | Purpose | Population | PrintThemes | IncludeStatement
+    pContextElement :: AmpParser ContextElement
+    pContextElement = CMeta    <$> pMeta         <|>
+                      CPat     <$> pPatternDef   <|>
+                      CPat     <$> pProcessDef   <|>
+                      CRul     <$> pRuleDef      <|>
+                      CCfy     <$> pClassify     <|>
+                      CRel     <$> pRelationDef  <|>
+                      CCon     <$> pConceptDef   <|>
+                      CRep     <$> pRepresentation <|>
+                      Cm       <$> pRoleRule     <|>
+                      Cm       <$> pServiceRule  <|>
+                      Cl       <$> pRoleRelation <|>
+                      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
+                    | CRul (P_Rule TermPrim)
+                    | CCfy P_Gen
+                    | CRel P_Declaration
+                    | CCon (String -> ConceptDef)
+                    | CRep Representation
+                    | Cm P_RoleRule
+                    | Cl P_RoleRelation
+                    | 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
+
+--- IncludeStatement ::= 'INCLUDE' String
+pIncludeStatement :: AmpParser String
+pIncludeStatement = pKey "INCLUDE" *> pString
+
+--- LanguageRef ::= 'IN' ('DUTCH' | 'ENGLISH')
+pLanguageRef :: AmpParser Lang
+pLanguageRef = pKey "IN" *>
+               (Dutch   <$ pKey "DUTCH"   <|>
+                English <$ pKey "ENGLISH")
+
+--- TextMarkup ::= 'REST' | 'HTML' | 'LATEX' | 'MARKDOWN'
+pTextMarkup :: AmpParser PandocFormat
+pTextMarkup = ReST     <$ pKey "REST"     <|>
+              HTML     <$ pKey "HTML"     <|>
+              LaTeX    <$ pKey "LATEX"    <|>
+              Markdown <$ pKey "MARKDOWN"
+
+--- Meta ::= 'META' String String
+pMeta :: AmpParser Meta
+pMeta = Meta <$> currPos <* pKey "META" <*> pMetaObj <*> pString <*> pString
+ where pMetaObj = return ContextMeta -- for the context meta we don't need a keyword
+
+--- PatternDef ::= 'PATTERN' ConceptName PatElem* 'ENDPATTERN'
+pPatternDef :: AmpParser P_Pattern
+pPatternDef = rebuild <$> currPos
+                      <*  pKey "PATTERN"
+                      <*> pConceptName   -- The name spaces of patterns, processes and concepts are shared.
+                      <*> many pPatElem
+                      <*> currPos
+                      <*  pKey "ENDPATTERN"
+  where
+    rebuild :: Origin -> String -> [PatElem] -> Origin -> P_Pattern
+    rebuild pos' nm pes end
+     = P_Pat { pt_pos = pos'
+             , pt_nm  = nm
+             , pt_rls = [r | Pr r<-pes]
+             , pt_gns = [y | Py y<-pes] ++ [g | Pg g<-pes]
+             , pt_dcs = [d | Pd d<-pes]
+             , pt_RRuls = [rr | Pm rr<-pes]
+             , pt_RRels = [rr | Pl rr<-pes]
+             , pt_cds = [c nm | Pc c<-pes]
+             , pt_Reprs = [x | Prep x<-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]
+             , pt_end = end
+             }
+
+--- ProcessDef ::= 'PROCESS' ConceptName PatElem* 'ENDPROCESS'
+pProcessDef :: AmpParser P_Pattern
+pProcessDef = rebuild <$> currPos
+                      <*  pKey "PROCESS"
+                      <*> pConceptName   -- The name spaces of patterns, processes and concepts are shared.
+                      <*> many pPatElem
+                      <*> currPos
+                      <*  pKey "ENDPROCESS"
+  where
+    rebuild :: Origin -> String -> [PatElem] -> Origin -> P_Pattern
+    rebuild pos' nm pes end
+     = P_Pat { pt_pos = pos'
+             , pt_nm  = nm
+             , pt_rls = [r | Pr r<-pes]
+             , pt_gns = [y | Py y<-pes] ++ [g | Pg g<-pes]
+             , pt_dcs = [d | Pd d<-pes]
+             , pt_RRuls = [rr | Pm rr<-pes]
+             , pt_RRels = [rr | Pl rr<-pes]
+             , pt_Reprs = [r | Prep 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]
+             , pt_end = end
+             }
+
+-- PatElem used by PATTERN and PROCESS
+--- PatElem ::= RuleDef | Classify | RelationDef | ConceptDef | GenDef | Index | ViewDef | Purpose | Population
+pPatElem :: AmpParser PatElem
+pPatElem = Pr <$> pRuleDef          <|>
+           Py <$> pClassify         <|>
+           Pd <$> pRelationDef      <|>
+                   -- the syntax of pRoleRule and pRoleRelation shows an ambiguity
+                   -- Syntax review can be considered
+           Pm <$> pRoleRule         <|>
+           Pm <$> pServiceRule      <|>
+           Pl <$> pRoleRelation     <|>
+           Pc <$> pConceptDef       <|>
+           Pg <$> pGenDef           <|>
+           Prep <$> pRepresentation <|>
+           Pk <$> pIndex            <|>
+           Pv <$> pViewDef          <|>
+           Pe <$> pPurpose          <|>
+           Pp <$> pPopulation
+
+data PatElem = Pr (P_Rule TermPrim)
+             | Py P_Gen
+             | Pd P_Declaration
+             | Pm P_RoleRule
+             | Pl P_RoleRelation
+             | Pc (String -> ConceptDef)
+             | Pg P_Gen
+             | Prep Representation
+             | Pk P_IdentDef
+             | Pv P_ViewDef
+             | Pe PPurpose
+             | Pp P_Population
+
+--- Classify ::= 'CLASSIFY' ConceptRef 'IS' Cterm
+pClassify :: AmpParser P_Gen   -- Example: CLASSIFY A IS B /\ C /\ D
+pClassify = try (P_Cy <$> currPos
+                      <* pKey "CLASSIFY"
+                      <*> pConceptRef
+                      <*  pKey "IS")
+                 <*> pCterm
+               where
+                 --- Cterm ::= Cterm1 ('/\' Cterm1)*
+                 --- Cterm1 ::= ConceptRef | ('('? Cterm ')'?)
+                 pCterm  = concat <$> pCterm1 `sepBy1` pOperator "/\\"
+                 pCterm1 = pure   <$> pConceptRef <|>
+                           id     <$> pParens pCterm  -- brackets are allowed for educational reasons.
+
+--- RuleDef ::= 'RULE' Label? Rule Meaning* Message* Violation?
+pRuleDef :: AmpParser (P_Rule TermPrim)
+pRuleDef =  P_Ru <$> currPos
+                 <*  pKey "RULE"
+                 <*> (try pLabel <|> rulid <$> currPos)
+                 <*> pRule
+                 <*> many pMeaning
+                 <*> many pMessage
+                 <*> pMaybe pViolation
+           where rulid (FileLoc pos _) = show("rule@" ++(show pos))
+                 rulid _ = fatal 226 "pRuleDef is expecting a file location."
+
+                 --- Violation ::= 'VIOLATION' PairView
+                 pViolation :: AmpParser (PairView (Term TermPrim))
+                 pViolation = id <$ pKey "VIOLATION" <*> pPairView
+
+                 --- PairView ::= '(' PairViewSegmentList ')'
+                 pPairView :: AmpParser (PairView (Term TermPrim))
+                 pPairView = PairView <$> pParens (pPairViewSegment `sepBy1` pComma)
+
+                 --- PairViewSegmentList ::= PairViewSegment (',' PairViewSegment)*
+                 --- PairViewSegment ::= 'SRC' Term | 'TGT' Term | 'TXT' String
+                 pPairViewSegment :: AmpParser (PairViewSegment (Term TermPrim))
+                 pPairViewSegment = PairViewExp  <$> posOf (pKey "SRC") <*> return Src <*> pTerm
+                                <|> PairViewExp  <$> posOf (pKey "TGT") <*> return Tgt <*> pTerm
+                                <|> PairViewText <$> posOf (pKey "TXT") <*> pString
+
+--- RelationDef ::= (RelationNew | RelationOld) 'BYPLUG'? Props? 'BYPLUG'? ('PRAGMA' String+)? Meaning* ('=' Content)? '.'?
+pRelationDef :: AmpParser P_Declaration
+pRelationDef = reorder <$> currPos
+                       <*> (pRelationNew <|> pRelationOld)
+                       <*> pIsThere (pKey "BYPLUG")
+                       <*> optList pProps
+                       <*> pIsThere (pKey "BYPLUG")
+                       <*> optList (pKey "PRAGMA" *> many1 pString)
+                       <*> many pMeaning
+                       <*> optList (pOperator "=" *> pContent)
+                       <*  optList (pOperator ".")
+            where reorder pos (nm,sign,fun) bp1 prop bp2 pragma meanings popu =
+                    let plug = bp1 || bp2
+                        props = prop ++ fun
+                    in P_Sgn nm sign props pragma meanings popu pos plug
+
+--- RelationNew ::= 'RELATION' Varid Signature
+pRelationNew :: AmpParser (String,P_Sign,Props)
+pRelationNew = (,,) <$  pKey "RELATION"
+                    <*> pVarid
+                    <*> pSign
+                    <*> return []
+
+--- RelationOld ::= Varid '::' ConceptRef Fun ConceptRef
+pRelationOld :: AmpParser (String,P_Sign,Props)
+pRelationOld = relOld <$> pVarid
+                      <*  pOperator "::"
+                      <*> pConceptRef
+                      <*> pFun
+                      <*> pConceptRef
+            where relOld nm src fun tgt = (nm,P_Sign src tgt,fun)
+
+--- Props ::= '[' PropList? ']'
+pProps :: AmpParser [Prop]
+pProps  = normalizeProps <$> pBrackets (pProp `sepBy` pComma)
+        --- PropList ::= Prop (',' Prop)*
+        --- Prop ::= 'UNI' | 'INJ' | 'SUR' | 'TOT' | 'SYM' | 'ASY' | 'TRN' | 'RFX' | 'IRF' | 'AUT' | 'PROP'
+  where pProp :: AmpParser Prop
+        pProp = choice [ p <$ pKey (show p) | p <- [minBound..] ]
+
+--- Fun ::= '*' | '->' | '<-' | '[' Mults ']'
+pFun :: AmpParser [Prop]
+pFun  = []        <$ pOperator "*"  <|>
+        [Uni,Tot] <$ pOperator "->" <|>
+        [Sur,Inj] <$ pOperator "<-" <|>
+        pBrackets pMults
+        --- Mults ::= Mult '-' Mult
+  where pMults :: AmpParser [Prop]
+        pMults = (++) <$> optList (pMult (Sur,Inj))
+                      <*  pDash
+                      <*> optList (pMult (Tot,Uni))
+
+        --- Mult ::= ('0' | '1') '..' ('1' | '*') | '*' | '1'
+        --TODO: refactor to Mult ::= '0' '..' ('1' | '*') | '1'('..' ('1' | '*'))? | '*'
+        pMult :: (Prop,Prop) -> AmpParser [Prop]
+        pMult (ts,ui) = (++) <$> ([]    <$ pZero   <|> [ts] <$ try pOne)
+                             <*  pOperator ".."
+                             <*> ([ui] <$ try pOne <|> ([]   <$ pOperator "*" )) <|>
+                        [] <$ pOperator "*"  <|>
+                        [ts,ui] <$ try pOne
+
+--- ConceptDef ::= 'CONCEPT' ConceptName 'BYPLUG'? String ('TYPE' String)? String?
+pConceptDef :: AmpParser (String->ConceptDef)
+pConceptDef       = Cd <$> currPos
+                       <*  pKey "CONCEPT"
+                       <*> pConceptName
+                       <*> pIsThere (pKey "BYPLUG")
+                       <*> (pString <?> "concept definition (string)")
+                       <*> (pString `opt` "") -- a reference to the source of this definition.
+
+--- Representation ::= 'REPRESENT' ConceptNameList 'TYPE' AdlTType
+pRepresentation :: AmpParser Representation
+pRepresentation 
+  = Repr <$> currPos
+         <*  pKey "REPRESENT"
+         <*> pConceptName `sepBy1` pComma
+         <*  pKey "TYPE"
+         <*> pAdlTType
+--- AdlTType = ...<enumeration>
+pAdlTType :: AmpParser TType
+pAdlTType
+        = k Alphanumeric     "ALPHANUMERIC"
+      <|> k BigAlphanumeric  "BIGALPHANUMERIC"
+      <|> k HugeAlphanumeric "HUGEALPHANUMERIC"
+      <|> k Password         "PASSWORD"
+      <|> k Binary           "BINARY"
+      <|> k BigBinary        "BIGBINARY"
+      <|> k HugeBinary       "HUGEBINARY"
+      <|> k Date             "DATE"
+      <|> k DateTime         "DATETIME"
+      <|> k Boolean          "BOOLEAN"
+      <|> k Integer          "INTEGER"
+      <|> k Float            "FLOAT"
+      
+  where
+   k tt str = f <$> pKey str where f _ = tt
+
+--- GenDef ::= ('CLASSIFY' | 'SPEC') ConceptRef 'ISA' ConceptRef
+pGenDef :: AmpParser P_Gen
+pGenDef = try (PGen <$> currPos <* key <*> pConceptRef <* pKey "ISA") <*> pConceptRef --
+          where key = pKey "CLASSIFY" <|> pKey "SPEC"
+
+-- | 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].
+--- Index ::= 'IDENT' Label ConceptRef '(' IndSegmentList ')'
+pIndex :: AmpParser P_IdentDef
+pIndex  = P_Id <$> currPos
+               <*  pKey "IDENT"
+               <*> pLabel
+               <*> pConceptRef
+               <*> pParens (pIndSegment `sepBy1` pComma)
+    where
+          --- IndSegmentList ::= Att (',' Att)*
+          pIndSegment :: AmpParser P_IdentSegment
+          pIndSegment = P_IdentExp <$> pAtt
+
+-- | 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.
+
+--- ViewDef ::= FancyViewDef | ViewDefLegacy
+pViewDef :: AmpParser P_ViewDef
+pViewDef = try pFancyViewDef <|> try pViewDefLegacy -- introduces backtracking, but is more elegant than rewriting pViewDefLegacy to disallow "KEY ... ENDVIEW".
+
+--- FancyViewDef ::= 'VIEW' Label ConceptOneRef 'DEFAULT'? ('{' ViewObjList? '}')?  HtmlView? 'ENDVIEW'
+pFancyViewDef :: AmpParser P_ViewDef
+pFancyViewDef  = mkViewDef <$> currPos
+                      <*  pKey "VIEW"
+                      <*> pLabel
+                      <*> pConceptOneRef
+                      <*> pIsThere (pKey "DEFAULT")
+                      <*> (pBraces ((P_ViewExp fatl <$> pViewObj) `sepBy` pComma)) `opt` []
+                      <*> pMaybe pHtmlView
+                      <*  pKey "ENDVIEW"
+    where mkViewDef pos nm cpt isDef ats html =
+            P_Vd { vd_pos = pos
+                 , vd_lbl = nm
+                 , vd_cpt = cpt
+                 , vd_isDefault = isDef
+                 , vd_html = html
+                 , vd_ats = numbered ats
+                 }
+          fatl = fatal 363 "Numbering of segment goes wrong."
+          numbered xs = map numbr (zip [1..] xs)
+              where numbr (i,x)= x{vs_nr=i}
+          --- ViewObjList ::= ViewObj (',' ViewObj)*
+          --- ViewObj ::= Label Term
+          pViewObj :: AmpParser P_ObjectDef
+          pViewObj = P_Obj <$> pLabel
+                           <*> currPos
+                           <*> pTerm
+                           <*> return Nothing
+                           <*> return Nothing
+                           <*> return []
+
+          --- HtmlView ::= 'HTML' 'TEMPLATE' String
+          pHtmlView :: AmpParser ViewHtmlTemplate
+          pHtmlView = ViewHtmlTemplateFile <$ pKey "HTML" <* pKey "TEMPLATE" <*> pString
+
+--- ViewDefLegacy ::= 'VIEW' LabelProps ConceptOneRef '(' ViewSegmentList ')'
+pViewDefLegacy :: AmpParser P_ViewDef
+pViewDefLegacy = P_Vd <$> currPos
+                      <*  pKey "VIEW"
+                      <*> pLabel
+                      <*> pConceptOneRef
+                      <*> return True
+                      <*> return Nothing
+                      <*> pParens(ats <$> pViewSegment `sepBy1` pComma)
+    --TODO: Numbering should not happen in the parser
+    where ats xs = [ case viewSeg of
+                         P_ViewExp _ x  -> if null (obj_nm x) then P_ViewExp i $ x{obj_nm="seg_"++show i} 
+                                                              else P_ViewExp i x 
+                         P_ViewText _ x -> P_ViewText i x
+                         P_ViewHtml _ x -> P_ViewHtml i x
+                         
+                    | (i,viewSeg) <- zip [(1::Integer)..] xs]
+                    -- counter is used to name anonymous segments (may skip numbers because text/html segments are also counted)
+          --- ViewSegmentList ::= ViewSegment (',' ViewSegment)*
+          --- ViewSegment ::= Att | 'TXT' String | 'PRIMHTML' String
+          pViewSegment :: AmpParser P_ViewSegment
+          pViewSegment = P_ViewExp  fat <$> pAtt <|>
+                         P_ViewText fat <$ pKey "TXT" <*> pString <|>
+                         P_ViewHtml fat <$ pKey "PRIMHTML" <*> pString
+               where fat = fatal 399 "numbering is done a little later."
+
+--- Interface ::= 'INTERFACE' ADLid 'CLASS'? (Conid | String) Params? InterfaceArgs? Roles? ':' Term SubInterface
+pInterface :: AmpParser P_Interface
+pInterface = lbl <$> currPos                                       <*>
+                     (pKey "INTERFACE" *> pADLid)                  <*>
+                     pMaybe (pKey "CLASS" *> (pConid <|> pString)) <*> -- the class is an upper-case identifier or a quoted string
+                     optList pParams                               <*> -- a list of expressions, which say which relations are editable within this service.
+                     optList pArgs                                 <*> -- either  Prel _ nm or  PNamedRel _ nm sgn
+                     optList pRoles                                <*>
+                     (pColon *> pTerm)                             <*>
+                     pSubInterface
+    where lbl :: Origin -> String -> Maybe String -> [P_NamedRel] -> [[String]] -> [Role] -> Term TermPrim -> P_SubInterface -> P_Interface
+          lbl p nm iclass params args roles term 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  = term
+                                          , 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.
+                     }
+          --- Params ::= '(' NamedRel ')'
+          pParams = pParens(pNamedRel `sepBy1` pComma)
+          --- InterfaceArgs ::= '{' ADLidListList '}'
+          pArgs   = pBraces(many1 pADLid `sepBy1` pComma)
+          --- Roles ::= 'FOR' RoleList
+          pRoles  = pKey "FOR" *> (pRole False) `sepBy1` pComma
+
+--- SubInterface ::= ('BOX' ('<' Conid '>')? | 'ROWS' | 'COLS') Box | 'LINKTO'? 'INTERFACE' ADLid
+pSubInterface :: AmpParser P_SubInterface
+pSubInterface = P_Box          <$> currPos <*> pBoxKey <*> pBox
+            <|> P_InterfaceRef <$> currPos <*> pIsThere (pKey "LINKTO") <*  pKey "INTERFACE" <*> pADLid
+  where pBoxKey :: AmpParser (Maybe String)
+        pBoxKey = pKey "BOX" *> pMaybe (pChevrons pConid)
+              <|> Just <$> pKey "ROWS"
+              <|> Just <$> pKey "COLS"
+              <|> Just <$> pKey "TABS"
+
+--- ObjDef ::= LabelProps Term ('<' Conid '>')? SubInterface?
+--- ObjDefList ::= ObjDef (',' ObjDef)*
+pObjDef :: AmpParser P_ObjectDef
+pObjDef = obj <$> currPos
+              <*> pLabelProps
+              <*> pTerm            -- the context expression (for example: I[c])
+              <*> pMaybe (pChevrons pConid)
+              <*> pMaybe pSubInterface  -- the optional subinterface
+         where obj pos (nm, args) ctx mView msub =
+                 P_Obj nm pos ctx mView msub args
+
+--- Box ::= '[' ObjDefList ']'
+pBox :: AmpParser [P_ObjectDef]
+pBox = pBrackets $ pObjDef `sepBy1` pComma
+
+--- Sqlplug ::= 'SQLPLUG' ObjDef
+pSqlplug :: AmpParser P_ObjectDef
+pSqlplug = pKey "SQLPLUG" *> pObjDef
+
+--- Phpplug ::= 'PHPPLUG' ObjDef
+pPhpplug :: AmpParser P_ObjectDef
+pPhpplug = pKey "PHPPLUG" *> pObjDef
+
+--- Purpose ::= 'PURPOSE' Ref2Obj LanguageRef? TextMarkup? ('REF' StringListSemi)? Expl
+pPurpose :: AmpParser PPurpose
+pPurpose = rebuild <$> currPos
+                   <*  pKey "PURPOSE"  -- "EXPLAIN" has become obsolete
+                   <*> pRef2Obj
+                   <*> pMaybe pLanguageRef
+                   <*> pMaybe pTextMarkup
+                   <*> optList (pKey "REF" *> pString `sepBy1` pSemi)
+                   <*> 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)
+              -- TODO: This separation should not happen in the parser
+              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)
+       --- Ref2Obj ::= 'CONCEPT' ConceptName | 'RELATION' NamedRel | 'RULE' ADLid | 'IDENT' ADLid | 'VIEW' ADLid | 'PATTERN' ADLid | 'PROCESS' ADLid | 'INTERFACE' ADLid | 'CONTEXT' ADLid
+       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
+
+--- Population ::= 'POPULATION' (NamedRel 'CONTAINS' Content | ConceptName 'CONTAINS' '[' ValueList ']')
+-- | Parses a population
+pPopulation :: AmpParser P_Population -- ^ The population parser
+pPopulation = pKey "POPULATION" *> (
+                  (P_RelPopu Nothing Nothing) <$> currPos <*> pNamedRel    <* pKey "CONTAINS" <*> pContent <|>
+                  P_CptPopu <$> currPos <*> pConceptName <* pKey "CONTAINS" <*> pBrackets (pAtomValue `sepBy` pComma))
+
+--- RoleRelation ::= 'ROLE' RoleList 'EDITS' NamedRelList
+pRoleRelation :: AmpParser P_RoleRelation
+pRoleRelation = try (P_RR <$> currPos
+                          <*  pKey "ROLE"
+                          <*> (pRole False) `sepBy1` pComma
+                          <*  pKey "EDITS")
+                    <*> pNamedRel `sepBy1` pComma
+
+--- RoleRule ::= 'ROLE' RoleList 'MAINTAINS' ADLidList
+--TODO: Rename the RoleRule to RoleMantains and RoleRelation to RoleEdits.
+pRoleRule :: AmpParser P_RoleRule
+pRoleRule = try (Maintain <$> currPos
+                          <*  pKey "ROLE"
+                          <*> (pRole False) `sepBy1` pComma
+                          <*  pKey "MAINTAINS")
+                <*> pADLid `sepBy1` pComma
+--- ServiceRule ::= 'SERVICE' RoleList 'MAINTAINS' ADLidList
+--TODO: Rename the RoleRule to RoleMantains and RoleRelation to RoleEdits.
+pServiceRule :: AmpParser P_RoleRule
+pServiceRule = try (Maintain <$> currPos
+                          <*  pKey "SERVICE"
+                          <*> (pRole True) `sepBy1` pComma
+                          <*  pKey "MAINTAINS")
+                <*> pADLid `sepBy1` pComma
+
+--- Role ::= ADLid
+--- RoleList ::= Role (',' Role)*
+pRole :: Bool -> AmpParser Role
+pRole isService =  (if isService then Service else Role) <$> pADLid
+
+--- PrintThemes ::= 'THEMES' ConceptNameList
+pPrintThemes :: AmpParser [String]
+pPrintThemes = pKey "THEMES"
+            *> pConceptName `sepBy1` pComma -- Patterns, processes and concepts share the same name space, so these names must be checked whether the processes and patterns exist.
+
+--- Meaning ::= 'MEANING' LanguageRef? TextMarkup? (String | Expl)
+pMeaning :: AmpParser PMeaning
+pMeaning = PMeaning <$> (
+           P_Markup <$  pKey "MEANING"
+                    <*> pMaybe pLanguageRef
+                    <*> pMaybe pTextMarkup
+                    <*> (pString <|> pExpl))
+
+--- Message ::= 'MESSAGE' Markup
+pMessage :: AmpParser PMessage
+pMessage = PMessage <$ pKey "MESSAGE" <*> pMarkup
+
+--- Markup ::= LanguageRef? TextMarkup? (String | Expl)
+pMarkup :: AmpParser P_Markup
+pMarkup = P_Markup
+           <$> pMaybe pLanguageRef
+           <*> pMaybe pTextMarkup
+           <*> (pString <|> pExpl)
+
+--- Rule ::= Term ('=' Term | '|-' Term)?
+-- | Parses a rule
+pRule :: AmpParser (Term TermPrim) -- ^ The rule parser
+pRule  =  pTerm <??> (invert PEqu  <$> currPos <* pOperator "="  <*> pTerm <|>
+                      invert PInc  <$> currPos <* pOperator "|-" <*> pTerm)
+
+
+{-
+pTerm 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.
+-}
+--- Term ::= Trm2 (('/\' Trm2)+ | ('\/' Trm2)+)?
+-- | Parses a term
+pTerm :: AmpParser (Term TermPrim) -- ^ The term parser
+pTerm = pTrm2 <??> (invertT PIsc <$> rightAssociate PIsc "/\\" pTrm2 <|>
+                    invertT PUni <$> rightAssociate PUni "\\/" pTrm2)
+
+-- The left factored version of difference: (Actually, there is no need for left-factoring here, but no harm either)
+--- Trm2 ::= Trm3 ('-' Trm3)?
+pTrm2 :: AmpParser (Term TermPrim)
+pTrm2   = pTrm3 <??> (invert PDif <$> posOf pDash <*> pTrm3)
+
+-- The left factored version of right- and left residuals:
+--- Trm3 ::= Trm4 ('/' Trm4 | '\' Trm4 | '<>' Trm4)?
+pTrm3 :: AmpParser (Term TermPrim)
+pTrm3  =  pTrm4 <??> (invert PLrs <$> currPos <* pOperator "/"  <*> pTrm4 <|>
+                      invert PRrs <$> currPos <* pOperator "\\" <*> pTrm4 <|>
+                      invert PDia <$> currPos <* pOperator "<>" <*> pTrm4 )
+
+-- composition and relational addition are associative, and parsed similar to union and intersect...
+--- Trm4 ::= Trm5 ((';' Trm5)+ | ('!' Trm5)+ | ('#' Trm5)+)?
+pTrm4 :: AmpParser (Term TermPrim)
+pTrm4   = pTrm5 <??> (invertT PCps <$> rightAssociate PCps ";" pTrm5 <|>
+                      invertT PRad <$> rightAssociate PRad "!" pTrm5 <|>
+                      invertT PPrd <$> rightAssociate PPrd "#" pTrm5)
+
+--- Trm5 ::= '-'* Trm6 ('~' | '*' | '+')*
+pTrm5 :: AmpParser (Term TermPrim)
+--TODO: Separate into prefix and postfix top-level functions
+pTrm5  =  f <$> many (valPosOf pDash) <*> pTrm6  <*> many (valPosOf (pOperator "~" <|> pOperator "*" <|> pOperator "+" ))
+          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
+
+--- Trm6 ::= RelationRef | '(' Term ')'
+pTrm6 :: AmpParser (Term TermPrim)
+pTrm6 = Prim <$> pRelationRef  <|>
+        PBrk <$> currPos <*> pParens pTerm
+
+-- Help function for several expressions. The type 't' is each of the terms.
+invert :: (Origin -> t -> t -> t) -> Origin -> t -> t -> t
+invert constructor position rightTerm leftTerm = constructor position leftTerm rightTerm
+
+-- Variant for the above function with a tuple, for usage with right association
+invertT :: (Origin -> t -> t -> t) -> (Origin, t) -> t -> t
+invertT constructor (position,rightTerm) leftTerm = constructor position leftTerm rightTerm
+
+-- Help function for pTerm and pTrm4, to allow right association
+rightAssociate :: (Origin -> t -> t -> t) -> String -> AmpParser t -> AmpParser (Origin, t)
+rightAssociate combinator operator term
+                 = g <$> currPos <* pOperator operator <*> term <*> pMaybe (rightAssociate combinator operator term)
+                          where g orig y Nothing  = (orig, y)
+                                g orig y (Just (org,z)) = (orig, combinator org y z)
+
+--- RelationRef ::= NamedRel | 'I' ('[' ConceptOneRef ']')? | 'V' Signature? | Singleton ('[' ConceptOneRef ']')?
+pRelationRef :: AmpParser TermPrim
+pRelationRef      = PNamedR <$> pNamedRel                                                
+                <|> pid   <$> currPos <* pKey "I" <*> pMaybe (pBrackets pConceptOneRef)
+                <|> pfull <$> currPos <* pKey "V" <*> pMaybe pSign
+                <|> Patm  <$> currPos <*> pSingleton <*> pMaybe (pBrackets pConceptOneRef)
+                    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
+
+pSingleton :: AmpParser PSingleton
+pSingleton = value2PAtomValue <$> currPos <*> pAtomInExpression
+
+pAtomValue :: AmpParser PAtomValue
+pAtomValue = value2PAtomValue <$> currPos <*> pAtomValInPopulation
+
+value2PAtomValue :: Origin -> Value -> PAtomValue
+value2PAtomValue o v = case v of 
+         VSingleton s x -> PSingleton o s (fmap (value2PAtomValue o) x)
+         VRealString s  -> ScriptString o s
+         VInt i         -> ScriptInt o (toInteger i)
+         VFloat x       -> ScriptFloat o x
+         VBoolean b     -> ComnBool o b
+         VDateTime x    -> ScriptDateTime o x
+         VDate x        -> ScriptDate o x
+         
+--- Att ::= LabelProps? Term
+pAtt :: AmpParser P_ObjectDef
+-- There's an ambiguity in the grammar here: If we see an identifier, we don't know whether it's a label followed by ':' or a term name.
+pAtt = rebuild <$> currPos <*> try pLabelProps `opt` ("",[]) <*> try pTerm
+  where rebuild pos (nm, strs) ctx = P_Obj nm pos ctx mView msub strs
+        mView = Nothing
+        msub = Nothing
+
+--- NamedRelList ::= NamedRel (',' NamedRel)*
+--- NamedRel ::= Varid Signature?
+pNamedRel :: AmpParser P_NamedRel
+pNamedRel = PNamedRel  <$> currPos <*> pVarid <*> pMaybe pSign
+
+--- Signature ::= '[' ConceptOneRef ('*' ConceptOneRef)? ']'
+pSign :: AmpParser P_Sign
+pSign = pBrackets sign
+   where sign = mkSign <$> pConceptOneRef <*> pMaybe (pOperator "*" *> pConceptOneRef)
+         mkSign src mTgt = P_Sign src (fromMaybe src mTgt)
+
+--- ConceptName ::= Conid | String
+--- ConceptNameList ::= ConceptName (',' ConceptName)
+pConceptName ::   AmpParser String
+pConceptName = pConid <|> pString
+
+--- ConceptRef ::= ConceptName
+pConceptRef ::    AmpParser P_Concept
+pConceptRef = PCpt <$> pConceptName
+
+--- ConceptOneRef ::= 'ONE' | ConceptRef
+pConceptOneRef :: AmpParser P_Concept
+pConceptOneRef = (P_Singleton <$ pKey "ONE") <|> pConceptRef
+
+--  (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).
+--- LabelProps ::= ADLid ('{' ADLidListList '}')? ':'
+pLabelProps :: AmpParser (String, [[String]])
+pLabelProps = (,) <$> pADLid
+                  <*> optList pArgs
+                  <*  posOf pColon
+              where pArgs = pBraces $ many1 pADLid `sepBy1` pComma
+
+--- Label ::= ADLid ':'
+pLabel :: AmpParser String
+pLabel = pADLid <* pColon
+
+--- Content ::= '[' RecordList? ']'
+pContent :: AmpParser [PAtomPair]
+pContent = pBrackets (pRecord `sepBy` (pComma <|> pSemi))
+          --- RecordList ::= Record ((','|';') Record)*
+          --- Record ::= String ',' String
+    where pRecord :: AmpParser PAtomPair
+          pRecord = 
+             pParens (PPair <$> currPos
+                            <*> pAtomValue
+                            <*  pComma
+                            <*> pAtomValue
+                     )
+                     
+--- ADLid ::= Varid | Conid | String
+--- ADLidList ::= ADLid (',' ADLid)*
+--- ADLidListList ::= ADLid+ (',' ADLid+)*
+pADLid :: AmpParser String
+pADLid = pVarid <|> pConid <|> pString
+
+
+ src/Database/Design/Ampersand/Input/ADL1/ParsingLib.hs view
@@ -0,0 +1,253 @@+{-# LANGUAGE FlexibleContexts, MultiParamTypeClasses, MagicHash, FlexibleInstances #-}
+module Database.Design.Ampersand.Input.ADL1.ParsingLib(
+    AmpParser, pIsThere, optList,
+    -- Operators
+    --TODO: Maybe we shouldn't export these here, but import in the parser directly
+    (DF.<$>), (P.<|>), (P.<?>), (<$), (CA.<*>), (CA.<*), (CA.*>), (<??>),
+    -- Combinators
+    sepBy, sepBy1, many, many1, opt, try, choice, pMaybe,
+    -- Positions
+    currPos, posOf, valPosOf,
+    -- Basic parsers
+    pConid, pString, pExpl, pVarid,
+    -- special parsers
+    pAtomInExpression, pAtomValInPopulation, Value(..),
+    -- Special symbols
+    pComma, pParens, pBraces, pBrackets, pChevrons,
+    -- Keywords
+    pKey,
+    -- Operators
+    pOperator, pDash, pSemi, pColon,
+    -- Integers
+    pZero, pOne
+) where
+
+import Control.Monad.Identity (Identity)
+import Database.Design.Ampersand.Input.ADL1.FilePos (Origin(..))
+import Database.Design.Ampersand.Input.ADL1.LexerToken
+import Database.Design.Ampersand.Input.ADL1.Lexer (lexer)
+import qualified Control.Applicative as CA
+import qualified Data.Functor as DF
+import qualified Text.Parsec.Prim as P
+import Text.Parsec as P hiding(satisfy)
+import Text.Parsec.Pos (newPos)
+import Data.Time.Calendar
+import Data.Time.Clock
+import Database.Design.Ampersand.Basics (fatalMsg)
+import Data.Maybe
+
+fatal :: Int -> String -> a
+fatal = fatalMsg "ParsingLib"
+
+-- | The Ampersand parser type
+type AmpParser a = P.ParsecT [Token] FilePos Identity a -- ^ The Parsec parser for a list of tokens with a file position.
+
+-----------------------------------------------------------
+-- Useful functions
+-----------------------------------------------------------
+
+infixl 4 <$
+
+-- | Applies the given parser and returns the given constructor
+(<$) :: a           -- ^ The value to return
+     -> AmpParser b -- ^ The parser to apply
+     -> AmpParser a -- ^ The result
+a <$ p = do { _ <- p; return a }
+
+(<??>) :: AmpParser a -> AmpParser (a -> a) -> AmpParser a
+p <??> q = (\x f -> f x) CA.<$> p CA.<*> (q `opt` id)
+
+-- | Tries to apply the given parser and returns a parser with a boolean indicating whether it succeeded
+pIsThere :: AmpParser a     -- ^ The parser to run
+         -> AmpParser Bool  -- ^ The parser with the result
+pIsThere p = (True <$ p) `opt` False
+
+-- | Optionally applies a list parser, returning an empty list if it doesn't succeed
+optList :: AmpParser [a]
+        -> AmpParser [a]
+optList p = p `opt` []
+
+-- | Tries to apply the given parser and encapsulates the result in Maybe
+pMaybe :: AmpParser a           -- ^ The parser to apply
+       -> AmpParser (Maybe a)   -- ^ The result
+pMaybe p = Just CA.<$> p <|> P.parserReturn Nothing
+
+-- | Tries to apply the given parser and returns the second argument if it doesn't succeed
+opt ::  AmpParser a  -- ^ The parser to try
+    -> a             -- ^ The item to return if the parser doesn't succeed
+    -> AmpParser a   -- ^ The resulting parser
+a `opt` b = P.option b a
+
+-----------------------------------------------------------
+-- Keywords & operators
+-----------------------------------------------------------
+pKey :: String -> AmpParser String
+pKey key = match (LexKeyword key)
+
+pOperator :: String -> AmpParser String
+pOperator op = match (LexOperator op)
+
+pDash :: AmpParser String
+pDash = pOperator "-"
+
+pSemi :: AmpParser String
+pSemi = pOperator ";"
+
+pColon :: AmpParser String
+pColon = pOperator ":"
+
+-----------------------------------------------------------
+-- Token parsers
+-----------------------------------------------------------
+
+check :: (Lexeme -> Maybe a) -> AmpParser a
+check predicate = tokenPrim showTok nextPos matchTok
+  where  -- Token pretty-printing function
+         showTok :: Token -> String
+         showTok (Tok lx _)   = show lx
+         -- Next position calculating function
+         nextPos :: SourcePos -> Token -> [Token] -> SourcePos
+         nextPos pos _ [] = pos
+         nextPos _ _ (Tok _ (FilePos file line col):_) = newPos file line col
+         -- ^ Matching function for the token to parse.
+         matchTok (Tok l _) = predicate l
+
+match :: Lexeme -> AmpParser String
+match lx = check (\lx' -> if lx == lx' then Just (lexemeText lx) else Nothing) <?> show lx
+
+--- Conid ::= UpperChar (Char | '_')*
+pConid :: AmpParser String
+pConid = check (\lx -> case lx of { LexConId s -> Just s; _ -> Nothing }) <?> "upper case identifier"
+
+--- String ::= '"' Any* '"'
+--- StringListSemi ::= String (';' String)*
+pString :: AmpParser String
+pString = check (\lx -> case lx of { LexString s -> Just s; _ -> Nothing }) <?> "string"
+
+--- Expl ::= '{+' Any* '-}'
+pExpl :: AmpParser String
+pExpl = check (\lx -> case lx of { LexExpl s -> Just s; _ -> Nothing }) <?> "explanation"
+
+--- Varid ::= (LowerChar | '_') (Char | '_')*
+pVarid :: AmpParser String
+pVarid = check (\lx -> case lx of { LexVarId s -> Just s; _ -> Nothing }) <?> "lower case identifier"
+
+--- Atom ::= "'" Any* "'"
+pAtomInExpression :: AmpParser Value
+pAtomInExpression = check (\lx -> case lx of 
+                                   LexSingleton s -> Just (VSingleton s (mval s))
+                                   _              -> Nothing 
+                          ) <?> "Singleton value"
+   where 
+    mval s = 
+      case lexer [] (fatal 141 $ "Reparse without fileName of `"++s ++"`") s of
+        Left _  -> Nothing
+        Right (toks,_) 
+           -> case runParser pAtomValInPopulation 
+                               (FilePos ("Reparse `"++s++"` ") 0 0) -- Todo: Fix buggy position
+                                "" toks of
+                Left _ -> Nothing
+                Right a -> Just a
+
+data Value = VRealString String
+           | VSingleton String (Maybe Value)
+           | VInt Int
+           | VFloat Double
+           | VBoolean Bool
+           | VDateTime UTCTime
+           | VDate Day
+pAtomValInPopulation :: AmpParser Value
+pAtomValInPopulation = 
+              VBoolean True  <$ pKey "TRUE"
+          <|> VBoolean False <$ pKey "FALSE"
+          <|> VRealString DF.<$> pString 
+          <|> VDateTime DF.<$> pUTCTime
+          <|> VDate DF.<$> pDay
+          <|> fromNumeric DF.<$> pNumeric
+   where fromNumeric :: Either Int Double -> Value
+         fromNumeric num = case num of
+             Left i -> VInt i
+             Right d -> VFloat d
+-----------------------------------------------------------
+-- Date / DateTime (ISO 8601 format)
+-----------------------------------------------------------
+
+pDay :: AmpParser Day
+pDay = check (\lx -> case lx of { LexDate s -> Just s; _ -> Nothing }) <?> "iso 8601 Date"
+
+pUTCTime :: AmpParser UTCTime
+pUTCTime  = check (\lx -> case lx of { LexDateTime s -> Just s; _ -> Nothing }) <?> "iso 8601 DateTime"
+    
+-----------------------------------------------------------
+-- Integers /float(Double)
+-----------------------------------------------------------
+
+pNumber :: Int -> AmpParser String
+pNumber nr = match (LexDecimal nr) <|> match (LexHex nr) <|> match (LexOctal nr)
+
+pNumeric :: AmpParser (Either Int Double)
+pNumeric = (f DF.<$> pIsNeg CA.<*> pUnsignedNumeric) <?> "numerical value"  
+  where
+     f :: Bool -> Either Int Double -> Either Int Double
+     f isNeg b = 
+        case b of
+          Left i  -> Left . (if isNeg then (0-) else id) $ i 
+          Right d -> Right. (if isNeg then (0-) else id) $ d
+
+pIsNeg :: AmpParser Bool
+pIsNeg = fromMaybe False
+            DF.<$> pMaybe ( True  <$ pOperator "-" <|>
+                            False <$ pOperator "+"
+                          )
+pUnsignedNumeric :: AmpParser (Either Int Double)
+pUnsignedNumeric = check isNr
+    where isNr (LexDecimal i) = Just (Left i)
+          isNr (LexHex i)     = Just (Left i)
+          isNr (LexOctal i)   = Just (Left i)
+          isNr (LexFloat d)   = Just (Right d)
+          isNr _              = Nothing
+
+pZero :: AmpParser String
+pZero = pNumber 0
+
+pOne :: AmpParser String
+pOne = pNumber 1
+
+-----------------------------------------------------------
+-- Special characters
+-----------------------------------------------------------
+
+-- matches special characters
+pSpec :: Char -> AmpParser String
+pSpec sym = match (LexSymbol sym)
+
+pComma :: AmpParser String
+pComma  = pSpec ','
+
+pParens :: AmpParser a -> AmpParser a
+pParens parser = pSpec '(' CA.*> parser CA.<* pSpec ')'
+
+pBraces :: AmpParser a -> AmpParser a
+pBraces parser = pSpec '{' CA.*> parser CA.<* pSpec '}'
+
+pBrackets :: AmpParser a -> AmpParser a
+pBrackets parser = pSpec '[' CA.*> parser CA.<* pSpec ']'
+
+pChevrons :: AmpParser a -> AmpParser a
+pChevrons parser = pSpec '<' CA.*> parser CA.<* pSpec '>'
+
+-----------------------------------------------------------
+-- Token positioning
+-----------------------------------------------------------
+
+posOrigin :: Show a => a -> SourcePos -> Origin
+posOrigin sym p = FileLoc (FilePos (sourceName p) (sourceLine p) (sourceColumn p)) (show sym)
+
+currPos :: AmpParser Origin
+currPos = posOf $ return ()
+
+posOf :: Show a => AmpParser a -> AmpParser Origin
+posOf parser = do { pos <- getPosition; a <- parser; return (posOrigin a pos) }
+
+valPosOf :: Show a => AmpParser a -> AmpParser (a, Origin)
+valPosOf parser = do { pos <- getPosition; a <- parser; return (a, posOrigin a pos) }
− src/Database/Design/Ampersand/Input/ADL1/UU_BinaryTrees.hs 
@@ -1,67 +0,0 @@-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 
@@ -1,336 +0,0 @@-{-# 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
@@ -1,106 +1,164 @@-{-# OPTIONS_GHC  -XScopedTypeVariables #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 -- 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
+module Database.Design.Ampersand.Input.Parsing (
+    parseADL, parseADL1pExpr, parseRule, parseCtx, runParser
+) where
 
+import Control.Applicative
+import Data.List
+import Data.Char(toLower)
+import Data.Traversable (sequenceA)
 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 Database.Design.Ampersand.Input.ADL1.Lexer
+import Database.Design.Ampersand.Input.ADL1.Parser
+import Database.Design.Ampersand.Core.ParseTree (mkContextOfPopsOnly)
+import Database.Design.Ampersand.Misc
+import Prelude hiding (putStrLn, writeFile) -- make sure everything is UTF8
 import System.Directory
 import System.FilePath
-import Data.Traversable (sequenceA)
+import Text.Parsec.Error (Message(..), showErrorMessages, errorMessages, ParseError, errorPos)
+import Text.Parsec.Prim (runP)
+import Database.Design.Ampersand.Input.Xslx.XLSX
+import Control.Exception
+import Database.Design.Ampersand.Prototype.StaticFiles_Generated(getStaticFileContent,FileKind(FormalAmpersand))
 
 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 ->
+-- | Parse an Ampersand file and all transitive includes
+parseADL ::  Options                -- ^ The options given through the command line
+         -> Either FilePath MetaType   -- ^ The path of the file to be parsed OR the MetaType. In the latter case, the files will be taken from `allStaticFiles`
+         -> IO (Guarded P_Context)  -- ^ The resulting context
+parseADL opts thingToParse =
+  whenCheckedIO (parseSingleADL opts useAllStaticFiles filePath) $ \(ctxt, filePaths) ->
+    whenCheckedIO (parseADLs opts useAllStaticFiles [filePath] filePaths) $ \ctxts ->
       return $ Checked $ foldl mergeContexts ctxt ctxts
-
-parseADLs :: Options -> [FilePath] -> [FilePath] -> IO (Guarded [P_Context])
-parseADLs _    _               []        = return $ Checked []
-parseADLs opts parsedFilePaths filePaths =
+ where (filePath, useAllStaticFiles) = case thingToParse of
+                                         Left fp        -> (fp               ,False)
+                                         Right Generics -> ("Generics.adl",True )
+                                         Right AST      -> ("AST.adl"     ,True )
+-- | Parses several ADL files
+parseADLs :: Options                    -- ^ The options given through the command line
+          -> Bool                       -- ^ True iff the file is from FormalAmpersand files in `allStaticFiles` 
+          -> [FilePath]                 -- ^ The list of files that have already been parsed
+          -> [FilePath]                 -- ^ The list of files to parse
+          -> IO (Guarded [P_Context])   -- ^ The resulting contexts
+parseADLs _    _                 _               []        = return $ Checked []
+parseADLs opts useAllStaticFiles 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' ->
+    ; whenCheckedIO (sequenceA <$> mapM (parseSingleADL opts useAllStaticFiles) filePathsToParse) $ \ctxtNewFilePathss ->
+       do { let (ctxts, newFilesToParse) = unzip ctxtNewFilePathss
+          ; whenCheckedIO (parseADLs opts useAllStaticFiles (parsedFilePaths ++ filePaths) $ concat newFilesToParse) $ \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
-
+-- | Parse an Ampersand file, but not its includes (which are simply returned as a list)
+parseSingleADL :: 
+    Options 
+ -> Bool   -- True iff the file is from FormalAmpersand files in `allStaticFiles` 
+ -> FilePath -> IO (Guarded (P_Context, [FilePath]))
+parseSingleADL opts useAllStaticFiles filePath
+ = do verboseLn opts $ "Reading file " ++ filePath ++ if useAllStaticFiles then " (from within ampersand.exe)" else ""
+      exists <- doesFileExist filePath
+      if useAllStaticFiles || exists 
+      then parseSingleADL'
+      else return . makeError $ "Could not find `"++filePath++"`."
+    where
+     parseSingleADL' :: IO(Guarded (P_Context, [FilePath]))
+     parseSingleADL'
+         | extension == ".xlsx" = 
+             do { popFromExcel <- catchInvalidXlsx $ parseXlsxFile opts useAllStaticFiles filePath
+                ; return ((\pops -> (mkContextOfPopsOnly pops,[])) <$> popFromExcel)  -- Excel file cannot contain include files
+                }
+         | otherwise =   
+             do { mFileContents 
+                    <- if useAllStaticFiles
+                       then case getStaticFileContent FormalAmpersand filePath of
+                             Just cont -> do return (Right $ stripBom cont)
+                             Nothing -> fatalMsg ("Statically included "++ show FormalAmpersand++ " files. ") 0 $
+                                         "Cannot find `"++filePath++"`."
+                       else readUTF8File filePath
+                ; case mFileContents of
+                    Left err -> return $ makeError ("ERROR reading file " ++ filePath ++ ":\n" ++ err)
+                    Right fileContents ->
+                         whenCheckedIO (return $ parseCtx filePath fileContents) $ \(ctxts, relativePaths) -> 
+                               do return (Checked (ctxts, relativePaths))
+            }
+         where stripBom :: String -> String
+               stripBom ('\239':'\187':'\191': s) = s
+               stripBom s = s 
+               extension = map toLower $ takeExtension filePath
+               catchInvalidXlsx :: IO a -> IO a 
+               catchInvalidXlsx m = catch m f 
+                 where f :: SomeException -> IO a
+                       f exception = fatal 34 $ "The file does not seem to have a valid .xlsx structure:\n  "++show exception
+             
+parseErrors :: Lang -> ParseError -> [CtxError]
+parseErrors lang err = [PE (Message msg)]
+                where msg :: String
+                      msg = "In file " ++ show (errorPos err) ++ ":" ++ showLang lang (errorMessages err)
+                      showLang :: Lang -> [Message] -> String
+                      showLang English = showErrorMessages "or" "unknown parse error"   "at that point expecting" "Parsing stumbled upon" "end of input"
+                      showLang Dutch   = showErrorMessages "of" "onbekende parsingfout" "verwacht"  "onverwacht" "einde van de invoer"
 
+parse :: AmpParser a -> FilePath -> [Token] -> Guarded a
+parse p fn ts =
+      -- runP :: Parsec s u a -> u -> FilePath -> s -> Either ParseError a 
+    case runP p pos fn ts of
+        --TODO: Add language support to the parser errors
+        Left err -> Errors $ parseErrors English err
+        Right a -> Checked a
+    where pos | null ts   = initPos fn
+              | otherwise = tokPos (head ts)
 
+--TODO: Give the errors in a better way
+lexerError2CtxError :: LexerError -> CtxError
+lexerError2CtxError (LexerError pos err) = 
+   PE (Message ("Lexer error at "++show pos++"\n  "
+                ++ intercalate "\n    " (showLexerErrorInfo err)
+               )
+      )
 
-type ParseError = Message Token (Maybe Token)
+-- | Runs the given parser
+runParser :: AmpParser a -- ^ The parser to run
+          -> FilePath    -- ^ Name of the file (for error messages)
+          -> String      -- ^ String to parse
+          -> Guarded a   -- ^ The result
+runParser parser filename input =
+  -- lexer :: [Options] -> String -> [Char] -> Either LexerError ([Token], [LexerWarning])
+  --TODO: Give options to the lexer
+  let lexed = lexer [] filename input
+  in case lexed of
+    Left err -> Errors [lexerError2CtxError err]
+    --TODO: Do something with the warnings. The warnings cannot be shown with the current Guarded data type
+    Right (tokens, _)  -> whenChecked (parse parser filename tokens) Checked
 
+-- | Parses an isolated rule
 -- 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 :: String         -- ^ The string to be parsed
+          -> Term TermPrim  -- ^ The resulting rule
 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
+   = case  runParser pRule "inside Haskell code" str of
+       Checked result -> result
+       Errors  msg    -> fatal 274 ("Parse errors in "++str++":\n   "++show msg)
 
--- | 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+-- | Parses an isolated ADL1 expression string
+parseADL1pExpr :: String            -- ^ The string to be parsed
+               -> FilePath          -- ^ The name of the file (used for error messages)
+               -> Either String (Term TermPrim)  -- ^ The result: Either an error message, or a good result
+parseADL1pExpr str fn =
+  case runParser pTerm fn str of
+      Checked result -> Right result
+      Errors  msg    -> Left $ "Parse errors:\n"++show msg
+
+-- | Parses an Ampersand context
+parseCtx :: FilePath -- ^ The file name (used for error messages)
+         -> String   -- ^ The string to be parsed
+         -> Guarded (P_Context, [String]) -- ^ The context and a list of included files
+parseCtx = runParser pContext
+ src/Database/Design/Ampersand/Input/Xslx/XLSX.hs view
@@ -0,0 +1,258 @@+{-# LANGUAGE OverloadedStrings #-}
+module Database.Design.Ampersand.Input.Xslx.XLSX 
+  (parseXlsxFile)
+where
+import Database.Design.Ampersand.Basics
+import Database.Design.Ampersand.Misc
+import Prelude hiding (putStrLn, writeFile) -- make sure everything is UTF8
+import Database.Design.Ampersand.Input.ADL1.CtxError
+import Database.Design.Ampersand.ADL1
+import Database.Design.Ampersand.Core.ParseTree
+import Codec.Xlsx
+import qualified Data.ByteString.Lazy as L
+import Control.Lens
+import qualified Data.Text as T
+import qualified Data.Map as M 
+import Data.Maybe
+import Data.Char
+import Data.String
+import Database.Design.Ampersand.Prototype.StaticFiles_Generated
+
+fatal :: Int -> String -> a
+fatal = fatalMsg "XLSX"
+
+parseXlsxFile :: Options 
+              -> Bool   -- True iff the file is from FormalAmpersand files in `allStaticFiles` 
+              -> FilePath -> IO (Guarded [P_Population])
+parseXlsxFile _ useAllStaticFiles file =
+  do bytestr <- if useAllStaticFiles
+                then case getStaticFileContent FormalAmpersand file of
+                      Just cont -> do return $ fromString cont
+                      Nothing -> fatalMsg ("Statically included "++ show FormalAmpersand++ " files. ") 0 $
+                                  "Cannot find `"++file++"`."
+                else L.readFile file
+     return . xlsx2pContext . toXlsx $ bytestr
+ where
+  xlsx2pContext :: Xlsx -> Guarded [P_Population]
+  xlsx2pContext xlsx 
+    = Checked $ concatMap (toPops file) $
+         Prelude.concatMap theSheetCellsForTable (xlsx ^. xlSheets . to M.toList)
+      
+data SheetCellsForTable 
+       = Mapping{ theSheetName :: String
+                , theCellMap   :: CellMap
+                , headerRowNrs :: [Int]
+                , popRowNrs    :: [Int]
+                , colNrs       :: [Int]
+                , debugInfo :: [String]
+                }
+instance Show SheetCellsForTable where  --for debugging only
+  show x 
+   = unlines $
+      [ "Sheet       : "++theSheetName x
+      , "headerRowNrs: "++show (headerRowNrs x)
+      , "popRowNrs   : "++show (popRowNrs x)
+      , "colNrs      : "++show (colNrs x)
+      ] ++ debugInfo x 
+toPops :: FilePath -> SheetCellsForTable -> [P_Population]
+toPops file x = map popForColumn' (colNrs x)
+  where
+    popForColumn' i = -- trace (show x ++"(Now column: "++show i++")") $
+                    popForColumn i
+    popForColumn :: Int -> P_Population
+    popForColumn i =
+      if i  == sourceCol  
+      then  P_CptPopu { p_orig = popOrigin
+                      , p_cnme = sourceConceptName 
+                      , p_popas = concat [ case value(row,i) of
+                                             Nothing -> []
+                                             Just cv -> cellToAtomValue mSourceConceptDelimiter cv popOrigin
+                                         | row <- popRowNrs x
+                                         ] 
+                      }
+      else  P_RelPopu { p_orig = popOrigin
+                      , p_src = src
+                      , p_tgt = trg
+                      , p_nmdr 
+                         = PNamedRel popOrigin relName Nothing
+                      , p_popps = thePairs
+                      }
+     where                             
+       src, trg :: Maybe String
+       (src,trg) = case mTargetConceptName of
+                  Just tCptName -> (if isFlipped then swap else id) (Just sourceConceptName, Just tCptName)
+                  Nothing -> (Nothing,Nothing)
+          where swap (a,b) = (b,a)
+       popOrigin :: Origin
+       popOrigin = originOfCell (relNamesRow, targetCol)
+       conceptNamesRow = headerRowNrs x !! 1
+       relNamesRow     = headerRowNrs x !! 0
+       sourceCol       = colNrs x !! 0
+       targetCol       = i 
+       sourceConceptName :: String
+       mSourceConceptDelimiter :: Maybe Char
+       (sourceConceptName, mSourceConceptDelimiter)
+          = case value (conceptNamesRow,sourceCol) of
+                Just (CellText t) -> case conceptNameWithOptionalDelimiter t of
+                                       Nothing -> fatal 94 "No valid source conceptname found. This should have been checked before"
+                                       Just res -> res
+                _ -> fatal 96 "No valid source conceptname found. This should have been checked before"
+       mTargetConceptName :: Maybe String
+       mTargetConceptDelimiter :: Maybe Char
+       (mTargetConceptName, mTargetConceptDelimiter)
+          = case value (conceptNamesRow,targetCol) of
+                Just (CellText t) -> let (nm,mDel) = case conceptNameWithOptionalDelimiter t of
+                                                      Nothing -> fatal 94 "No valid source conceptname found. This should have been checked before"
+                                                      Just res -> res
+                                     in (Just nm, mDel)
+                _ -> (Nothing, Nothing)
+       relName :: String
+       isFlipped :: Bool
+       (relName,isFlipped) 
+          = case value (relNamesRow,targetCol) of
+                Just (CellText t) -> 
+                    let str = T.unpack t
+                    in if last str == '~'
+                       then (init str, True )
+                       else (     str, False)
+                _ -> fatal 87 $ "No valid relation name found. This should have been checked before" ++show (relNamesRow,targetCol)
+       thePairs :: [PAtomPair]
+       thePairs =  concat . catMaybes . map pairsAtRow . popRowNrs $ x
+       pairsAtRow :: Int -> Maybe [PAtomPair]
+       pairsAtRow r = case (value (r,sourceCol)
+                          ,value (r,targetCol)
+                          ) of
+                       (Just s,Just t) -> Just $ 
+                                            (if isFlipped then map flp else id) $
+                                                [mkPair origTrg a b
+                                                | a <- cellToAtomValue mSourceConceptDelimiter s origSrc
+                                                , b <- cellToAtomValue mTargetConceptDelimiter t origTrg
+                                                ]
+                       _               -> Nothing
+            where origSrc = XLSXLoc file (theSheetName x) (r,sourceCol)
+                  origTrg = XLSXLoc file (theSheetName x) (r,targetCol)
+       cellToAtomValue :: Maybe Char -> CellValue -> Origin -> [PAtomValue]  -- The value in a cell can contain the delimeter of the row
+       cellToAtomValue mDelimiter cv orig
+         = case cv of
+             CellText t   -> map (XlsxString orig) (map T.unpack (unDelimit mDelimiter t))
+             CellDouble d -> [XlsxDouble orig d]
+             CellBool b -> [ComnBool orig b] 
+       unDelimit :: Maybe Char -> T.Text -> [T.Text]
+       unDelimit mDelimiter xs =
+         case mDelimiter of
+           Nothing -> [xs]
+           (Just delimiter) -> T.split (== delimiter) xs
+            
+    originOfCell :: (Int,Int) -- (row number,col number)
+                 -> Origin
+    originOfCell (r,c) 
+      = XLSXLoc file (theSheetName x) (r,c) 
+
+    value :: (Int,Int) -> Maybe CellValue
+    value k = (theCellMap x) ^? ix k . cellValue . _Just
+
+
+theSheetCellsForTable :: (T.Text,Worksheet) -> [SheetCellsForTable]
+theSheetCellsForTable (sheetName,ws) 
+  =  catMaybes [theMapping i | i <- [0..(Prelude.length tableStarters) - 1]]
+  where
+    tableStarters :: [(Int,Int)]
+    tableStarters = Prelude.filter isStartOfTable $ M.keys (ws  ^. wsCells)  
+      where isStartOfTable :: (Int,Int) -> Bool
+            isStartOfTable (rowNr,colNr)
+              | colNr /= 1 = False
+              | rowNr == 1 = isBracketed (rowNr,colNr) 
+              | otherwise  =           isBracketed (rowNr     ,colNr)  
+                             && (not $ isBracketed (rowNr - 1, colNr))             
+              
+    value :: (Int,Int) -> Maybe CellValue
+    value k = (ws  ^. wsCells) ^? ix k . cellValue . _Just
+    isBracketed :: (Int,Int) -> Bool
+    isBracketed k = 
+       case value k of
+         Just (CellText t) -> (not . T.null ) t && T.head t == '[' && T.last t == ']'
+         _                 -> False      
+    theMapping :: Int -> Maybe SheetCellsForTable
+    theMapping indexInTableStarters 
+     | length okHeaderRows /= nrOfHeaderRows = Nothing  -- Because there are not enough header rows
+     | otherwise
+     =  Just -- . (\x->trace (show x) x) $
+             Mapping { theSheetName = T.unpack sheetName
+                     , theCellMap   = ws  ^. wsCells
+                     , headerRowNrs = okHeaderRows
+                     , popRowNrs    = populationRows
+                     , colNrs       = theCols
+                     , debugInfo = [ "indexInTableStarters"++": "++show indexInTableStarters
+                                   , "maxRowOfWorksheet"++": "++show maxRowOfWorksheet
+                                   , "maxColOfWorksheet"++": "++show maxColOfWorksheet
+                                   , "startOfTable     "++": "++show startOfTable
+                                   , "firstPopRowNr    "++": "++show firstPopRowNr
+                                   , "lastPopRowNr     "++": "++show lastPopRowNr
+                                   , "[(row,isProperRow)] "++": "++concatMap show [(r,isProperRow r) | r<- [firstPopRowNr..lastPopRowNr]]
+                                   , "theCols          "++": "++show theCols
+                                   ] 
+                     }
+     where
+       startOfTable = tableStarters !! indexInTableStarters 
+       firstHeaderRowNr = fst startOfTable
+       firstColumNr = snd startOfTable
+       relationNameRowNr = firstHeaderRowNr
+       conceptNameRowNr  = firstHeaderRowNr+1
+       nrOfHeaderRows = 2
+       maxRowOfWorksheet = Prelude.maximum (Prelude.map fst (M.keys (ws  ^. wsCells)))
+       maxColOfWorksheet = Prelude.maximum (Prelude.map snd (M.keys (ws  ^. wsCells)))
+       firstPopRowNr = firstHeaderRowNr + nrOfHeaderRows
+       lastPopRowNr = ((map fst tableStarters++[maxRowOfWorksheet+1])!!(indexInTableStarters+1))-1
+       okHeaderRows = filter isProperRow [firstHeaderRowNr,firstHeaderRowNr+nrOfHeaderRows-1]
+       populationRows = filter isProperRow [firstPopRowNr..lastPopRowNr]
+       isProperRow :: Int -> Bool
+       isProperRow rowNr
+          | rowNr == relationNameRowNr = True -- The first row was recognized as tableStarter
+          | rowNr == conceptNameRowNr  = isProperConceptName(rowNr,firstColumNr)
+          | otherwise                  = notEmpty (rowNr,firstColumNr)
+       notEmpty k
+          = case value k of
+            Just (CellText t)   -> (not . T.null) t
+            Just (CellDouble _) -> True
+            Just (CellBool _)   -> True
+            Nothing -> False
+       theCols = filter isProperCol [1..maxColOfWorksheet]
+       isProperCol :: Int -> Bool
+       isProperCol colNr
+          | colNr == 1 = isProperConceptName (conceptNameRowNr,colNr)
+          | otherwise  = isProperConceptName (conceptNameRowNr,colNr) && isProperRelName(relationNameRowNr,colNr)
+       isProperConceptName k 
+         = case value k of
+            Just (CellText t) -> isJust (conceptNameWithOptionalDelimiter t)
+            _ -> False
+       isProperRelName k 
+         = case value k of
+            Just (CellText t) -> (not . T.null) t && isLower(T.head t)
+            _ -> False
+               
+conceptNameWithOptionalDelimiter :: T.Text -> Maybe ( String     {- Conceptname -} 
+                                                    , Maybe Char {- Delimiter   -}
+                                             )
+-- Cases:  1) "[" ++ Conceptname ++ delimiter ++ "]"
+--         2) Conceptname
+--         3) none of above
+--  Where Conceptname is any string starting with an uppercase character
+conceptNameWithOptionalDelimiter t
+  | T.null t = Nothing
+  | T.head t == '[' && T.last t == ']'
+             = let mid = (T.reverse . T.tail . T.reverse . T.tail) t
+                   (nm,d) = (T.init mid, T.last mid)
+               in if isDelimiter d && isConceptName nm
+                  then Just (T.unpack nm , Just d)
+                  else Nothing
+  | otherwise = if isConceptName t
+                then Just (T.unpack t, Nothing)
+                else Nothing
+           
+isDelimiter :: Char -> Bool
+isDelimiter = isPunctuation
+isConceptName :: T.Text -> Bool
+isConceptName t = case T.uncons t of
+                    Nothing  -> False
+                    (Just (h,_)) -> isUpper h
+
src/Database/Design/Ampersand/Misc.hs view
@@ -8,6 +8,6 @@ import Database.Design.Ampersand.Misc.Options
        (getOptions, Options(..),
         verboseLn, verbose, DocTheme(..), FSpecFormat(..),
-        FileFormat(..), helpNVersionTexts)
+        helpNVersionTexts,MetaType(..))
 import Database.Design.Ampersand.Misc.Explain
        (string2Blocks, blocks2String, PandocFormat(..))
src/Database/Design/Ampersand/Misc/Options.hs view
@@ -1,8 +1,10 @@ {-# LANGUAGE PatternGuards #-}
 module Database.Design.Ampersand.Misc.Options
         (Options(..),getOptions,usageInfo'
-        ,verboseLn,verbose,FSpecFormat(..),FileFormat(..)
-        ,DocTheme(..),helpNVersionTexts)
+        ,verboseLn,verbose,FSpecFormat(..)
+        ,DocTheme(..),helpNVersionTexts
+        ,MetaType(..)
+        )
 where
 import System.Environment    (getArgs, getProgName,getEnvironment,getExecutablePath )
 import Database.Design.Ampersand.Misc.Languages (Lang(..))
@@ -36,20 +38,15 @@                        , 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
@@ -65,6 +62,7 @@                        , 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
+                       , genPOPExcel :: Bool   -- Generate an .xmlx file containing the populations 
                        , 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.
@@ -73,7 +71,6 @@                        , 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
@@ -82,7 +79,6 @@                        , 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
@@ -127,7 +123,6 @@                       , 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)
@@ -141,24 +136,19 @@                       , validateEdit  = Nothing
                       , genPrototype  = False
                       , allInterfaces = False
-                      , genAtlas      = False
-                      , namespace     = []
+                      , 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
+                      , doubleEdges   = True
                       , showPredExpr  = False
                       , noDiagnosis   = False
                       , diagnosisOnly = False
@@ -167,6 +157,7 @@                       , genFPAChap    = False
                       , genFPAExcel   = False
                       , genStaticFiles= True
+                      , genPOPExcel   = False
                       , genBericht    = False
                       , language      = Nothing
                       , progrName     = progName
@@ -181,25 +172,24 @@                       , 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
+                      , newFrontend   = True
                       }
       -- 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 MetaType = Generics | AST deriving (Show)
 
 data FSpecFormat = FPandoc| Fasciidoc| Fcontext| Fdocbook| Fhtml| FLatex| Fman| Fmarkdown| Fmediawiki| Fopendocument| Forg| Fplain| Frst| Frtf| Ftexinfo| Ftextile deriving (Show, Eq)
 allFSpecFormats :: String
@@ -212,7 +202,6 @@                     _: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
@@ -237,7 +226,7 @@             , Public)
           , (Option []      ["dev"]
                (NoArg (\opts -> return opts{development = True}))
-               "Report and generate extra development information"
+               "Report and generate extra development information (for Martijn)"
             , Hidden)
           , (Option []      ["validate"]
                (NoArg (\opts -> return opts{validateSQL = True}))
@@ -252,14 +241,14 @@                (OptArg (\nm opts -> return opts {dirPrototype = fromMaybe (dirPrototype opts) nm
                                                   ,genPrototype = True}
                        ) "DIRECTORY")
-               ("generate a functional prototype (overwrites environment variable "++ envdirPrototype ++ ").")
+               ("generate a functional prototype (overrules 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)")
+               ("database name (overrules environment variable "++ envdbName ++ ", defaults to filename)")
             , Public)
           , (Option []      ["theme"]
                (ReqArg (\t opts -> return opts{theme = case map toUpper t of
@@ -283,34 +272,12 @@           , (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)).")
+               ("output directory (dir overrules environment variable "++ envdirOutput ++ ").")
             , Public)
           , (Option []      ["namespace"]
                (ReqArg (\nm opts -> return opts{namespace = nm}
                        ) "NAMESPACE")
-               "places the population in this namespace within the context."
+               "prefix database identifiers with this namespace, in order to isolate namspaces."
             , Public)
           , (Option ['f']   ["fspec"]
                (ReqArg (\w opts -> return opts
@@ -354,26 +321,18 @@                (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)
+            , Hidden)
           , (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)
+            , Hidden)
           , (Option []        ["haskell"]
                (NoArg (\opts -> return opts{haskell = True}))
                "generate internal data structure, written in Haskell (for debugging)."
-            , Public)
+            , Hidden)
           , (Option []        ["crowfoot"]
                (NoArg (\opts -> return opts{crowfoot = True}))
                "generate crowfoot notation in graphics."
@@ -382,14 +341,14 @@                (NoArg (\opts -> return opts{blackWhite = True}))
                "do not use colours in generated graphics"
             , Public)
-          , (Option []        ["doubleEdges"]
+          , (Option []        ["altGraphics"]
                (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)
+            , Hidden)
           , (Option []        ["noDiagnosis"]
                (NoArg (\opts -> return opts{noDiagnosis = True}))
                "omit the diagnosis chapter from the functional specification document."
@@ -398,9 +357,9 @@                (NoArg (\opts -> return opts{diagnosisOnly = True}))
                "diagnose your Ampersand script (generates a .pdf file)."
             , Public)
-          , (Option []        ["legalrefs"]
+          , (Option []        ["reference-table"]
                (NoArg (\opts -> return opts{genLegalRefs = True}))
-               "generate a table of legal references in Natural Language chapter."
+               "generate a table of references in the Natural Language chapter, for instance for legal traceability."
             , Public)
           , (Option []        ["uml"]
                (NoArg (\opts -> return opts{genUML = True}))
@@ -410,13 +369,17 @@                (NoArg (\opts -> return opts{genFPAChap = True}))
                "Generate Function Point Analysis chapter."
             , Hidden)
-          , (Option []        ["excel"]
+          , (Option []        ["fpa-excel"]
                (NoArg (\opts -> return opts{genFPAExcel = True}))
                "Generate an Excel workbook (FPA_<filename>.xml)."
             , Hidden)
-          , (Option []        ["bericht"]
+          , (Option []        ["pop-xlsx"]
+               (NoArg (\opts -> return opts{genPOPExcel = True}))
+               "Generate an .xmlx file containing the populations of your script."
+            , Public) 
+          , (Option []        ["ebc"]
                (NoArg (\opts -> return opts{genBericht = True}))
-               "Generate definitions for 'berichten' (specific to INDOORS project)."
+               "Generate specifications of interfaces in EBV-format (http://www.justid.nl/ebv/)."
             , Hidden)
           , (Option []        ["language"]
                (ReqArg (\l opts-> return opts{language = case map toUpper l of
@@ -452,11 +415,6 @@                (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"
@@ -485,7 +443,8 @@                "use the new normalizer at your own risk." -- :-)
             , Hidden)
           , (Option []        ["newFrontend"]
-               (NoArg (\opts -> return opts{newFrontend = True}))
+               (NoArg (\opts -> do putStrLn "WARNING: Option '--newFrontend' is obsolete, and will soon be removed. The only supported interface currently is the Zwolle interface."
+                                   return opts{newFrontend = True}))
                "Use the new frontend."
             , Hidden)
           ]
@@ -535,8 +494,6 @@ envdirOutput="CCdirOutput"
 envdbName :: String
 envdbName="CCdbName"
-envlogName :: String
-envlogName="CClogName"
 
 verbose :: Options -> String -> IO ()
 verbose opts x
− src/Database/Design/Ampersand/Misc/TinyXML.hs 
@@ -1,45 +0,0 @@-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
@@ -2,8 +2,10 @@     ( module Database.Design.Ampersand.Output.FSpec2Pandoc
     , module Database.Design.Ampersand.Output.PandocAux
     , module Database.Design.Ampersand.Output.FSpec2Excel
+    , module Database.Design.Ampersand.Output.Population2Xlsx
     ) where
 import Database.Design.Ampersand.Output.FSpec2Pandoc
        (fSpec2Pandoc)
 import Database.Design.Ampersand.Output.PandocAux (writepandoc)
-import Database.Design.Ampersand.Output.FSpec2Excel+import Database.Design.Ampersand.Output.FSpec2Excel
+import Database.Design.Ampersand.Output.Population2Xlsx
src/Database/Design/Ampersand/Output/FSpec2Excel.hs view
@@ -1,4 +1,4 @@-module Database.Design.Ampersand.Output.FSpec2Excel (fspec2Workbook,showSpreadsheet)
+module Database.Design.Ampersand.Output.FSpec2Excel (fspec2FPA_Excel)
 where
 import Text.XML.SpreadsheetML.Builder
 import Text.XML.SpreadsheetML.Types
@@ -10,7 +10,12 @@ import Database.Design.Ampersand.Basics
 import Data.Maybe
 
+-- TODO: Get rid of package SpreadsheetML. Use http://hackage.haskell.org/package/xlsx (Reason: SpreadsheetML doesn.t have a writer. xlsx package does.
+
 -- NOTE: this code was refactored to support the new FPA module, but has not been tested yet.
+
+fspec2FPA_Excel :: FSpec -> String
+fspec2FPA_Excel = showSpreadsheet . fspec2Workbook
 
 fspec2Workbook :: FSpec -> Workbook
 fspec2Workbook fSpec =
src/Database/Design/Ampersand/Output/FSpec2Pandoc.hs view
@@ -2,7 +2,7 @@ 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.ChapterInterfaces            (chpInterfacesBlocks)
 import Database.Design.Ampersand.Output.ToPandoc.ChapterIntroduction          (chpIntroduction)
 import Database.Design.Ampersand.Output.ToPandoc.ChapterNatLangReqs           (chpNatLangReqs)
 import Database.Design.Ampersand.Output.ToPandoc.ChapterDiagnosis             (chpDiagnosis)
@@ -96,11 +96,11 @@     fspec2Blocks SharedLang            = (chpNatLangReqs          0 fSpec, [])
     fspec2Blocks Diagnosis             = chpDiagnosis               fSpec
     fspec2Blocks ConceptualAnalysis    = chpConceptualAnalysis    0 fSpec
-    fspec2Blocks ProcessAnalysis       = chpProcessAnalysis       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 Interfaces            = (chpInterfacesBlocks     0 fSpec, [])
+    fspec2Blocks FunctionPointAnalysis = (chpFunctionPointAnalysis  fSpec, [])
     fspec2Blocks Glossary              = (chpGlossary             0 fSpec, [])
src/Database/Design/Ampersand/Output/PandocAux.hs view
@@ -9,7 +9,6 @@       , pandocEqnArrayWithLabel
       , pandocEquation
       , pandocEquationWithLabel
-      , uniquecds
       , count
       , ShowMath(..)
       , latexEscShw, escapeNonAlphaNum
@@ -17,8 +16,10 @@       , texOnly_Id
       , texOnly_fun
       , texOnly_rel
+      , newGlossaryEntry
       )
 where
+import Database.Design.Ampersand.Prototype.StaticFiles_Generated
 import Database.Design.Ampersand.ADL1
 import Database.Design.Ampersand.FSpec
 import Data.Char hiding    (Space)
@@ -45,7 +46,9 @@ defaultWriterVariables :: FSpec -> [(String , String)]
 defaultWriterVariables fSpec
   = [ ("title", (case (fsLang fSpec, diagnosisOnly (getOpts fSpec)) of
-                        (Dutch  , False) -> "Functionele Specificatie van "
+                        (Dutch  , False) -> if test (getOpts fSpec)
+                                            then "Taalmodel van "
+                                            else "Functionele Specificatie van "
                         (English, False) -> "Functional Specification of "
                         (Dutch  ,  True) -> "Diagnose van "
                         (English,  True) -> "Diagnosis of "
@@ -106,7 +109,7 @@          , "% End-hack1"
          , ""
 
-         , "% hack2) The LaTeX commands \\[ and \\], are redefined in the amsmath package, making sure that ecuations are"
+         , "% hack2) The LaTeX commands \\[ and \\], are redefined in the amsmath package, making sure that equations 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}}"
@@ -169,11 +172,8 @@                                                  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)
+            =  do verboseLn (getOpts fSpec) ("Generating "++fSpecFormatString++" to : "++outputFile)
+                  writeFile outputFile (pandocWriter (writerOptions (readDefaultTemplate fSpecFormatString)) $ thePandoc)
                   verboseLn (getOpts fSpec) "... done."
            where
               pandocWriter :: WriterOptions -> Pandoc -> String
@@ -214,24 +214,8 @@                   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
-                     )
-                   }
+              readDefaultTemplate :: String -> Maybe String
+              readDefaultTemplate s = getStaticFileContent PandocTemplates ("default."++s)
               writerOptions :: Maybe String -> WriterOptions
               writerOptions template = case theme (getOpts fSpec) of
                           ProofTheme -> ampersandDefaultWriterOptions
@@ -350,7 +334,6 @@ ------ Symbolic referencing ---------------------------------
 data XRefObj = XRefNaturalLanguageDeclaration Declaration
              | XRefPredicateXpression Rule
-             | XRefNaturalLanguageConcept A_Concept
              | XRefDataAnalRule Rule
              | XRefNaturalLanguageRule Rule
              | XRefProcessAnalysis Pattern
@@ -369,7 +352,6 @@  = 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
@@ -456,13 +438,13 @@ instance ShowMath Rule where
  showMath r = showMath (rrexp r)
 
-instance ShowMath Sign where
+instance ShowMath Signature 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 (EInc (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
@@ -481,11 +463,12 @@           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 (EDcD d)     = "\\text{"++latexEscShw (name d)++"}"
+          showExpr (EDcI c)     = "I_{[\\text{"++latexEscShw (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++"}'"
+          showExpr (EDcV sgn)   = "V_{[\\text{"++latexEscShw (name (source sgn))++"}"++"*"
+                                   ++"\\text{"++latexEscShw (name (target sgn))++"}]}"
+          showExpr (EMp1 val _) = "`\\text{"++(latexEscShw . showADL $ val)++"}`"
 
 -- add extra parentheses to consecutive superscripts, since latex cannot handle these
 -- (this is not implemented in insParentheses because it is a latex-specific issue)
@@ -646,33 +629,13 @@ -- 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 ---
 ---------------------------
+-- safe function to have plain text in a piece of Math  
+mathText :: String -> String
+mathText s = "\\text{"++latexEscShw s++"} "
 
 texOnly_Id :: String -> String
 texOnly_Id s = "\\id{"++latexEscShw s++"} "
@@ -724,3 +687,10 @@ 
 texOnly_flip :: String
 texOnly_flip = "\\smallsmile "
+
+newGlossaryEntry :: String -> String -> Inlines
+newGlossaryEntry nm cnt = 
+  rawInline "latex"
+    ("\\newglossaryentry{"++escapeNonAlphaNum nm ++"}\n"++
+     "     { name={"++latexEscShw nm ++"}\n"++
+     "     , description={"++latexEscShw (cnt)++"}}\n")
+ src/Database/Design/Ampersand/Output/Population2Xlsx.hs view
@@ -0,0 +1,94 @@+{-# LANGUAGE OverloadedStrings #-}
+module Database.Design.Ampersand.Output.Population2Xlsx
+  (fSpec2PopulationXlsx)
+where
+import Database.Design.Ampersand.FSpec
+import Database.Design.Ampersand.Basics
+import Database.Design.Ampersand.Core.AbstractSyntaxTree
+import System.Time
+import qualified Data.Map as M
+import Codec.Xlsx
+import qualified Data.ByteString.Lazy as L
+import qualified Data.Text as T
+import Data.Maybe
+import Data.List
+import Data.Time.Calendar
+
+fatal :: Int -> String -> a
+fatal = fatalMsg "Population2Xlsx"
+
+fSpec2PopulationXlsx :: ClockTime -> FSpec -> L.ByteString 
+fSpec2PopulationXlsx ct fSpec = 
+  fromXlsx ct xlsx
+    where
+      xlsx =def { _xlSheets = plugs2Sheets fSpec}
+               
+     
+
+plugs2Sheets :: FSpec -> M.Map T.Text Worksheet
+plugs2Sheets fSpec = M.fromList . catMaybes . Prelude.map plug2sheet $ plugInfos fSpec
+  where
+    plug2sheet :: PlugInfo -> Maybe (T.Text, Worksheet)
+    plug2sheet ExternalPlug{} = Nothing  -- Not supported at present
+    plug2sheet (InternalPlug plug) = fmap (\x -> (T.pack (name plug),x)) sheet
+      where 
+       sheet :: Maybe Worksheet
+       sheet = case matrix of
+                 Nothing -> Nothing
+                 Just m -> Just def{_wsCells = fromRows . numberList . Prelude.map numberList $ m }
+            where 
+              numberList :: [c] -> [(Int, c)]
+              numberList = zip [1..] 
+       matrix :: Maybe  [[Cell]]
+       matrix = 
+         case plug of
+           TblSQL{} -> if length (fields plug) > 1
+                       then Just $ headers ++ content
+                       else Nothing
+           BinSQL{} -> -- trace ("## Warning: Handling of link-tables isn't correct yet. Therefor, sheet`"++name plug++"` doesn't contain proper info") $
+                       Just $ headers ++ content
+           ScalarSQL{} -> Nothing
+         where
+           headers :: [[Cell]]
+           headers = transpose (Prelude.map f (zip (True : repeat False) (plugFields plug))) 
+             where f :: (Bool,SqlField) -> [Cell]
+                   f (isFirstField,fld) = Prelude.map toCell 
+                         [ if isFirstField  -- In case of the first field of the table, we put the fieldname inbetween brackets,
+                                            -- to be able to find the population again by the reader of the .xlsx file
+                           then Just $ "["++name fld++"]" 
+                           else Just . cleanUpRelName $
+                                          case plug of
+                                            TblSQL{}    -> name fld
+                                            BinSQL{}    -> name plug
+                                            ScalarSQL{} -> fatal 57 "ScalarSQL not expected here"
+                         , Just $ name .target . fldexpr $ fld ]
+                   cleanUpRelName :: String -> String
+                   --TODO: This is a not-so-nice way to get the relationname from the fieldname.
+                   cleanUpRelName orig
+                     | isPrefixOf "tgt_" orig = drop 4 orig
+                     | isPrefixOf "src_" orig = drop 4 orig ++"~" --TODO: Make in less hacky! (See also the way the fieldname is constructed.
+                     | otherwise         = orig
+           content = fmap record2Cells (tableContents fSpec plug)
+           record2Cells :: [Maybe AAtomValue] -> [Cell]
+           record2Cells = map record2Cell
+           record2Cell :: Maybe AAtomValue -> Cell
+           record2Cell mVal = Cell Nothing (case mVal of
+                                             Nothing -> Nothing
+                                             Just aVal -> Just $
+                                                case aVal of
+                                                  AAVString _ str -> CellText $ T.pack str
+                                                  AAVInteger _ int -> CellDouble (fromInteger int)
+                                                  AAVFloat _ x -> CellDouble x
+                                                  AAVBoolean _ b -> CellBool b
+                                                  AAVDate _ day -> (CellDouble . fromInteger) (diffDays (fromGregorian 1900 1 1) day)
+                                                  _ -> fatal 87 $ "Content found that cannot be converted to Excel (jet)." 
+                                           )  
+       toCell :: Maybe String -> Cell
+       toCell mVal 
+        = Cell { _cellStyle = Nothing
+               , _cellValue = fmap (\x -> CellText . T.pack $ x) mVal
+               }
+       
+
+  
+
src/Database/Design/Ampersand/Output/PredLogic.hs view
@@ -269,7 +269,6 @@                    , 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"
@@ -297,7 +296,7 @@    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 (EInc (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))]
@@ -332,7 +331,7 @@             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 _ (EMp1 val _) _             = Atom . showADL $ val
    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++">)")
@@ -441,7 +440,7 @@      = 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
+         EMp1 val _      -> \_ _-> Atom . showADL $ val
          EFlp EMp1{}     -> relFun exclVars lhs e rhs
          _               -> \sv tv->f (exclVars++[sv,tv]) e (sv,tv)
src/Database/Design/Ampersand/Output/ToPandoc/ChapterConceptualAnalysis.hs view
@@ -5,7 +5,6 @@ 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
@@ -51,7 +50,7 @@   patPicts :: Pattern -> [Picture]
   patPicts pat = pictOfPat pat :
                 (map pictOfRule (invariants fSpec `isc` udefrules pat))
-  pictOfPat  :: Pattern ->  Picture
+  pictOfPat ::  Pattern ->  Picture
   pictOfPat  = makePicture fSpec . PTRelsUsedInPat
   pictOfRule :: Rule -> Picture
   pictOfRule = makePicture fSpec . PTSingleRule
@@ -62,14 +61,13 @@         -- 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
+     <> ( case (fsLang fSpec) of
+               (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)
+               (English) -> para ("Figure " <> xRefReference (getOpts fSpec) (pictOfPat pat) <> " shows a conceptual diagram of this pattern.")
+                          <>((plain . showImage (getOpts fSpec) . pictOfPat) pat)
         ) <>
     (
         -- now provide the text of this pattern.
@@ -133,7 +131,8 @@     ukadj Trn = "transitive"
     ukadj Rfx = "reflexive"
     ukadj Irf = "irreflexive"
-    ukadj Aut = "automatically computed"    
+    ukadj Aut = "automatically computed"
+    ukadj Prop = "symmetric and antisymmetric"
   nladjs d = case [Uni,Tot]>-multiplicities d of
                [] -> commaNL "en" (map nladj (multiplicities d>-[Uni,Tot]))++" functie"
                _  -> commaNL "en" (map nladj (multiplicities d))++" relatie"
@@ -147,7 +146,8 @@     nladj Trn = "transitieve"
     nladj Rfx = "reflexieve"
     nladj Irf = "irreflexieve"
-    nladj Aut = "automatisch berekende"  
+    nladj Aut = "automatisch berekende"
+    nladj Prop  = "symmetrische en antisymmetrische" 
   caRule :: Rule -> (Inlines, [Blocks])
   caRule r
         = let purp = (purposes2Blocks (getOpts fSpec) (purposesDefinedIn fSpec (fsLang fSpec) r))
@@ -169,9 +169,9 @@                    (  str (l (NL "Dit is - gebruikmakend van relaties "
                              ,EN "Using relations "  ))
                     <>(mconcat (intersperse  (str ", ") 
-                          [   xRefTo (XRefConceptualAnalysisDeclaration d) 
-                           <> text (" ("++name d++")")
-                          | d@Sgn{}<-relsMentionedIn r]))  
+                                [   xRefTo (XRefConceptualAnalysisDeclaration d) 
+                                 <> text (" ("++name d++")")
+                                | d@Sgn{}<-relsMentionedIn r])) 
                     <> str (l (NL " - geformaliseerd als "
                               ,EN ", this is formalized as "))    
                    )
@@ -180,14 +180,12 @@                    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
+               <> 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))
                ]
              )
src/Database/Design/Ampersand/Output/ToPandoc/ChapterDataAnalysis.hs view
@@ -3,9 +3,9 @@ 
 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.Graphic.ClassDiagram --(Class(..),CdAttribute(..))
+import Database.Design.Ampersand.Graphic.Fspec2ClassDiagrams
 import Database.Design.Ampersand.Output.PredLogic
 import Data.Char
 import Data.List
@@ -115,15 +115,16 @@                                 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:"
+                                  <> text "De details van elk van deze gegevensverzameling worden, op alfabetische volgorde, in de twee nu volgende tabellen 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:"
+                                  <> text "The details of each entity type are described (in alphabetical order) in the following two tables:"
                              )
-     <> conceptTable
+     <> conceptTable True
+     <> conceptTable False
      <> mconcat (map detailsOfClass (sortBy (compare `on` name) (classes oocd)))
 
 
@@ -137,27 +138,46 @@   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
-                 ]
-
+  conceptTable :: Bool    -- this bool is introduced to split the table into two separate tables. The first table contains
+                          -- the concepts that have their own table in the logical data model. The second table contains
+                          -- all other concepts.  
+               -> Blocks
+  conceptTable keys = 
+    table (if keys
+           then text.l $ (NL "Logische gegevensverzamelingen"
+                         ,EN "Logical entity types")
+           else text.l $ (NL "Overige attributen"
+                         ,EN "Other attributes"
+                         )
+          )
+         [(AlignLeft,1/6),(AlignLeft,4/6),(AlignLeft,1/6)]
+         [ (plain.text.l) (NL "Concept"       , EN "Concept")
+         , (plain.text.l) (NL "Betekenis"     , EN "Meaning")
+         , (plain.text.l) (NL "Type"          , EN "Type") 
+         ] 
+         [ [ (plain.text.name) c
+           ,   meaningOf c
+            <> fromList (maybe mempty (concatMap $ amPandoc . explMarkup) $ purposeOf fSpec (fsLang fSpec) c)
+           , mempty
+           ]
+         | c <- sortBy (compare `on` name) . filter keyFilter . delete ONE $ allConcepts fSpec
+         ]
+     where
+       keyFilter :: A_Concept -> Bool
+       keyFilter cpt = (    keys &&      isKey  cpt)
+                     ||(not keys && (not.isKey) cpt)
+       isKey :: A_Concept -> Bool
+       isKey cpt = cpt `elem` ooCpts oocd
+       meaningOf :: A_Concept -> Blocks
+       meaningOf = mconcat . map (fromList . string2Blocks ReST . cddef) . concDefs 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
+             Just cpt -> purposes2Blocks (getOpts fSpec) (purposesDefinedIn fSpec (fsLang fSpec) cpt)
         <> (para . text . l) ( NL "Deze gegevensverzameling bevat de volgende attributen: "
                              , EN "This entity type has the following attributes: "
                              )
@@ -177,26 +197,24 @@                                             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 ] 
+        <> let asscs = [ assoc | assoc <- assocs oocd, assSrc assoc == clName cl || assTgt assoc == clName cl
+                       ] 
            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) 
+                 _  -> 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 :: Database.Design.Ampersand.Graphic.ClassDiagram.Association -> Blocks
      assocToRow assoc  =
-        (para.text.assrhr) assoc <>
-        purposeAndMeaningOfAssoc assoc
+         plain (  (text.assrhr) assoc
+                <>(text.l) (NL " (vanaf ",EN " (from ")
+                <>(text.assSrc) assoc
+                <>(text.l) (NL " naar ", EN " to ")
+                <>(text.assTgt) assoc
+                <>text ")."
+               ) 
      {- <>
         if (null.assrhr) assoc
         then fatal 192 "Shouldn't happen: flip the relation for the right direction!"
@@ -409,7 +427,15 @@             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)
-     ]
+     , if isSignal rule
+       then mempty
+       else (para.text.l)
+              (NL $ "Overtredingen van deze regel leiden tot een foutmelding aan de gebruiker: "
+                        ++"\"TODO\"."
+              ,EN $ "Violations of this rule will result in an error message for the user: "
+                        ++"\"TODO\"."
+              )   
+     ]   
     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
src/Database/Design/Ampersand/Output/ToPandoc/ChapterDiagnosis.hs view
@@ -3,627 +3,545 @@ 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
-             ]
-
+import Data.List(nub,partition)
+import Data.Maybe(isJust)
+
+
+fatal :: Int -> String -> a
+fatal = fatalMsg "Output.ToPandoc.ChapterDiagnosis"
+
+chpDiagnosis :: FSpec -> (Blocks,[Picture])
+chpDiagnosis fSpec
+ = (  chptHeader (fsLang fSpec) Diagnosis
+   <> para (   (str.l) (NL "Dit hoofdstuk geeft een analyse van het Ampersand-script van "
+                       ,EN "This chapter provides an analysis of the Ampersand script of ")
+            <> (emph.singleQuoted.str.name) fSpec 
+            <>  str ". "
+            <> (str.l) (NL $ "Deze analyse is bedoeld voor de auteur(s) van dit script. "
+                          ++ "Op basis hiervan kunnen zij het script completeren en mogelijke tekortkomingen verbeteren."
+                       ,EN $ "This analysis is intended for the author(s) of this script. "
+                          ++ "It can be used to complete the script or to improve possible flaws.")
+           )   
+   <> 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 and/or without a meaning
+   <> 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
+   <> processrulesInPatterns --
+   <> wipReport              -- sums up the work items (i.e. the violations of process rules)
+   <> violationReport          -- sums up the violations caused by the population of this script.
+     
+   , pics )
+  where
+  -- shorthand for easy localizing    
+  l :: LocalizedStr -> String
+  l lstr = localize (fsLang fSpec) lstr
+
+  roleRuleTable :: Blocks
+  roleRuleTable
+    | null ruls = mempty
+    | null (fRoles fSpec) =
+         para (   (emph.str.upCap.name) fSpec
+               <> (str.l) (NL " specificeert geen rollen. "
+                          ,EN " does not define any roles. ")
+              )
+    | otherwise =
+        case (filter isSignal) ruls of
+          []   -> para (   (emph.str.upCap.name) fSpec
+                        <> (str.l) (NL " kent geen procesregels. "
+                                   ,EN " does not define any process rules. ")
+                       )
+          sigs -> (para (   (emph.str.upCap.name) fSpec
+                         <> (str.l) (NL " kent regels aan rollen toe. "
+                                    ,EN " assigns rules to roles. ")
+                         <> (str.l) (NL "De volgende tabel toont welke regels door een bepaalde rol kunnen worden gehandhaafd."
+                                    ,EN "The following table shows the rules that are being maintained by a given role.")
+                        )
+                  ) <> 
+                  ( table -- No caption:
+                          mempty
+                          -- Alignment:
+                          (  (AlignLeft,0.4) 
+                           : replicate (length.fRoles $ fSpec) (AlignLeft, 0.6/(fromIntegral.length.fRoles $ fSpec))
+                          )  
+                          -- Header row:
+                          (  (plain.str.l) (NL "Regel", EN "Rule")
+                           : map (plain.str.name) (fRoles fSpec)
+                          )
+                          -- Content rows:
+                          [  (plain.str.name) rul
+                            :[f rol rul | rol<-fRoles fSpec] 
+                          | rul<-sigs 
+                          ]
+                  )
+     where
+                  
+      ruls = filter inScopeRule . filter isSignal . vrules $ fSpec                  
+      f :: Role -> Rule -> Blocks
+      f rol rul | (rol,rul) `elem` maintained      = (plain.emph.str.l) (NL "ja",EN "yes")
+                | (rol,rul) `elem` dead            = (plain.emph.str.l) (NL "nee",EN "no")
+                | (rol,rul) `elem` fRoleRuls fSpec = (plain.emph.str.l) (NL "part",EN "part")
+                | otherwise                      = mempty
+      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 :: Blocks
+  roleomissions
+   = if (null . filter inScopePat . vpatterns) fSpec
+     then mempty
+     else (if (null.fRoleRuls) fSpec && (not.null.vrules) fSpec
+           then plain (   (emph.str.upCap.name) fSpec
+                       <> (str.l) (NL " kent geen regels aan rollen toe. "
+                                  ,EN " does not assign rules to roles. ")
+                       <> (str.l) (NL "Een generieke rol, User, zal worden gedefinieerd om al het werk te doen wat in het bedrijfsproces moet worden uitgevoerd."
+                                  ,EN "A generic role, User, will be defined to do all the work that is necessary in the business process.")
+                      )
+           else mempty
+          )<>
+          (if null (fRoleRels fSpec) && (not.null.fRoleRuls) fSpec ||(not.null.fRoleRels) fSpec
+           then plain (   (emph.str.upCap.name) fSpec
+                       <> (str.l) (NL " specificeert niet welke rollen de inhoud van welke relaties mogen wijzigen. "
+                                  ,EN " does not specify which roles may change the contents of which relations. ")
+                      )
+           else mempty
+          )
+
+  missingConceptDefs :: Blocks
+  missingConceptDefs =
+   case missing of
+      []  -> if (null.concs) fSpec
+             then mempty
+             else (para.str.l) (NL "Alle concepten in dit document zijn voorzien van een bestaansreden."
+                               ,EN "All concepts in this document have been provided with a purpose.")
+      [c] -> para (   (str.l) (NL "De bestaansreden van concept "
+                              ,EN "The concept ")
+                   <> (singleQuoted.str.name) c
+                   <> (str.l) (NL " is niet gedocumenteerd."
+                              ,EN " remains without a purpose.")
+                  )
+      xs  -> para (   (str.l) (NL "De bestaansreden van de concepten: "
+                              ,EN "Concepts ")
+                   <> commaPandocAnd (fsLang fSpec) (map (str.name) xs)
+                   <> (str.l) (NL " is niet gedocumenteerd."
+                              ,EN " 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 :: Blocks
+  unusedConceptDefs
+   = case [cd | cd <-cDefsInScope fSpec, name cd `notElem` map name (allConcepts fSpec)] of
+      []  -> if (null.cDefsInScope) fSpec
+             then mempty
+             else para.str.l $
+                     (NL "Alle concepten, die in dit document zijn voorzien van een definitie, worden gebruikt in relaties."
+                     ,EN "All concepts defined in this document are used in relations.")
+      [c] -> para (   (str.l) (NL "Het concept ",EN "The concept ") 
+                   <> singleQuoted (str (name c))
+                   <> (str.l) (NL " is gedefinieerd, maar wordt niet gebruikt."
+                              ,EN " is defined, but isn't used.")
+                  )
+      xs  -> para (   (str.l) (NL "De concepten: ", EN "Concepts ")
+                   <> commaPandocAnd (fsLang fSpec) (map (str . name) xs)
+                   <> (str.l) (NL " zijn gedefinieerd, maar worden niet gebruikt."
+                              ,EN " are defined, but not used.")
+                  )
+
+  missingRels :: Blocks
+  missingRels
+   = case bothMissing ++ purposeOnlyMissing ++ meaningOnlyMissing of
+      [] -> (para.str.l) (NL "Alle relaties in dit document zijn voorzien van zowel een reden van bestaan (purpose) als een betekenis (meaning)."
+                         ,EN "All relations in this document have been provided with a purpose as well as a meaning.")
+      _ ->(case bothMissing of
+            []  -> mempty
+            [d] -> para (   (str.l) (NL "Van de relatie ",EN "The relation ")
+                         <> showDcl d
+                         <> (str.l) (NL " ontbreekt zowel de betekenis (meaning) als de reden van bestaan (purpose)."
+                                    ,EN " lacks both a purpose as well as a meaning.")
+                        )
+            ds  -> para (   (str.l) (NL "Van de relaties ",EN "The relations ")
+                          <> commaPandocAnd (fsLang fSpec) (map showDcl ds) 
+                          <>(str.l) (NL " ontbreken zowel de betekenis (meaning) als de reden van bestaan (purpose)."
+                                    ,EN " all lack both a purpose and a meaning.")
+                        )
+          )<>
+          (case purposeOnlyMissing of
+            []  -> mempty
+            [d] -> para (   (str.l) (NL "De reden waarom relatie ",EN "The purpose of relation ")
+                         <> showDcl d
+                         <> (str.l) (NL " bestaat wordt niet uitgelegd."
+                                    ,EN " remains unexplained.")
+                        )
+            ds  -> para (   (str.l) (NL "Relaties ",EN "The purpose of relations ")
+                          <> commaPandocAnd (fsLang fSpec) (map showDcl ds) 
+                          <>(str.l) (NL " zijn niet voorzien van een reden van bestaan (purpose)."
+                                    ,EN " is not documented.")
+                        )
+          )<>
+          (case meaningOnlyMissing of
+            []  -> mempty
+            [d] -> para (   (str.l) (NL "De betekenis van relatie ",EN "The meaning of relation ")
+                         <> showDcl d
+                         <> (str.l) (NL " is niet gedocumenteerd."
+                                    ,EN " is not documented.")
+                        )
+            ds  -> para (   (str.l) (NL "De betekenis van relaties ",EN "The meaning of relations ")
+                          <> commaPandocAnd (fsLang fSpec) (map showDcl ds) 
+                          <>(str.l) (NL " zijn niet gedocumenteerd."
+                                    ,EN " is not documented.")
+                        )
+          )
+     where bothMissing, purposeOnlyMissing, meaningOnlyMissing :: [Declaration]
+           bothMissing        = filter (not . hasPurpose) . filter (not . hasMeaning) $ decls
+           purposeOnlyMissing = filter (not . hasPurpose) . filter (      hasMeaning) $ decls
+           meaningOnlyMissing = filter (      hasPurpose) . filter (not . hasMeaning) $ decls
+           decls = allDecls fSpec  -- A restriction on only themes that the user wants the document for is not supported, 
+                                   -- because it is possible that declarations from other themes are required in the
+                                   -- generated document. 
+           showDcl = math . showMath . EDcD
+  hasPurpose :: Motivated a => a -> Bool
+  hasPurpose = not . null . purposesDefinedIn fSpec (fsLang fSpec)
+  hasMeaning :: Meaning a => a -> Bool
+  hasMeaning = isJust . meaning (fsLang fSpec)
+
+  relsNotUsed :: Blocks
+  pics :: [Picture]
+  (relsNotUsed,pics)
+   = (  
+       (case notUsed of
+          []  -> ( if (null.relsMentionedIn.vrules) fSpec
+                   then mempty
+                   else (para .str.l)
+                            (NL "Alle relaties in dit document worden in één of meer regels gebruikt."
+                            ,EN "All relations in this document are being used in one or more rules.")
+                 )
+          [r] -> para (   (str.l) (NL "De relatie ",EN  "Relation ")
+                       <> r 
+                       <> (str.l) (NL " wordt in geen enkele regel gebruikt. "
+                                  ,EN " is not being used in any rule. ")
+                      )
+          rs  -> para (   (str.l) (NL "Relaties ", EN "Relations ")
+                       <> commaPandocAnd (fsLang fSpec) rs
+                       <> (str.l) (NL " worden niet gebruikt in regels. "
+                                  ,EN " are not used in any rule. ")
+                      ) 
+       ) <>
+       ( case pictsWithUnusedRels of
+          [pict] -> para (    (str.l) (NL "Figuur ", EN "Figure ")
+                           <> xRefReference (getOpts fSpec) pict 
+                           <> (str.l) (NL " geeft een conceptueel diagram met alle relaties."
+                                      ,EN " shows a conceptual diagram with all relations.")
+                         ) <>
+                    plain((showImage (getOpts fSpec)) pict)
+          picts  -> mconcat
+                       [ para (   (str.l) (NL "Figuur ", EN "Figure ")
+                               <> xRefReference (getOpts fSpec) pict
+                               <> (str.l) (NL " geeft een conceptueel diagram met alle relaties die gedeclareerd zijn in "
+                                          ,EN " 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 :: [Inlines]
+           notUsed = [(math . showMath) (EDcD d)
+                     | d@Sgn{} <- nub (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 :: Blocks
+  missingRules
+   = case if null (themes fSpec)
+          then vrules fSpec
+          else concat [udefrules pat | pat<-vpatterns fSpec, name pat `elem` themes fSpec] of
+      []   -> mempty
+      ruls ->
+       ( if all hasMeaning ruls && all hasPurpose ruls
+         then (para.str.l) (NL "Alle regels in dit document zijn voorzien van een uitleg."
+                           ,EN "All rules in this document have been provided with a meaning and a purpose.")
+         else ( case filter (not.hasPurpose) ruls of
+                  []  -> mempty
+                  rls -> (para.str.l) (NL "Van de volgende regels is de bestaansreden niet uitgelegd:"
+                                      ,EN "Rules are defined without documenting their purpose:")
+                       <> bulletList [    (para.emph.str.name) r 
+                                       <> (plain.str.show.origin) r 
+                                     | r <- rls]
+              ) <>
+              ( case filter (not.hasMeaning) ruls of
+                  []  -> mempty
+                  rls -> (para.str.l) (NL "Van de volgende regels is de betekenis uitgelegd in taal die door de computer is gegenereerd:"
+                                      ,EN "Rules are defined, the meaning of which is documented by means of computer generated language:")
+                       <> bulletList [    (para.emph.str.name) r 
+                                       <> (plain.str.show.origin) r 
+                                     | r <- rls]
+              )
+       ) 
+
+  ruleRelationRefTable :: Blocks
+  ruleRelationRefTable =
+      (para.str.l) (NL $ "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."
+                   ,EN $ "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."
+                   )
+    <>(table -- No caption:
+             mempty
+             -- Alignment:
+             ((AlignLeft,0.4) : replicate 6 (AlignCenter,0.1))
+             -- Headers
+             (map (plain.str.l) [ (NL "Thema"         , EN "Theme")
+                                , (NL "Relaties"      , EN "Relations")
+                                , (NL "Met referentie", EN "With reference")
+                                , (NL "%"             , EN "%")
+                                , (NL "Regels"        , EN "Rules")
+                                , (NL "Gehele context", EN "Entire context")
+                                , (NL "%"             , EN "%")
+                                ]
+             )
+             -- Content rows
+             (   map mkTableRowPat (vpatterns fSpec)
+              ++ [mempty] -- empty row
+              ++ [mkTableRow (l (NL "Gehele context", EN "Entire context")) (filter decusr $ vrels fSpec) (vrules fSpec)]
+             )
+      )
+    where mkTableRow :: String  -- The name of the pattern / fSpec 
+                     -> [Declaration] --The user-defined relations of the pattern / fSpec
+                     -> [Rule]  -- The user-defined rules of the pattern / fSpec
+                     -> [Blocks]
+          mkTableRowPat p = mkTableRow (name p) (relsDefdIn p) (udefrules p)
+          mkTableRow nm rels ruls =
+            map (plain.str) [ nm
+                            , (show.length) rels 
+                            , (show.length) (filter hasRef rels)
+                            , showPercentage (length rels) (length.filter hasRef $ rels)
+                            , (show.length) ruls
+                            , (show.length) (filter hasRef ruls)
+                            , showPercentage (length ruls) (length.filter hasRef $ ruls)
+                            ]
+
+          hasRef x = maybe False (any  ((/=[]).explRefIds)) (purposeOf fSpec (fsLang fSpec) x)
+
+          showPercentage x y = if x == 0 then "-" else show (y*100 `div` x)++"%"
+
+  processrulesInPatterns :: Blocks
+  processrulesInPatterns = 
+       para ("TODO: Inleiding bij de rol-regel tabel")
+    <> if null (fRoleRuls fSpec)
+       then mempty
+       else table -- No caption:
+                  mempty
+                  -- Alignment:
+                  ( if multProcs
+                    then replicate 4 (AlignLeft,1/4)
+                    else replicate 3 (AlignLeft,1/3)
+                  )
+                  -- Headers:
+                  (  [ (plain.str.l) (NL "rol"      , EN "role")]
+                   ++[ (plain.str.l) (NL "in proces", EN "in process") | multProcs]
+                   ++[ (plain.str.l) (NL "regel"    , EN "rule")
+                     , (plain.str.l) (NL "uit"      , EN "from")
+                     ]
+                  )
+                  -- Rows:
+                  [  [ (plain.str.name) rol]
+                   ++[ (plain.str.r_env) rul | multProcs]
+                   ++[ (plain.str.name) rul
+                     , (plain.str.r_env) rul
+                     ]
+                  | (rol,rul)<-fRoleRuls fSpec]
+     where multProcs = length procsInScope>1
+           procsInScope = filter inScopePat (vpatterns fSpec)
+
+  wipReport :: Blocks
+  wipReport
+   =   case popwork of
+         []       -> (para.str.l) (NL "De populatie in dit script beschrijft geen onderhanden werk. "
+                                  ,EN "The population in this script does not specify any work in progress. ")
+         [(r,ps)] -> para (   (str.l) (NL"Regel ",EN "Rule")
+                            <> quoterule r
+                            <>(str.l) (NL $ " laat " ++count Dutch   (length ps) "taak"++" zien."
+                                      ,EN $ " shows "++count English (length ps) "task"++".")
+                          )
+         _        -> (para.str.l) (NL "Dit script bevat onderhanden werk. De volgende tabellen geven details met regelnummers in de oorspronkelijk script-bestanden."
+                                  ,EN "This script contains work in progress. The following tables provide details with line numbers from the original script files.")
+            
+     <> if null popwork
+        then mempty
+        else table -- No caption:
+                    mempty
+                    -- Alignment:
+                    ((AlignLeft,1/3): replicate 2 (AlignRight,1/3))
+                    --Header:
+                    (map (plain.str.l) 
+                           [ (NL "regel"  ,EN "rule" )
+                           , (NL "locatie",EN "location" )
+                           , (NL "#taken" ,EN "#tasks" )
+                           ])
+                    -- Rows:
+                    [ map (plain.str)
+                           [ name r
+                           , (show.origin) r
+                           , (show.length) ps
+                           ]
+                    | (r,ps)<-popwork
+                    ]
+     <>
+-- the tables containing the actual work in progress population
+     mconcat
+     [    para (  (str.l) (NL "Regel", EN "Rule")
+               <> quoterule r
+               <> xRefTo (XRefNaturalLanguageRule r)
+               <> (str.l) (NL " luidt: ", EN "says: ")
+               )
+       <> fromList (meaning2Blocks (fsLang fSpec) r)
+       <> para (  (str.l) (NL "Deze regel bevat nog werk (voor "
+                          ,EN "This rule contains work (for ")
+                <>commaPandocOr (fsLang fSpec) (map (str.name) (nub [rol | (rol, rul)<-fRoleRuls fSpec, r==rul]))
+                <>")"
+                <> if length ps == 1
+                   then   (str.l) (NL ", te weten ", EN " by ")
+                       <> oneviol r (head ps)
+                       <> "."
+                   else   (str.l) (NL $ ". De volgende tabel laat de "++(if length ps>10 then "eerste tien " else "")++"items zien die aandacht vragen."
+                                  ,EN $ "The following table shows the "++(if length ps>10 then "first ten " else "")++"items that require attention.")
+               )
+       <> if length ps <= 1
+          then mempty -- iff there is a single violation, it is already shown in the previous paragraph
+          else violtable r ps 
+     | (r,ps)<- 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 null (name r)
+         then (str.l) (NL $ "op "++show (origin r)
+                      ,EN $ "at "++show (origin r))
+         else (singleQuoted.str.name) r
+      oneviol :: Rule -> AAtomPair -> Inlines
+      oneviol r p
+       = if source r==target r && apLeft p==apRight p
+         then singleQuoted (  (str.name.source) r 
+                            <>(str.showValADL.apLeft) p
+                           )
+         else    "("  <> (str.name.source) r <> (str.showValADL.apLeft) p 
+              <> ", " <> (str.name.target) r <> (str.showValADL.apRight) p
+              <> ")"
+      popwork :: [(Rule,[AAtomPair])]
+      popwork = [(r,ps) | (r,ps) <- allViolations fSpec, isSignal r, inScopeRule r]
+
+  violationReport :: Blocks
+  violationReport =
+        (para (case (invariantViolations, processViolations) of
+                ([] , [] ) ->  (str.l) (NL "De populatie in dit script overtreedt geen regels. "
+                                       ,EN "The population in this script violates no rule. ")
+                (iVs, pVs) ->  (str.l) (NL "De populatie in dit script overtreedt "
+                                       ,EN "The population in this script violates ")
+                             <>(str.show.length) iVs
+                             <>(str.l) (NL $ " invariant"++(if length iVs == 1 then "" else "en")++" en "
+                                       ,EN $ " invariant"++(if length iVs == 1 then "" else "s")++" and ")
+                             <>(str.show.length) pVs
+                             <>(str.l) (NL $ " procesregel" ++if length pVs == 1 then "" else "s"++"."
+                                       ,EN $ " process rule"++if length pVs == 1 then "" else "s"++"."
+                           )
+              )
+        )
+     <> bulletList (map showViolatedRule invariantViolations)
+     <> bulletList (map showViolatedRule processViolations)
+    where
+         (processViolations,invariantViolations) = partition (isSignal.fst) (allViolations fSpec)
+         showViolatedRule :: (Rule,[AAtomPair]) -> Blocks
+         showViolatedRule (r,ps)
+             =    (para.emph)
+                      (  (str.l) (NL "Regel ", EN "Rule ")
+                       <>(str.name) r
+                      )
+               <> para(  (if isSignal r 
+                          then (str.l) (NL "Totaal aantal taken: "        ,EN "Total number of work items: ")
+                          else (str.l) (NL "Totaal aantal overtredingen: ",EN "Total number of violations: ")
+                         )
+                       <>(str.show.length) ps
+                      )
+               <> table -- Caption
+                        (if isSignal r
+                         then ( (str.l) (NL "Openstaande taken voor "     ,EN "Tasks yet to be performed by ")
+                              <>(commaPandocOr (fsLang fSpec) (map (str.name) (nub [rol | (rol, rul)<-fRoleRuls fSpec, r==rul])))
+                              )
+                         else ( (str.l) (NL "Overtredingen van invariant ",EN "Violations of invariant ")
+                              <>(str.name) r
+                              )
+                        )  
+                        -- Alignment:
+                        (replicate 2 (AlignLeft,1/2))
+                        -- Headers:
+                        [(para.strong.text.name.source.rrexp) r
+                        ,(para.strong.text.name.target.rrexp) r
+                        ]
+                        -- Rows:
+                        [ [(para.text.showValADL.apLeft) p
+                          ,(para.text.showValADL.apRight) p
+                          ]
+                        | p<- ps]
+
+
+
+  violtable :: Rule -> [AAtomPair] -> Blocks
+  violtable r ps
+      = if hasantecedent r && isIdent (antecedent r)  -- note: treat 'isIdent (consequent r) as binary table.
+        then table -- No caption:
+                   mempty
+                   -- Alignment:
+                   [(AlignLeft,1.0)]
+                   -- Header:
+                   [(plain.str.name.source) r]
+                   -- Data rows:
+                   [ [(plain.str.showValADL.apLeft) p]
+                   | p <-take 10 ps --max 10 rows
+                   ]
+        else table -- No caption:
+                   mempty
+                   -- Alignment:
+                   (replicate 2 (AlignLeft,1/2))
+                   -- Header:
+                   [(plain.str.name.source) r , (plain.str.name.target) r ]
+                   -- Data rows:
+                   [ [(plain.str.showValADL.apLeft) p,(plain.str.showValADL.apRight) p]
+                   | p <-take 10 ps --max 10 rows
+                   ]
+
+  inScopePat :: Pattern -> Bool
+  inScopePat x = null (themes fSpec) || name x `elem` themes fSpec  -- restrict if this is partial documentation.
+
+  inScopeRule :: Rule -> Bool
+  inScopeRule r =
+        or [ null (themes fSpec)
+           , r `elem` concat [udefrules pat | pat<-vpatterns fSpec, name pat `elem` themes fSpec]
+           ]
src/Database/Design/Ampersand/Output/ToPandoc/ChapterECArules.hs view
@@ -4,52 +4,36 @@ 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
+ | (not.genEcaDoc.getOpts) fSpec = mempty
+ | otherwise = 
+     chptHeader (fsLang fSpec) EcaRules
+  <> (para.str.l) (NL "Dit hoofdstuk bevat de ECA regels."
+                  ,EN "This chapter lists the ECA rules.")
+  <> para (  (str.l) (NL "ECA regels:"                 , EN "ECA rules:")
+           <> linebreak
+           <> (str.l) (NL"   tijdelijk ongedocumenteerd", EN "   temporarily not documented")
+          )
+  <> mconcat
+       [   (blockQuote . codeBlock . ("\n     "++) . showECA "\n     ") eca
+        <> if False -- TODO : This could be enabled by introducing a switch in Options.hs
+           then mempty
+           else    para (   linebreak
+                         <> (str.l) (NL "------ Afleiding ----->"  ,EN "------ Derivation ----->")
+                        )
+                <> (showProof (codeBlock . ("\n     "++) . showECA "\n     ") . proofPA (getOpts fSpec) . ecaAction) eca   --  for the proof
+                <> para (   linebreak
+                         <> (str.l) (NL "<------Einde afleiding --",EN "<------End Derivation --") 
+                        )
+       | eca<-vEcas fSpec, (not.isNop.ecaAction) eca
+       ]
 
-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."
+  -- shorthand for easy localizing    
+  l :: LocalizedStr -> String
+  l lstr = localize (fsLang fSpec) lstr
 
-  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
@@ -10,58 +10,72 @@ -- TODO: add introductory and explanatory text to chapter
 -- TODO: what about KGVs?
 
-chpFunctionPointAnalysis :: FSpec -> (Blocks,[Picture])
+chpFunctionPointAnalysis :: FSpec -> Blocks
 chpFunctionPointAnalysis fSpec
- = ( (chptHeader (fsLang fSpec) FunctionPointAnalysis) <>
-     (fromList . concat)
-       [ introBlocks
-       , dataModelFPABlocks
-       , userTransactionFPABlocks
-       ]
-   , []) -- no pictures at the moment
+ =    chptHeader (fsLang fSpec) FunctionPointAnalysis
+   <> para (   (str.l) (NL "Dit hoofdstuk ..."
+                       ,EN "This chapter ...")
+           )
+   <> -- Data model section:
+      table -- Caption: 
+            ((str.l) (NL "Datamodel", EN "Data model"))
+            -- Alignment:
+            (replicate 4 (AlignLeft, 1/4))
+            -- Header:
+            (map (plain.str.l) 
+               [ (NL "Type"        , EN "Type")
+               , (NL "Naam"        , EN "Name")
+               , (NL "Complexiteit", EN "Complexity")
+               , (NL "FP"          , EN "FP")
+               ])
+            -- Data rows:
+            ( [map (plain.str) 
+                 [ l (NL "ILGV", EN "ILGV(???)")
+                 , nm
+                 , showLang (fsLang fSpec) cmplxty
+                 , (show.fpVal) fp
+                 ]
+              | fp@FP{fpType=ILGV, fpName=nm, fpComplexity=cmplxty} <- fst (dataModelFPA fpa)
+              ]++
+              [ [ mempty
+                , mempty
+                , (plain.str.l) (NL "Totaal:", EN "Total:")
+                , (plain.str.show.snd.dataModelFPA) fpa
+              ] ]
+            )
+   <> -- User transaction section:
+      table -- Caption
+            ( (str.l)  (NL "Gebruikerstransacties", EN "User transactions"))
+            -- Alignment:
+            (replicate 4 (AlignLeft, 1/4))
+            -- Header:
+            (map (plain.str.l) 
+               [ (NL "Type"        , EN "Type")
+               , (NL "Naam"        , EN "Name")
+               , (NL "Complexiteit", EN "Complexity")
+               , (NL "FP"          , EN "FP")
+               ])
+            -- Data rows::
+            ( [map plain 
+                 [ (str.showLang (fsLang fSpec).fpType) fp
+                 , (str.fpName) fp
+                 , (str.showLang (fsLang fSpec).fpComplexity) fp
+                 , (str.show.fpVal) fp
+                 ]
+              |fp@FP{} <- fst (userTransactionFPA fpa)
+              ]++
+              [ [ mempty
+                , mempty
+                , (plain.str.l) (NL "Totaal:", EN "Total:")
+                , (plain.str.show.snd.userTransactionFPA) fpa
+              ] ]
+            )
+       
+   
   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 ..."
-                  ]]
+  -- shorthand for easy localizing    
+  l :: LocalizedStr -> String
+  l lstr = localize (fsLang fSpec) lstr
 
-  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
+  fpa = fpAnalyze fSpec 
 
-  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
@@ -3,7 +3,6 @@   (chpGlossary)
 where
 import Database.Design.Ampersand.Output.ToPandoc.SharedAmongChapters
-import Database.Design.Ampersand.ADL1
 import Database.Design.Ampersand.Classes
 
 chpGlossary :: Int -> FSpec ->  Blocks
src/Database/Design/Ampersand/Output/ToPandoc/ChapterInterfaces.hs view
@@ -1,6 +1,6 @@ module Database.Design.Ampersand.Output.ToPandoc.ChapterInterfaces
-  ( chpInterfacesPics
-  , chpInterfacesBlocks
+  ( 
+   chpInterfacesBlocks
   )
 where
 import Data.List
@@ -14,9 +14,6 @@ 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) ]
@@ -127,7 +124,7 @@     docMSubInterface editableRels roles hierarchy subIfc =
       case subIfc of
         Nothing                -> []
-        Just (InterfaceRef nm) -> [ plainText $ "REF "++nm ] -- TODO: handle InterfaceRef
+        Just (InterfaceRef isLink nm) -> [ plainText $ (if isLink then "LINKTO " else "")++"REF "++nm ] -- TODO: handle InterfaceRef
         Just (Box _ _ objects) -> [ docInterfaceObjects editableRels roles (hierarchy ++[i]) obj | (obj,i) <- zip objects [1..] ]
 
     docCrudMatrix :: Interface -> Blocks
@@ -188,8 +185,8 @@                   , 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
+                        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 "*")
src/Database/Design/Ampersand/Output/ToPandoc/ChapterNatLangReqs.hs view
@@ -1,26 +1,19 @@ {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE OverloadedStrings #-}
-module Database.Design.Ampersand.Output.ToPandoc.ChapterNatLangReqs where
+module Database.Design.Ampersand.Output.ToPandoc.ChapterNatLangReqs (
+      chpNatLangReqs
+ ) 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
+--import Database.Design.Ampersand.Basics
+import Database.Design.Ampersand.Output.ToPandoc.SharedAmongChapters
 
 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 ***
@@ -59,12 +52,14 @@                      <> "All definitions have been numbered for the sake of traceability. "
                      )
    <> --  *** Requirements ***
-   fromList dpRequirementsOld
---   dpRequirementesNew
+   (mconcat . map printOneTheme . orderingByTheme) fSpec
    <> --  *** Legal Refs ***
      if genLegalRefs (getOpts fSpec) then legalRefs else mempty
 
   where
+  -- shorthand for easy localizing    
+  l :: LocalizedStr -> String
+  l lstr = localize (fsLang fSpec) lstr
   legalRefs :: Blocks
   legalRefs = (header (lev+2) sectionTitle)
             <> table caption'
@@ -80,363 +75,220 @@                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)
+  -- | 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 :: ThemeContent -> Blocks
+  printOneTheme tc 
+    | (not . null . themes) fSpec && (isNothing . patOfTheme) tc 
+        = mempty   -- The document is partial (because themes have been defined), so we don't print loose ends.
+    | otherwise 
+        =   --  *** Header of the theme: ***
+            headerWithLabel (XRefNaturalLanguageTheme (patOfTheme tc))
+                            (lev+2)
+                            (case (patOfTheme tc,fsLang fSpec) of
+                                (Nothing, Dutch  ) -> "Losse eindjes..."
+                                (Nothing, English) -> "Loose ends..."
+                                (Just pat, _     ) -> text (name pat)
+                            )
+          <> --  *** Purpose of the theme: ***
+             (case patOfTheme tc of
+                 Nothing  -> 
+                   (para.str.l) 
+                     (NL "Deze paragraaf beschrijft de relaties en concepten die niet in voorgaande secties zijn beschreven."
+                     ,EN "This paragraph shows remaining artifacts that have not been described in previous paragraphs."
+                     )
+                 Just pat -> purposes2Blocks (getOpts fSpec) (purposesDefinedIn fSpec (fsLang fSpec) pat)
              )
-           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
+          <> printIntro    (cptsOfTheme tc)
+          <> (mconcat . map printConcept . cptsOfTheme ) tc
+          <> (mconcat . map printRel     . dclsOfTheme ) tc
+          <> (mconcat . map printRule    . rulesOfTheme) tc
+      where
                            
 -- 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
-
+       printIntro :: [Numbered CptCont] -> Blocks
+       printIntro [] = mempty
+       printIntro nCpts
+         = case patOfTheme tc of
+             Nothing  -> mempty
+             Just pat -> 
+               ((para ((str.l) (NL "In het volgende wordt de taal geïntroduceerd ten behoeve van "
+                                 ,EN "The sequel introduces the language of ")
+                              <> (str.name) pat <> ".")
+                )<>
+                ( case nCpts of
+                   [] 
+                     -> fatal 136 "Unexpected. There should be at least one concept to introduce."
+                   [x]
+                     -> para(   (str.l) (NL "Nu volgt de definitie van het begrip "
+                                        ,EN "At this point, the definition of ")
+                             <> (showCpt x) 
+                             <> (str.l) (NL "."
+                                        ,EN " is given.")
+                            )
+                   _ 
+                     -> para(   (str.l) (NL "Nu volgen definities van de begrippen "
+                                        ,EN "At this point, the definitions of ")
+                             <> commaPandocAnd (fsLang fSpec) (map showCpt (sortWith theNr nCpts)) 
+                             <> (str.l) (NL "."
+                                        ,EN " are given.")
+                             )
+               )<>
+               ( case filter hasMultipleDefs nCpts of
+                   []  -> mempty
+                   [x] -> para(  (str.l) (NL "Het begrip "
+                                         ,EN "Concept ")
+                              <> showCpt x 
+                              <> (str.l) (NL " heeft meerdere definities."
+                                         ,EN " is multiple defined.")
+                              )
+                   multipleDefineds
+                       -> para(  (str.l) (NL "De begrippen "
+                                         ,EN "Concepts ")
+                              <> commaPandocAnd (fsLang fSpec) (map showCpt multipleDefineds) 
+                              <> (str.l) (NL " hebben meerdere definities."
+                                         ,EN " are multiple defined.")
+                              )
+               )
+              )                                    
+         where
+           showCpt :: Numbered CptCont -> Inlines
+           showCpt = emph.text.name.cCpt.theLoad
+           hasMultipleDefs :: Numbered CptCont -> Bool
+           hasMultipleDefs x = 
+              case cCptDefs (theLoad x) of
+                (_:_:_) -> True
+                _       -> False       
 
+  printConcept :: Numbered CptCont -> Blocks
+  printConcept nCpt 
+        = -- Purposes:
+           (printPurposes . cCptPurps . theLoad) nCpt
+         <> case (cCptDefs.theLoad) nCpt of
+             []    -> mempty  -- There is no definition of the concept
+             [cd] -> printCDef cd Nothing
+             cds  -> mconcat
+                    [printCDef cd (Just ("."++ [suffx])) 
+                    |(cd,suffx) <- zip cds ['a' ..]  -- There are multiple definitions. Which one is the correct one?
+                    ]
+        where
+         printCDef :: ConceptDef -- the definition to print
+                -> Maybe String -- when multiple definitions exist of a single concept, this is to distinguish
+                -> Blocks
+         printCDef cDef suffx
+           = definitionList 
+              [(   str (l (NL"Definitie " ,EN "Definition "))
+                <> case fspecFormat (getOpts fSpec) of
+                                    FLatex -> (str . show .theNr) nCpt
+                                    _      -> (str . name) cDef  
+                <> str (fromMaybe "" suffx) <> ":" 
+               , [para (   newGlossaryEntry (name cDef++fromMaybe "" suffx) (cddef cDef)
+                        <> (case fspecFormat (getOpts fSpec) of
+                                    FLatex -> rawInline "latex"
+                                                ("~\\marge{\\gls{"++escapeNonAlphaNum 
+                                                      (name cDef++fromMaybe "" suffx)++"}}")
+                                    _      -> mempty)
+                        <> str (cddef cDef)
+                        <> if null (cdref cDef) then mempty
+                           else str (" ["++cdref cDef++"]")
+                       ) 
+                 ] 
+               )
+              ]
 
-              -- | 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 ""
-                                                  )
+  printRel :: Numbered DeclCont -> Blocks
+  printRel nDcl
+       =   (printPurposes . cDclPurps . theLoad) nDcl
+        <> case (cDclMeaning . theLoad) nDcl of
+              Just m -> definitionList [( definitionListItemLabel 
+                                           (XRefNaturalLanguageDeclaration dcl)
+                                              (l (NL "Afspraak ", EN "Agreement ")++show(theNr nDcl)
+                                               ++if development (getOpts fSpec)
+                                                 then (" ("++name nDcl++")") 
+                                                 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))
+                                        , [printMeaning m]
+                                        )]
+              _      -> mempty
+        <> case samples of
+              []  -> mempty
+              [_] -> plain ((str.l) (NL "Een frase die hiermee gemaakt kan worden is bijvoorbeeld:"
+                                    ,EN "A phrase that can be formed is for instance:")
+                           )
+              _   -> plain ((str.l) (NL "Frasen die hiermee gemaakt kunnen worden zijn bijvoorbeeld:"
+                                    ,EN "Phrases that can be made are for instance:")
+                                        )
+        <> if null samples then mempty
+           else bulletList [ plain $ mkPhrase dcl sample
+                           | sample <- samples]
+         
+         where dcl = cDcl . theLoad $ nDcl
+               samples = take 3 . cDclPairs . theLoad $ nDcl
 
-  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
+  printRule :: Numbered RuleCont -> Blocks
+  printRule nRul
+   =  (printPurposes . cRulPurps . theLoad) nRul
+    <> case (cRulMeaning . theLoad) nRul of
+        Nothing 
+          -> mempty
+        Just m
+          -> definitionList 
+               [(definitionListItemLabel
+                   (XRefNaturalLanguageRule . cRul . theLoad $ nRul)
+                   ((case fsLang fSpec of
+                       Dutch   -> "Afspraak "
+                       English -> "Agreement "
+                    )++
+                    show (theNr nRul)++
+                    if development (getOpts fSpec)  
+                    then (" ("++name nRul++")")
+                    else ""
+                   )
+                , [printMeaning m]
+                ) 
+               ]
+      
 
-  mkSentence :: Bool -> Declaration -> String -> String -> [Inline]
-  mkSentence isDev decl srcAtom tgtAtom
+  mkPhrase :: Declaration -> AAtomPair -> Inlines
+  mkPhrase decl pair -- 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 "."]
+                  ->    (atomShow . upCap) srcAtom
+                     <> devShow (source decl) 
+                     <> (pragmaShow.l) (NL " correspondeert met ", EN " corresponds to ")
+                     <> atomShow tgtAtom
+                     <> devShow (target decl)
+                     <> (pragmaShow.l) (NL " in de relatie ",EN " in relation ")
+                     <> atomShow (name decl)
+                     <> "."
              | 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' "."]
+                  ->    (if null prL then mempty
+                         else pragmaShow (upCap prL) <> " ")
+                     <> devShow (source decl)
+                     <> atomShow srcAtom <> " "
+                     <> (if null prM then mempty
+                         else pragmaShow prM <> " ")
+                     <> devShow (target decl)
+                     <> atomShow tgtAtom
+                     <> (if null prR then mempty
+                         else " " <> pragmaShow prR)
+                     <> "."
 
-       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 = []
+       Isn{}     -> fatal 299 "Isn  is not supposed to be here expected here."
+       Vs{}      -> fatal 300 "Vs  is not supposed to be here expected here."
+   where srcAtom = showValADL (apLeft pair)
+         tgtAtom = showValADL (apRight pair)
+         prL = decprL decl
+         prM = decprM decl
+         prR = decprR decl
+         atomShow = str
+         pragmaShow = emph . str
+         devShow c = if (development (getOpts fSpec)) then "("<> (str.name) c <> ")" else mempty
+                   
 
--- 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]
@@ -445,8 +297,6 @@ 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]
@@ -475,4 +325,10 @@ 
 unscanRef :: [Either String Int] -> String
 unscanRef scannedRef = concat $ map (either id show) scannedRef
-             +             
+             
+printPurposes :: [Purpose] -> Blocks
+printPurposes  = fromList . concat . map (amPandoc . explMarkup) 
+
+printMeaning :: A_Markup -> Blocks
+printMeaning = fromList . amPandoc
src/Database/Design/Ampersand/Output/ToPandoc/ChapterProcessAnalysis.hs view
@@ -3,9 +3,7 @@ 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.
@@ -14,14 +12,13 @@ noProcesses :: FSpec -> Bool
 noProcesses fSpec = null (fRoles fSpec)
 
-chpProcessAnalysis :: Int -> FSpec -> (Blocks,[Picture])
+chpProcessAnalysis :: Int -> FSpec -> Blocks
 chpProcessAnalysis lev fSpec
- = ( if null procs
-     then mempty
-     else headerBlocks <> roleRuleBlocks <> fromList roleRelationBlocks <> processSections
-   , pictures)
+ = if null procs
+   then mempty
+   else headerBlocks <> roleRuleBlocks <> fromList roleRelationBlocks <> processSections
+   
  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 ]
src/Database/Design/Ampersand/Output/ToPandoc/SharedAmongChapters.hs view
@@ -10,6 +10,10 @@     , module Database.Design.Ampersand.FSpec
     , module Database.Design.Ampersand.Misc
     , module Database.Design.Ampersand.Core.AbstractSyntaxTree
+    , module Database.Design.Ampersand.ADL1
+    , module Database.Design.Ampersand.Output.PandocAux
+    , module Database.Design.Ampersand.Graphic.Graphics
+    , module Database.Design.Ampersand.Classes
     , Chapter(..)
     , chaptersInDoc
     , chptHeader
@@ -23,19 +27,20 @@     , lclForLang
     , dpRule'
     , relsInThemes
-    , Counter(..),newCounter,incEis
+ --   , Counter(..),newCounter,incEis
     , inlineIntercalate
-    , orderingByTheme
+    , ThemeContent(..), orderingByTheme
+    , Numbered(..), RuleCont(..),DeclCont(..),CptCont(..)
     , plainText
     , NLString(..)
     , ENString(..)
     , LocalizedStr
     , localize
-    )
+    , sortWith)
 where
 import Database.Design.Ampersand.Basics
-import Database.Design.Ampersand.Core.AbstractSyntaxTree hiding (Meta)
-import Database.Design.Ampersand.ADL1
+import Database.Design.Ampersand.Core.AbstractSyntaxTree hiding (Meta,sortWith)
+import Database.Design.Ampersand.ADL1 hiding (Meta)
 import Database.Design.Ampersand.Classes
 import Database.Design.Ampersand.FSpec
 import Text.Pandoc
@@ -44,10 +49,15 @@ 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.List      --       (intercalate,partition)
 import Data.Monoid
-import System.Locale
-
+import Data.Maybe
+import Data.Ord
+import qualified System.Locale as SL
+import System.FilePath
+import GHC.Exts(sortWith)
+import Database.Design.Ampersand.Graphic.Graphics
+import Database.Design.Ampersand.Classes()
 fatal :: Int -> String -> a
 fatal = fatalMsg "Output.ToPandoc.SharedAmongChapters"
 
@@ -71,7 +81,7 @@    -- temporarily switch off chapters that need too much refactoring, but keep this Haskell code compilable.
     disabled = []
     chapters
-     | test opts                  = [Interfaces]
+     | test opts                  = [SharedLang,Diagnosis]
      | diagnosisOnly opts         = [Diagnosis]
      | theme opts == StudentTheme = [Intro,SharedLang,Diagnosis,ConceptualAnalysis,DataAnalysis]
      | otherwise                   = [ Intro
@@ -122,8 +132,6 @@ 
 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++"}")
@@ -140,14 +148,12 @@ 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" )
+   <> image fileOnly (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")
@@ -156,57 +162,159 @@    <> case fspecFormat opts of
          FLatex  -> rawInline "latex" "\n\\end{center}\n\\end{figure}"
          _       -> mempty
-
+  where
+    fileOnly = (snd . splitFileName . imagePath opts) pict
+    
 -- | 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.
-                            )
-                           ]
+
+data ThemeContent = 
+       Thm { themeNr ::      Int
+           , patOfTheme ::   Maybe Pattern -- A theme is about either a pattern or about everything outside patterns
+           , rulesOfTheme :: [Numbered RuleCont] -- The (numbered) rules of that theme
+           , dclsOfTheme ::  [Numbered DeclCont] -- The (numbered) relations that are used in a rule of this theme, but not in any rule of a previous theme.
+           , cptsOfTheme ::  [Numbered CptCont]   -- The (numbered) concepts that are used in a rule of this theme, but not in any rule of a previous theme.
+           }
+data Numbered t =
+ Nr { theNr ::   Int
+    , theLoad :: t
+    }   
+instance Named t => Named (Numbered t) where
+ name = name . theLoad    
+data RuleCont = CRul { cRul ::  Rule
+                     , cRulPurps :: [Purpose] 
+                     , cRulMeaning :: Maybe A_Markup
+                     } 
+data DeclCont = CDcl { cDcl ::  Declaration
+                     , cDclPurps :: [Purpose] 
+                     , cDclMeaning :: Maybe A_Markup
+                     , cDclPairs :: [AAtomPair]
+                     } 
+data CptCont  = CCpt { cCpt ::  A_Concept
+                     , cCptDefs :: [ConceptDef]
+                     , cCptPurps :: [Purpose] 
+                     } 
+instance Named RuleCont where
+  name = name . cRul
+instance Named DeclCont where
+  name = name . cDcl
+instance Named CptCont where
+  name = name . cCpt
+data Counters 
+  = Counter { pNr :: Int --Theme number
+            , definitionNr :: Int --For Concepts
+            , agreementNr ::  Int --For declarations andrules 
+            }
+orderingByTheme :: FSpec -> [ThemeContent]
 orderingByTheme fSpec
- = f (fallRules fSpec) (filter isUserDefined (relsMentionedIn fSpec)) (allConcepts fSpec) tms
+ = f ( Counter 1 1 1 --the initial numbers of the countes
+     , (sortWith origin . filter rulMustBeShown . fallRules)       fSpec
+     , (sortWith origin . filter relMustBeShown . relsMentionedIn) fSpec
+     , (sortBy conceptOrder . filter cptMustBeShown . allConcepts)     fSpec
+     ) $ 
+     [Just pat | pat <- vpatterns fSpec -- The patterns that should be taken into account for this ordering
+        ,    null (themes fSpec)        -- all patterns if no specific themes are requested
+          || name pat  `elem` themes fSpec  -- otherwise the requested ones only
+        ]++[Nothing] --Make sure the last is Nothing, to take all res stuff.
  where
+  conceptOrder :: A_Concept -> A_Concept -> Ordering 
+  conceptOrder a b =
+  -- The sorting of Concepts is done by the origin of its first definition if there is one. 
+  -- Concepts without definition are placed last, and sorted by name.
+   case (originOfFirstCDef a, originOfFirstCDef b) of
+     (Just origA, Just origB) -> compare origA origB
+     (Just _    , Nothing   ) -> LT
+     (Nothing   , Just _    ) -> GT
+     (Nothing   , Nothing   ) -> comparing name a b
+  originOfFirstCDef :: A_Concept -> Maybe Origin
+  originOfFirstCDef cpt 
+    = case sortWith origin $ concDefs fSpec cpt of
+        [] -> Nothing
+        cd :_ -> Just (origin cd)
+        
+  rulMustBeShown r = r_usr r == UserDefined && (hasMeaning r || hasPurpose r)
+  relMustBeShown d = isUserDefined d && hasPurpose d 
   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
+  hasPurpose :: Motivated a => a -> Bool
+  hasPurpose = not . null . purposesDefinedIn fSpec (fsLang fSpec)
+  hasMeaning = isJust . meaning (fsLang fSpec)
+  cptMustBeShown = not . null . concDefs fSpec
+  f :: 
+   (Counters, [Rule], [Declaration], [A_Concept]) -> [Maybe Pattern] -> [ThemeContent]
+  f stuff 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)]
+       t:ts' -> let ( thm, rest) = partitionByTheme t stuff
+                in thm : f rest ts'
+       []    -> case stuff of
+                  (_,[],[],[]) -> []
+                  _ -> fatal 247 "No stuff should be left over."
+
+  rul2rulCont :: Rule -> RuleCont
+  rul2rulCont rul
+    = CRul { cRul      = rul
+           , cRulPurps = fromMaybe [] $ purposeOf fSpec (fsLang fSpec) rul
+           , cRulMeaning = meaning (fsLang fSpec) rul
+           }
+  dcl2dclCont :: Declaration -> DeclCont
+  dcl2dclCont dcl
+    = CDcl { cDcl      = dcl
+           , cDclPurps = fromMaybe [] $ purposeOf fSpec (fsLang fSpec) dcl
+           , cDclMeaning = meaning (fsLang fSpec) dcl
+           , cDclPairs = pairsInExpr fSpec (EDcD dcl)
+           }
+
+  cpt2cptCont :: A_Concept -> CptCont
+  cpt2cptCont cpt 
+    = CCpt { cCpt      = cpt
+           , cCptDefs  = sortWith origin $ concDefs fSpec cpt
+           , cCptPurps = fromMaybe [] $ purposeOf fSpec (fsLang fSpec) cpt
+           }
+
+
+  setNumbers :: Int           -- ^ the initial number
+             -> (t -> a)      -- ^ the constructor function
+             -> [t]           -- ^ a list of things that are numberd        
+             -> [Numbered a] 
+  setNumbers i construct items =
+    case items of 
+      []     -> []
+      (x:xs) ->  Nr { theNr   = i
+                    , theLoad = construct x
+                    }:setNumbers (i+1) construct xs
   -- | 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 :: Maybe Pattern
+                   -> ( Counters, [Rule], [Declaration], [A_Concept])
+                   -> ( ThemeContent , ( Counters ,[Rule], [Declaration], [A_Concept])
                       )
-  partitionByTheme pat ruls rels cpts
-      = ((rulsOfTheme,rulsNotOfTheme), (relsOfTheme,relsNotOfTheme), (cptsOfTheme,cptsNotOfTheme))
+  partitionByTheme t (cnt, ruls, rels, cpts)
+      = ( Thm { themeNr      = pNr cnt
+              , patOfTheme   = t
+              , rulesOfTheme = setNumbers (agreementNr cnt + length themeDcls ) rul2rulCont thmRuls
+              , dclsOfTheme  = setNumbers (agreementNr cnt) dcl2dclCont themeDcls
+              , cptsOfTheme  = setNumbers (definitionNr cnt) cpt2cptCont themeCpts
+              }
+        , (Counter {pNr = pNr cnt +1
+                   ,definitionNr = definitionNr cnt + length themeCpts
+                   ,agreementNr = agreementNr cnt + length themeDcls + length thmRuls
+                   }
+          , restRuls, restDcls, restCpts)
+        )
      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?
+       (thmRuls,restRuls) = partition (inThisTheme ptrls) ruls
+       (themeDcls,restDcls) = partition (inThisTheme relsInTheme) rels
+          where relsInTheme p = relsDefdIn p `uni` relsMentionedIn p
+       (themeCpts,restCpts) = partition (inThisTheme concs) cpts
+       inThisTheme :: Eq a => (Pattern -> [a]) -> a -> Bool
+       inThisTheme allElemsOf x
+         = case t of
+             Nothing -> True
+             Just pat -> x `elem` allElemsOf pat
+--GMI: What's the meaning of the Int? HJO: This has to do with the numbering of rules
 dpRule' :: FSpec -> [Rule] -> Int -> [A_Concept] -> [Declaration]
           -> ([(Inlines, [Blocks])], Int, [A_Concept], [Declaration])
 dpRule' fSpec = dpR
@@ -214,7 +322,7 @@    l lstr = text $ localize (fsLang fSpec) lstr
    dpR [] n seenConcs seenDeclarations = ([], n, seenConcs, seenDeclarations)
    dpR (r:rs) n seenConcs seenDeclarations
-     = ( ( str (name r)
+     = ( ( l (NL "Regel: ",EN "Rule: ") <> (text.latexEscShw.name) r
          , [theBlocks]
           ): dpNext
        , n'
@@ -308,19 +416,6 @@      )
    ]
 
-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 $
@@ -338,15 +433,13 @@                     _                                  -> []
 concatMarkup :: [A_Markup] -> Maybe A_Markup
 concatMarkup es
- = case eqCl f es of
+ = case eqCl amLang 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)
+                      intercalate "\n   " [(show.amLang.head) cl | cl<-cls])
 
 -- Insert an inline after the first inline in the list of blocks, if possible.
 insertAfterFirstInline :: [Inline] -> [Block] -> [Block]
@@ -361,8 +454,8 @@     Nothing -> True
     Just p  -> (not . explUserdefd) p
 
-lclForLang :: Lang -> TimeLocale
-lclForLang lang = defaultTimeLocale { months =
+lclForLang :: Lang -> SL.TimeLocale
+lclForLang lang = SL.defaultTimeLocale { SL.months =
          case lang of
            Dutch   -> [ ("januari","jan"),("februari","feb"),("maart","mrt"),("april","apr")
                       , ("mei","mei"),("juni","jun"),("juli","jul"),("augustus","aug")
− src/Database/Design/Ampersand/Prototype/Apps.hs 
@@ -1,6 +0,0 @@-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 
@@ -1,350 +0,0 @@-{-# 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 
@@ -1,63 +0,0 @@---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
@@ -4,76 +4,4 @@ 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
@@ -56,7 +56,7 @@                           case objmsub objDef of
                             Nothing -> []
                             Just (Box _ _ objs)    -> map (genEntity_ObjDef (dpth+1)) objs
-                            Just (InterfaceRef nm) -> map (genEntity_ObjDef (dpth+1)) $ objsForInterfaceNamed nm
+                            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 "*")
src/Database/Design/Ampersand/Prototype/GenFrontend.hs view
@@ -55,7 +55,10 @@ 
 -}
 
-data Include = Include { _fileOrDir :: FileOrDir, includeSrc :: String, _includeTgt :: String } deriving Show
+data Include = Include { fileOrDir :: FileOrDir
+                       , includeSrc :: String
+                       , includeTgt :: String
+                       } deriving Show
 
 data FileOrDir = File | Dir deriving Show
 
@@ -63,8 +66,10 @@ allowedIncludeSubDirs :: [Include]
 allowedIncludeSubDirs = [ Include Dir  "templates"         "templates"
                         , Include Dir  "views"             "app/views"
+                        , Include Dir  "controllers"       "app/controllers"
                         , Include Dir  "css"               "app/css"
                         , Include Dir  "js"                "app/js"
+                        , Include Dir  "lib"               "app/lib"
                         , Include Dir  "images"            "app/images"
                         , Include Dir  "extensions"        "extensions"
                         , Include File "localSettings.php" "localSettings.php"
@@ -108,54 +113,74 @@           protoDir = Opts.dirPrototype (getOpts fSpec)
     ; includeDirExists <- doesDirectoryExist $ includeDir
     ; if includeDirExists then
-       do { putStrLn $ "Copying user includes from " ++ includeDir 
+       do { verboseLn (getOpts fSpec) $ "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
+          ; let absIncludes = [ Include { fileOrDir = fileOrDir incl
+                                        , includeSrc = absSd
+                                        , includeTgt = protoDir </> includeTgt incl
+                                        }
+                              | incl <- allowedIncludeSubDirs
+                              , let absSd = includeDir </> includeSrc incl
                               , 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
-                      ]
+          ; sequence_ (fmap copyInclude absIncludes) -- recursively copy all includes
                       
           ; let ignoredPaths = includeDirContents \\ map includeSrc absIncludes
-          ; when (not $ null ignoredPaths) $
+          ; when (not . null . filter (\str -> head str /= '.') $ ignoredPaths) $  --filter paths starting with a dot, because on mac this is very common and it is a nuisance to avoid (see issue #
              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 ++ ")"
+        verboseLn (getOpts fSpec) $ "No user includes (there is no directory " ++ includeDir ++ ")"
     } 
-  where toFOrDStr File = "file"
-        toFOrDStr Dir  = "directory"
-        
+  where copyInclude :: Include -> IO()
+        copyInclude incl =
+          do { verboseLn (getOpts fSpec) $ 
+                          "  Copying " ++ (case fileOrDir incl of 
+                                             File -> "file"
+                                             Dir  -> "directory"
+                                          )++ " " ++ includeSrc incl ++ "\n    -> " ++ includeTgt incl
+             ; case fileOrDir incl of
+                 File -> copyDeepFile (includeSrc incl) (includeTgt incl)
+                 Dir  -> copyDirRecursively (includeSrc incl) (includeTgt incl)
+             }
 ------ Build intermediate data structure
 
 -- NOTE: _ disables 'not used' warning for fields
 data FEInterface = FEInterface { ifcName :: String
+                               , ifcLabel :: String
                                , _ifcMClass :: Maybe String 
                                , _ifcExp :: Expression, _ifcSource :: A_Concept, _ifcTarget :: A_Concept
-                               , _ifcRoles :: [Role], _ifcEditableRels :: [Declaration], _ifcObj :: FEObject }
+                               , _ifcRoles :: [Role], _ifcEditableRels :: [Declaration], _ifcObj :: FEObject
+                               } deriving (Typeable, Data)
 
 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
+                         , objExp :: Expression
+                         , objSource :: A_Concept
+                         , objTarget :: A_Concept
+                         , objIsEditable :: Bool
+                         , exprIsUni :: Bool
+                         , exprIsTot :: Bool
+                         , exprIsProp :: Bool
+                         , exprIsIdent :: Bool
+                         , objNavInterfaces :: [NavInterface]
+                         , atomicOrBox :: FEAtomicOrBox
+                         } deriving (Show, Data, Typeable )
 
 -- 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 FEAtomicOrBox = FEAtomic { objMPrimTemplate :: Maybe ( FilePath -- the absolute path to the template
+                                                          , [String] -- the attributes of the template
+                                                          ) }
+                   | FEBox    { objMClass :: Maybe String
+                              , ifcSubObjs :: [FEObject] 
+                              } deriving (Show, Data,Typeable)
 
-data NavInterface = NavInterface { _navIfcName :: String, _navIfcRoles :: [Role] } deriving Show
+data NavInterface = NavInterface { navIfcName :: String
+                                 , navIfcRoles :: [Role]
+                                 } deriving (Show, Data, Typeable)
 
 flatten :: FEObject -> [FEObject]
 flatten obj = obj : concatMap flatten subObjs
@@ -173,8 +198,17 @@ 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
+    ; return 
+        FEInterface { ifcName = escapeIdentifier $ name ifc
+                    , ifcLabel = name ifc
+                    , _ifcMClass = ifcClass ifc
+                    , _ifcExp = objExp obj
+                    , _ifcSource = objSource obj
+                    , _ifcTarget = objTarget obj
+                    , _ifcRoles = ifcRoles ifc
+                    , _ifcEditableRels = editableRels
+                    , _ifcObj = 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)
     } 
@@ -193,25 +227,36 @@                   ; mSpecificTemplatePath <-
                           case mView of
                             Just Vd{vdhtml=Just (ViewHtmlTemplateFile fName), vdats=viewSegs}
-                              -> return $ Just ("views" </> fName, [ viewAttr | ViewExp Obj{objnm=viewAttr} <- 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"
+                             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)
+                  ; return (FEAtomic { objMPrimTemplate = 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)
+                  ; return (FEBox { objMClass  = mCl
+                                  , ifcSubObjs = subObjs
+                                  }
+                           , iExp, isEditable, src, tgt)
                   }
-              Just (InterfaceRef nm)   -> 
+              Just (InterfaceRef isLink 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
+                  [i]     -> 
+                        if isLink
+                        then do { let (isEditable, src, tgt) = getIsEditableSrcTgt iExp
+                                ; let templatePath = "views" </> "LINKTO.html"
+                                ; return (FEAtomic { objMPrimTemplate = Just (templatePath, [])}
+                                         , iExp, isEditable, src, tgt)
+                                }
+                        else 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)
@@ -219,13 +264,25 @@                                 ; 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 
+        ; let navIfcs = [ NavInterface { navIfcName  = name nIfc
+                                       , navIfcRoles = ifcRoles nIfc `intersect` ifcRoles ifc -- 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
+        ; return $ FEObject{ objName = name object
+                           , objExp = iExp'
+                           , objSource = src
+                           , objTarget = tgt
+                           , objIsEditable = isEditable
+                           , exprIsUni = isUni iExp'
+                           , exprIsTot = isTot iExp'
+                           , exprIsProp = isProp iExp'
+                           , exprIsIdent = isIdent iExp'
+                           , objNavInterfaces = navIfcs
+                           , atomicOrBox = aOrB
+                           }
         }
       where getIsEditableSrcTgt expr = 
               case getExpressionRelation expr of
@@ -241,12 +298,13 @@     ; template <- readTemplate fSpec "RouteProvider.js"
     ; let contents = renderTemplate template $
                        setAttribute "contextName"         (fsName fSpec)
-                     . setAttribute "interfaceNames"      (map (escapeIdentifier . ifcName) ifcs)
                      . setAttribute "ampersandVersionStr" ampersandVersionStr
+                     . setAttribute "ifcs"                ifcs
+                     . setAttribute "verbose"             (verboseP (getOpts fSpec))
 
     ; writePrototypeFile fSpec ("app/RouteProvider.js") $ contents 
     }
-    
+
     
 ------ Generate view html code
 
@@ -256,46 +314,48 @@     }
 
 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
+genView_Interface fSpec interf =
+ do { lns <- genView_Object fSpec 0 (_ifcObj interf)
     ; 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 "isTopLevel"          ((name . source . _ifcExp $ interf) `elem` ["ONE", "SESSION"])
+                     . setAttribute "roles"               (map show . _ifcRoles $ interf) -- show string, since StringTemplate does not elegantly allow to quote and separate
+                     . setAttribute "editableRelations"   (map (show . escapeIdentifier . name) . _ifcEditableRels $ interf) -- 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 "interfaceName"       (ifcName  interf)
+                     . setAttribute "interfaceLabel"      (ifcLabel interf) -- no escaping for labels in templates needed
+                     . setAttribute "expAdl"              (showADL . _ifcExp $ interf)
+                     . setAttribute "source"              (escapeIdentifier . name . _ifcSource $ interf)
+                     . setAttribute "target"              (escapeIdentifier . name . _ifcTarget $ interf)
                      . setAttribute "contents"            (intercalate "\n" . indent 4 $ lns) -- intercalate, because unlines introduces a trailing \n
+                     . setAttribute "verbose"             (verboseP (getOpts fSpec))
 
-    ; let filename = escapeIdentifier iName ++ ".html" -- filenames with spaces aren't a huge problem, but it's probably safer to prevent them
+    ; let filename = ifcName interf ++ ".html" 
     ; 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)
+data SubObjectAttr = SubObjAttr { subObjName :: String
+                                , subObjLabel :: String
+                                , subObjContents :: String 
+                                , subObjExprIsUni :: Bool
+                                } 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 _) =
+genView_Object fSpec depth obj =
   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)
-                    
+      atomicAndBoxAttrs = setAttribute "isEditable" (objIsEditable obj)
+                        . setAttribute "exprIsUni"  (exprIsUni obj)
+                        . setAttribute "exprIsTot"  (exprIsTot obj)
+                        . setAttribute "name"       (escapeIdentifier . objName $ obj)
+                        . setAttribute "label"      (objName $ obj) -- no escaping for labels in templates needed
+                        . setAttribute "expAdl"     (showADL . objExp $ obj) 
+                        . setAttribute "source"     (escapeIdentifier . name . objSource $ obj)
+                        . setAttribute "target"     (escapeIdentifier . name . objTarget $ obj)
+                        . setAttribute "verbose"    (verboseP (getOpts fSpec))
   in  case atomicOrBox obj of
-        FEAtomic mPrimTemplate ->
+        FEAtomic{} ->
          do { {-
               verboseLn (getOpts fSpec) $ replicate depth ' ' ++ "ATOMIC "++show nm ++ 
                                             " [" ++ name src ++ "*"++ name tgt ++ "], " ++
@@ -304,21 +364,21 @@             -- 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
+            ; conceptTemplate <- getTemplateForObject
+            ; let (templateFilename, _) = fromMaybe (conceptTemplate, []) (objMPrimTemplate . atomicOrBox $ obj) -- 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
+            ; let mNavInterface = listToMaybe (objNavInterfaces obj) -- TODO: can also be deleted, not used anymore?
                                                                                   
             ; return $ lines $ renderTemplate template $ 
                                  atomicAndBoxAttrs
-                               . setManyAttrib [(viewAttr, "{{row['@view']['"++viewAttr++"']}}") | viewAttr <- viewAttrs ] -- TODO: escape/protect
-                               . setAttribute "navInterface" (fmap escapeIdentifier mNavInterface)
+                               -- . setManyAttrib [(viewAttr, "{{row['@view']['"++viewAttr++"']}}") | viewAttr <- viewAttrs ] -- TODO: delete this, not used anymore
+                               . setAttribute "navInterface" (fmap (escapeIdentifier . navIfcName) mNavInterface) -- TODO: can also be deleted, not used anymore?
             }
-        FEBox mClass subObjs ->
+        FEBox { objMClass  = mClass
+              , ifcSubObjs = subObjs} ->
          do { {-
               verboseLn (getOpts fSpec) $ replicate depth ' ' ++ "BOX" ++ maybe "" (\c -> "<"++c++">") mClass ++
                                             " " ++ show nm ++ " [" ++ name src ++ "*"++ name tgt ++ "], " ++
@@ -338,14 +398,26 @@          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
+                               , subObjExprIsUni = exprIsUni subObj
                                -- Indentation is not context sensitive, so some templates will
                                -- be indented a bit too much (we take the maximum necessary value now)
                                } 
             }
-
-            
+        getTemplateForObject :: IO(FilePath)
+        getTemplateForObject 
+           | exprIsProp obj && (not . exprIsIdent) obj  -- special 'checkbox-like' template for propery relations
+                       = return $  templatePath </> "Relation-PROP"++".html"
+           | otherwise = getTemplateForConcept (objTarget obj)
+        getTemplateForConcept :: A_Concept -> IO(FilePath)
+        getTemplateForConcept cpt = do exists <- doesTemplateExist fSpec cptfn
+                                   --    verboseLn (getOpts fSpec) $ "Looking for: " ++cptfn ++ "("++(if exists then "" else " not")++ " found.)" 
+                                       return $ if exists
+                                                then cptfn
+                                                else templatePath </> "Atomic-"++show ttp++".html" 
+           where ttp = cptTType fSpec $ cpt
+                 cptfn = templatePath </> "Concept-"++name cpt++".html" 
+        templatePath = "views"     
 ------ Generate controller JavaScript code
 
 genController_Interfaces :: FSpec -> [FEInterface] -> IO ()
@@ -354,41 +426,45 @@     }
 
 genController_Interface :: FSpec -> FEInterface -> IO ()
-genController_Interface fSpec (FEInterface iName _ iExp iSrc iTgt roles editableRels obj) =
+genController_Interface fSpec interf =
  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
-                                        ]
+    ; let allObjs = flatten (_ifcObj interf)
+          allEditableObjects = nub . map objTarget $  
+                                         ( filter (targetIsObject ) 
+                                         . filter (isAtomic . atomicOrBox)
+                                         . filter objIsEditable $ allObjs)
+          targetIsObject o = (cptTType fSpec . objTarget) o == Object
+          isAtomic FEAtomic{} = True
+          isAtomic _ = False                              
           containsEditable          = any objIsEditable allObjs
-          containsEditableNonPrim   = not $ null allEditableNonPrimTargets
-          containsDATE              = any (\o -> name (objTarget o) == "DATE" && objIsEditable o) allObjs
+          containsEditableObjects    = (not . null) allEditableObjects
+          containsDATE              = any (\o -> (cptTType fSpec) (objTarget o) == Date && objIsEditable o) allObjs
           
-    ; template <- readTemplate fSpec "controllers/controller.js"
+    ; let controlerTemplateName = "controllers/controller.js"
+    ; template <- readTemplate fSpec controlerTemplateName
     ; 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 "isRoot"                   ((name . source . _ifcExp $ interf) `elem` ["ONE", "SESSION"])
+                     . setAttribute "roles"                    (map show . _ifcRoles $ interf) -- show string, since StringTemplate does not elegantly allow to quote and separate
+                     . setAttribute "editableRelations"        (map (show . escapeIdentifier . name) . _ifcEditableRels $ interf) -- show name, since StringTemplate does not elegantly allow to quote and separate
+                     . setAttribute "editableObjects"          (map (escapeIdentifier . name) allEditableObjects)
                      . setAttribute "containsDATE"             containsDATE
                      . setAttribute "containsEditable"         containsEditable
-                     . setAttribute "containsEditableNonPrim"  containsEditableNonPrim
+                     . setAttribute "containsEditableObjects"  containsEditableObjects
                      . 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"
+                     . setAttribute "interfaceName"            (ifcName interf)
+                     . setAttribute "interfaceLabel"           (ifcLabel interf) -- no escaping for labels in templates needed
+                     . setAttribute "expAdl"                   (showADL . _ifcExp $ interf)
+                     . setAttribute "source"                   (escapeIdentifier . name . _ifcSource $ interf)
+                     . setAttribute "target"                   (escapeIdentifier . name . _ifcTarget $ interf)
+                     . setAttribute "verbose"                  (verboseP (getOpts fSpec))
+                     . setAttribute "usedTemplate"             controlerTemplateName
+    ; let filename = ifcName interf ++ ".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
 
@@ -398,7 +474,7 @@  do { let absPath = getTemplateDir fSpec </> templatePath
     ; doesFileExist absPath
     }
- 
+
 readTemplate :: FSpec -> String -> IO Template
 readTemplate fSpec templatePath =
  do { let absPath = getTemplateDir fSpec </> templatePath
@@ -416,6 +492,6 @@              ([],  [],    []) -> render appliedTemplate
              (parseErrs@(_:_), _, _)        -> templateError $ concat [ "Parse error in " ++ tmplt ++ " " ++ err ++ "\n" 
                                                                       | (tmplt,err) <- parseErrs]
-             ([], attrs@(_:_), _)        -> templateError $ "Uninitialized template attributes: " ++ show attrs
+             ([], attrs@(_:_), _)        -> templateError $ "The following attributes are expected by the template, but not supplied: " ++ 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
@@ -1,7 +1,7 @@ module Database.Design.Ampersand.Prototype.Generate (generateGenerics, generateCustomCss) where
 
 import Database.Design.Ampersand
-import Database.Design.Ampersand.Core.AbstractSyntaxTree
+import Database.Design.Ampersand.Core.AbstractSyntaxTree 
 import Prelude hiding (writeFile,readFile,getContents,exp)
 import Data.Function
 import Data.List
@@ -11,7 +11,6 @@ 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)
@@ -116,12 +115,12 @@       [ [ "CREATE TABLE "++ show "__SessionTimeout__"
         , "   ( "++show "SESSION"++" VARCHAR(255) UNIQUE NOT NULL"
         , "   , "++show "lastAccess"++" BIGINT NOT NULL"
-        , "   ) ENGINE=InnoDB DEFAULT CHARACTER SET UTF8"
+        , "   ) ENGINE=InnoDB DEFAULT CHARACTER SET UTF8 COLLATE UTF8_BIN"
         ]
       , [ "CREATE TABLE "++ show "__History__"
         , "   ( "++show "Seconds"++" VARCHAR(255) DEFAULT NULL"
         , "   , "++show "Date"++" VARCHAR(255) DEFAULT NULL"
-        , "   ) ENGINE=InnoDB DEFAULT CHARACTER SET UTF8"
+        , "   ) ENGINE=InnoDB DEFAULT CHARACTER SET UTF8 COLLATE UTF8_BIN"
         ]
       , [ "INSERT INTO "++show "__History__"++" ("++show "Seconds"++","++show "Date"++")"
         , "   VALUES (UNIX_TIMESTAMP(NOW(6)), NOW(6))"
@@ -130,7 +129,7 @@         , "   ( "++show "conjId"++" VARCHAR(255) NOT NULL"
         , "   , "++show "src"++" VARCHAR(255) NOT NULL"
         , "   , "++show "tgt"++" VARCHAR(255) NOT NULL"
-        , "   ) ENGINE=InnoDB DEFAULT CHARACTER SET UTF8"
+        , "   ) ENGINE=InnoDB DEFAULT CHARACTER SET UTF8 COLLATE UTF8_BIN"
         ]
       ] ++ 
       ( concatMap tableSpec2Queries [(plug2TableSpec p) | InternalPlug p <- plugInfos fSpec])
@@ -149,7 +148,9 @@                                  )
                             )
                         )
-                     ++ [" )"]
+                     ++ [" , "++show "ts_insert"++" TIMESTAMP DEFAULT CURRENT_TIMESTAMP"]
+                     ++ [" , "++show "ts_update"++" TIMESTAMP ON UPDATE CURRENT_TIMESTAMP NULL"]
+                     ++ [" ) ENGINE=InnoDB DEFAULT CHARACTER SET UTF8 COLLATE UTF8_BIN"]
                    )
           ]
         fld2sql :: SqlField -> String
@@ -159,7 +160,7 @@   = TableSpec { tsCmnt :: [String]
               , tsName :: String
               , tsflds :: [SqlField]
-              , tsKey  :: [String]
+              , tsKey ::  [String]
               , tsEngn :: String
               }
 data FieldSpecNew
@@ -194,7 +195,7 @@                                         ]
                          ForeignKey c  -> fatal 195 ("ForeignKey "++name c++"not expected here!")
                          PlainAttr     -> []
-     , tsEngn = "InnoDB DEFAULT CHARACTER SET UTF8"
+     , tsEngn = "InnoDB DEFAULT CHARACTER SET UTF8 COLLATE UTF8_BIN"
      }
 
 commentBlockSQL :: [String] -> [String]
@@ -215,7 +216,7 @@         populateTablesWithPops
         
 
-    fillSignalTable :: [(Conjunct, [Paire])] -> [String]
+    fillSignalTable :: [(Conjunct, [AAtomPair])] -> [String]
     fillSignalTable [] = []
     fillSignalTable conjSignals 
      = [intercalate "\n           " $ 
@@ -223,7 +224,7 @@             , "   ("++intercalate ", " (map show ["conjId","src","tgt"])++")"
             ] ++ lines 
               ( "VALUES " ++ intercalate "\n     , " 
-                  [ "(" ++intercalate ", " (map showAsValue [rc_id conj, srcPaire p, trgPaire p])++ ")" 
+                  [ "(" ++intercalate ", " (map showAsValue [rc_id conj, showValPHP (apLeft p), showValPHP (apRight p)])++ ")" 
                   | (conj, viols) <- conjSignals
                   , p <- viols
                   ]
@@ -235,7 +236,7 @@       where
         populatePlug :: PlugSQL -> [String]
         populatePlug plug 
-          = case tblcontents (vgens fSpec) (initialPops fSpec) plug of
+          = case tableContents fSpec plug of
              []  -> []
              tblRecords 
                  -> [intercalate "\n           " $ 
@@ -251,10 +252,9 @@              = intercalate ", " 
                  [case fld of 
                     Nothing -> "NULL"
-                    Just str -> showAsValue str
+                    Just val -> showValPHP val
                  | fld <- record ]
 
-
 generateSpecializations :: FSpec -> [String]
 generateSpecializations fSpec =
   [ "$allSpecializations = // transitive, so including specializations of specializations"
@@ -308,15 +308,21 @@                   -- 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
                   ])) ++
+              [ ", 'type' => '"++(show . cptTType fSpec) c++"'" ]++
+              [ ", 'specializations' => array ("++intercalate ", " (map (showPhpStr . name)(smallerConcepts (vgens fSpec) c))++")"]++
+              [ ", 'defaultViewId'   => "++(showPhpStr . vdlbl $ dfltV)
+              | Just dfltV <- [getDefaultViewForConcept fSpec c]
+              ]++
               [ ")" ]
            )
          | c <- concs fSpec
-         , let affConjs = case lookup c $ allConjsPerConcept fSpec of
-                 Nothing    -> []
-                 Just conjs -> conjs
+         , let 
+               affConjs = nub [ conj  
+                              | Just conjs<-[lookup c (allConjsPerConcept fSpec)]
+                              , conj<-conjs
+                              ]
                affInvConjs = filterFrontEndInvConjuncts affConjs
-               affSigConjs = filterFrontEndSigConjuncts affConjs 
-
+               affSigConjs = filterFrontEndSigConjuncts affConjs
          ]
     ) ++
   [ ""
@@ -383,10 +389,10 @@          , let rExpr=rrexp rule
          ]
     ) )
- where showMeaning rule = maybe "" aMarkup2String (meaning (fsLang fSpec) rule)
+ where showMeaning rule = maybe "" (aMarkup2String ReST) (meaning (fsLang fSpec) rule)
        showMessage rule = case [ markup | markup <- rrmsg rule, amLang markup == fsLang fSpec ] of
                             []    -> ""
-                            markup:_ -> aMarkup2String markup
+                            markup:_ -> aMarkup2String ReST markup
 
        genMPairView Nothing                  = []
        genMPairView (Just (PairView pvsegs)) = map genPairViewSeg pvsegs
@@ -455,18 +461,28 @@   
 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'
+  concatMap showRoles [False,True]
+  where showRoles isService =
+          [ if isService then "$allServices =" else "$allRoles ="
+          , "  array"
+          ] ++
+          addToLastLine ";"
+            (indent 4
+              (blockParenthesize  "(" ")" ","
+                 [ [ "array ( 'id' => "++show i 
+                   , "      , 'name' => "++showPhpStr (name role)
+                   , "      , 'ruleNames'  => array ("++ intercalate ", " ((map (showPhpStr . name . snd) . filter (maintainedByRole role) . fRoleRuls) fSpec) ++")"
+                   , "      , 'interfaces' => array ("++ intercalate ", " ((map (showPhpStr . name) . filter (forThisRole role) . interfaceS) fSpec) ++")"
+                   , "      )" ]
+                 | (i,role) <- zip [1::Int ..] (filter serviceOrRole $ fRoles fSpec) ]
+            ) )
+            where
+             serviceOrRole Role{} = not isService
+             serviceOrRole Service{} = isService 
+        maintainedByRole role (role',_) = role == role'
+        forThisRole role interf = case ifcRoles interf of
+                                     []   -> True -- interface is for all roles
+                                     rs  -> role `elem` rs
 
 generateViews :: FSpec -> [String]
 generateViews fSpec =
@@ -488,15 +504,22 @@          | 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'"
+ where genViewSeg (ViewText i str) = [ "array ( 'segmentType' => 'Text'"
+                                     , "      , 'label' => " ++ lab i
+                                     , "      , 'Text' => " ++ showPhpStr str
+                                     , "      )" ]
+       genViewSeg (ViewHtml i str) = [ "array ( 'segmentType' => 'Html'"
+                                     , "      , 'label' => " ++ lab i
+                                     , "      , '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)
+       lab i = showPhpStr ("seg_"++show i)
 
 generateInterfaces :: FSpec -> [String]
 generateInterfaces fSpec =
@@ -563,6 +586,7 @@      , "      , '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) 
+     , "      , 'exprIsIdent'   => " ++ showPhpBool (isIdent normalizedInterfaceExp) 
      , "      , 'expressionSQL' => " ++ showPhpStr (prettySQLQuery fSpec (22+14*depth) normalizedInterfaceExp)
      ] 
   ++ generateMSubInterface fSpec editableRels depth (objmsub object)
@@ -583,18 +607,21 @@ 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))
+    Nothing -> [ "      // No subinterfaces" ]
+    Just (InterfaceRef isLink nm)
+            -> [ "      // InterfaceRef"
+         --      , "      , 'refSubInterface' => " ++ showPhpStr nm
+               , "      , 'refSubInterfaceId' => " ++ showPhpStr (escapeIdentifier nm) -- only for new front-end
+               , "      , 'isLinkTo' => "++ show isLink
+               ]
+    Just (Box _ cl objects)
+            -> [ "      // Box" ++ (maybe "" (\c -> "<"++c++">") cl)
+               , "      , 'boxSubInterfaces' =>"
+               , "          array"
+               ] ++
+               indent 12
+                 (blockParenthesize "(" ")" ","
+                   (map (genInterfaceObjects fSpec editableRels Nothing (depth + 1)) objects))
 
 -- utils
src/Database/Design/Ampersand/Prototype/Installer.hs view
@@ -30,7 +30,7 @@       , "// Don't bother about the error if the database didn't exist..."
       , ""
       , "// Create the database"
-      , "$sql=\"CREATE DATABASE $DB_name DEFAULT CHARACTER SET UTF8\";"
+      , "$sql=\"CREATE DATABASE $DB_name DEFAULT CHARACTER SET UTF8 DEFAULT COLLATE UTF8_BIN\";"
       , "if (!mysqli_query($DB_link,$sql)) {"
       , "  die(\"Error creating the database: \" . mysqli_error($DB_link));"
       , "  }"
src/Database/Design/Ampersand/Prototype/ObjBinGen.hs view
@@ -1,9 +1,8 @@ {-# LANGUAGE CPP #-}
-module Database.Design.Ampersand.Prototype.ObjBinGen (generatePhp, doGenAtlas, writeStaticFiles) where
+module Database.Design.Ampersand.Prototype.ObjBinGen (generatePhp, 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
@@ -47,22 +46,15 @@        [ "?>"
        ]
 
-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
+                 | sf <- filter isRequired allStaticFiles
                  ]
   else verboseLn opts "Skipping static files (because of command line argument)"
-
+ where isRequired :: StaticFile -> Bool
+       isRequired sf = fileKind sf == ZwolleFrontEnd
 writeStaticFile :: Options -> StaticFile -> IO()
 writeStaticFile opts sf =
   do { createDirectoryIfMissing True (takeDirectory (absFilePath opts sf))
src/Database/Design/Ampersand/Prototype/PHP.hs view
@@ -1,7 +1,7 @@ module Database.Design.Ampersand.Prototype.PHP 
          ( executePHPStr, executePHP, showPHP, sqlServerConnectPHP, createTempDbPHP, setSqlModePHP
          , evaluateExpSQL, performQuery
-         , createTablesPHP, populateTablesPHP, populateTablesWithPopsPHP, plug2TableSpec
+         , createTablesPHP, populateTablesPHP, populateTablesWithInitialPopsPHP, plug2TableSpec
          , dropplug, historyTableSpec, sessionTableSpec, signalTableSpec, TableSpec, getTableName) where
 
 import Prelude hiding (exp)
@@ -83,7 +83,7 @@                                         ]
                    ForeignKey c  -> fatal 195 ("ForeignKey "++name c++"not expected here!")
                    PlainAttr     -> []
-   , "InnoDB DEFAULT CHARACTER SET UTF8")
+   , "InnoDB DEFAULT CHARACTER SET UTF8 DEFAULT COLLATE UTF8_BIN")
 
 signalTableSpec :: TableSpec
 signalTableSpec =
@@ -92,7 +92,7 @@   , [ "`conjId` VARCHAR(255) NOT NULL"
     , "`src` VARCHAR(255) NOT NULL"
     , "`tgt` VARCHAR(255) NOT NULL" ]
-  , "InnoDB DEFAULT CHARACTER SET UTF8"
+  , "InnoDB DEFAULT CHARACTER SET UTF8 DEFAULT COLLATE UTF8_BIN"
   )
 
 sessionTableSpec :: TableSpec
@@ -101,7 +101,7 @@    , "__SessionTimeout__"
    , [ "`SESSION` VARCHAR(255) UNIQUE NOT NULL"
      , "`lastAccess` BIGINT NOT NULL" ]
-   , "InnoDB DEFAULT CHARACTER SET UTF8" )
+   , "InnoDB DEFAULT CHARACTER SET UTF8 DEFAULT COLLATE UTF8_BIN" )
 
 historyTableSpec :: TableSpec
 historyTableSpec
@@ -109,12 +109,12 @@    , "__History__"
    , [ "`Seconds` VARCHAR(255) DEFAULT NULL"
      , "`Date` VARCHAR(255) DEFAULT NULL" ]
-   , "InnoDB DEFAULT CHARACTER SET UTF8" )
+   , "InnoDB DEFAULT CHARACTER SET UTF8 DEFAULT COLLATE UTF8_BIN" )
 
 populateTablesPHP :: FSpec -> [String]
 populateTablesPHP fSpec =
   fillSignalTable (initialConjunctSignals fSpec) ++
-  populateTablesWithPopsPHP fSpec (initialPops fSpec)
+  populateTablesWithInitialPopsPHP fSpec
   where
     fillSignalTable []          = []
     fillSignalTable conjSignals =
@@ -122,7 +122,7 @@                                                                     ++" (`conjId`, `src`, `tgt`)"
                                               ++phpIndent 24++"VALUES " ++ 
                                               intercalate (phpIndent 29++", ") 
-                                                [ "(" ++sqlConjId++", "++sqlAtomQuote (srcPaire p)++", "++sqlAtomQuote (trgPaire p)++")" 
+                                                [ "(" ++sqlConjId++", "++showValPHP (apLeft p)++", "++showValPHP (apRight p)++")" 
                                                 | (conj, viols) <- conjSignals
                                                 , let sqlConjId = "'" ++ rc_id conj ++ "'" -- conjunct id's do not need escaping
                                                 , p <- viols
@@ -131,12 +131,12 @@       , "if($err=mysqli_error($DB_link)) { $error=true; echo $err.'<br />'; }"
       ]
 
-populateTablesWithPopsPHP :: FSpec -> [Population] -> [String]
-populateTablesWithPopsPHP fSpec pops =
+populateTablesWithInitialPopsPHP :: FSpec -> [String]
+populateTablesWithInitialPopsPHP fSpec =
   concatMap populatePlugPHP [p | InternalPlug p <- plugInfos fSpec]
   where
     populatePlugPHP plug
-         = case tblcontents (vgens fSpec) pops plug of
+         = case tableContents fSpec plug of
                [] -> []
                tblRecords -> ( "mysqli_query($DB_link, "++showPhpStr ("INSERT INTO "++quote (name plug)
                                                            ++" ("++intercalate "," [quote (fldname f) |f<-plugFields plug]++")"
@@ -146,7 +146,7 @@                              ):
                              ["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]
+        valuechain record = intercalate ", " [case fld of Nothing -> "NULL" ; Just val -> showValPHP val | fld<-record]
 
 
 dropplug :: PlugSQL -> String
@@ -177,7 +177,7 @@       , "// Don't bother about the error if the database didn't exist..."
       , ""
       , "// Create the database"
-      , "$sql=\"CREATE DATABASE $DB_name DEFAULT CHARACTER SET UTF8\";"
+      , "$sql=\"CREATE DATABASE $DB_name DEFAULT CHARACTER SET UTF8 COLLATE utf8_bin\";"
       , "if (!mysqli_query($DB_link,$sql)) {"
       , "  die(\"Error creating the database: \" . mysqli_error($DB_link));"
       , "  }"
@@ -306,3 +306,4 @@        , "  }"
        , ""
        ]
+
src/Database/Design/Ampersand/Prototype/ProtoUtil.hs view
@@ -5,8 +5,8 @@          , escapeIdentifier,commentBlock,strReplace
          , addSlashes
          , indentBlock,addToLast
-         , indentBlockBetween,quote,sqlAtomQuote
-         , phpIndent,showPhpStr,escapePhpStr,showPhpBool
+         , indentBlockBetween,quote
+         , showValPHP,phpIndent,showPhpStr,escapePhpStr,showPhpBool
          ) where
  
 import Prelude hiding (putStrLn, readFile, writeFile)
@@ -89,12 +89,6 @@ --          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 '*'++"*\\"]
− src/Database/Design/Ampersand/Prototype/StaticFiles_Generated.hs

file too large to diff

src/Database/Design/Ampersand/Prototype/ValidateEdit.hs view
@@ -4,7 +4,8 @@ import Data.List
 import Data.Maybe
 import System.FilePath hiding (isValid)
-import Database.Design.Ampersand
+import Database.Design.Ampersand.Core.AbstractSyntaxTree
+import Database.Design.Ampersand.FSpec
 import Database.Design.Ampersand.Basics
 import Database.Design.Ampersand.Prototype.PHP
 import Database.Design.Ampersand.FSpec.SQL
@@ -33,8 +34,8 @@             ; 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 expectedConceptTables  = [ (c,map showValSQL atoms) | ACptPopu c atoms <- afterPops ]
+            ; let expectedRelationTables = [ (d,map showValsSQL pairs) | ARelPopu{popdcl=d,popps=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
@@ -78,13 +79,18 @@             ; return  isValid
             }
     }
-
+  where showValsSQL p = ((showValSQL.apLeft) p, (showValSQL.apRight) p)
 createTempDatabase :: FSpec -> [Population] -> IO ()
 createTempDatabase fSpec pops =
  do { _ <- executePHPStr . showPHP $ sqlServerConnectPHP fSpec ++
                                      createTempDbPHP tempDbName ++
                                      createTablesPHP fSpec ++
-                                     populateTablesWithPopsPHP fSpec pops
+--                                     [ "TODO: "
+--                                     , "*** Beware: This script has bitrotted! ***"
+--                                     , "To get it on her feet again, bsure not to forget"
+--                                     , "to initialize the signal table too. "
+--                                     ] ++
+                                     populateTablesWithInitialPopsPHP fSpec
     ; return ()
     }
 
@@ -101,13 +107,13 @@     ; return (c, map fst atomsDummies)
     }
 
-getSqlRelationTable :: FSpec -> Declaration -> IO (Declaration, [Paire])
+getSqlRelationTable :: FSpec -> Declaration -> IO (Declaration, [(String,String)])
 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])
+    ; return (d, pairs)
     }
 -- TODO: are we going to use this data type?
src/Database/Design/Ampersand/Prototype/ValidateSQL.hs view
@@ -6,6 +6,7 @@ import System.Exit
 import System.IO hiding (hPutStr,hGetContents)
 import Database.Design.Ampersand hiding (putStr, origin)
+import Database.Design.Ampersand.Core.AbstractSyntaxTree
 import Database.Design.Ampersand.Prototype.Installer
 import Database.Design.Ampersand.Prototype.PHP
 
@@ -82,13 +83,13 @@ getAllViewExps :: FSpec -> [ValidationExp]
 getAllViewExps fSpec = concatMap getViewExps $ vviews fSpec
  where getViewExps view = [ (objctx objDef, "view "++show (name view))
-                          | ViewExp objDef <- vdats 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
+showVExp (exp, orig) = "Origin: "++orig++", expression: "++showADL exp
 
 -- validate a single expression and report the results
 validateExp :: FSpec -> ValidationExp -> IO (ValidationExp, Bool)
@@ -96,10 +97,10 @@  do { putStr "."
     ; return (vExp, True)
     }
-validateExp fSpec vExp@(exp, origin) =
- do { --putStr $ "Checking "++origin ++": expression = "++showADL exp
+validateExp fSpec vExp@(exp, orig) =
+ do { --putStr $ "Checking "++orig ++": expression = "++showADL exp
     ; violationsSQL <- fmap sort . evaluateExpSQL fSpec tempDbName $ exp
-    ; let violationsAmp = sort [(srcPaire p, trgPaire p) | p <- fullContents (vgens fSpec) (initialPops fSpec) exp]
+    ; let violationsAmp = sort [(showValSQL (apLeft p), showValSQL (apRight p)) | p <- pairsInExpr fSpec exp]
 
     ; if violationsSQL == violationsAmp
       then
@@ -107,7 +108,7 @@           ; return (vExp, True)
           }
       else
-       do { putStr $ "Checking "++origin ++": expression = "++showADL exp
+       do { putStr $ "Checking "++orig ++": expression = "++showADL exp
           ; putStrLn "\nMismatch between SQL and Ampersand"
           ; putStrLn $ showVExp vExp
           ; putStrLn $ "SQL violations:\n"++show violationsSQL
+ src/Database/Design/Ampersand/Test/Parser/ArbitraryPandoc.hs view
@@ -0,0 +1,193 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}
+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, ScopedTypeVariables #-}
+-- provides Arbitrary instance for Pandoc types
+-- from https://github.com/jgm/pandoc/blob/master/tests/Tests/Arbitrary.hs
+module Tests.Arbitrary ()
+where
+import Test.QuickCheck.Gen
+import Test.QuickCheck.Arbitrary
+import Control.Monad (liftM, liftM2)
+import Text.Pandoc.Definition
+import Text.Pandoc.Shared (normalize, escapeURI)
+import Text.Pandoc.Builder
+
+realString :: Gen String
+realString = resize 8 $ listOf $ frequency [ (9, elements [' '..'\127'])
+                                           , (1, elements ['\128'..'\9999']) ]
+
+arbAttr :: Gen Attr
+arbAttr = do
+  id' <- elements ["","loc"]
+  classes <- elements [[],["haskell"],["c","numberLines"]]
+  keyvals <- elements [[],[("start","22")],[("a","11"),("b_2","a b c")]]
+  return (id',classes,keyvals)
+
+instance Arbitrary Inlines where
+  arbitrary = liftM (fromList :: [Inline] -> Inlines) arbitrary
+
+instance Arbitrary Blocks where
+  arbitrary = liftM (fromList :: [Block] -> Blocks) arbitrary
+
+instance Arbitrary Inline where
+  arbitrary = resize 3 $ arbInline 2
+
+arbInlines :: Int -> Gen [Inline]
+arbInlines n = listOf1 (arbInline n) `suchThat` (not . startsWithSpace)
+  where startsWithSpace (Space:_) = True
+        startsWithSpace        _  = False
+
+-- restrict to 3 levels of nesting max; otherwise we get
+-- bogged down in indefinitely large structures
+arbInline :: Int -> Gen Inline
+arbInline n = frequency $ [ (60, liftM Str realString)
+                          , (60, return Space)
+                          , (10, liftM2 Code arbAttr realString)
+                          , (5,  elements [ RawInline (Format "html") "<a id=\"eek\">"
+                                          , RawInline (Format "latex") "\\my{command}" ])
+                          ] ++ [ x | x <- nesters, n > 1]
+   where nesters = [ (10,  liftM Emph $ arbInlines (n-1))
+                   , (10,  liftM Strong $ arbInlines (n-1))
+                   , (10,  liftM Strikeout $ arbInlines (n-1))
+                   , (10,  liftM Superscript $ arbInlines (n-1))
+                   , (10,  liftM Subscript $ arbInlines (n-1))
+                   , (10,  liftM SmallCaps $ arbInlines (n-1))
+                   , (10,  do x1 <- arbitrary
+                              x2 <- arbInlines (n-1)
+                              return $ Quoted x1 x2)
+                   , (10,  do x1 <- arbitrary
+                              x2 <- realString
+                              return $ Math x1 x2)
+                   , (10,  do x1 <- arbInlines (n-1)
+                              x3 <- realString
+                              x2 <- liftM escapeURI realString
+                              return $ Link x1 (x2,x3))
+                   , (10,  do x1 <- arbInlines (n-1)
+                              x3 <- realString
+                              x2 <- liftM escapeURI realString
+                              return $ Image x1 (x2,x3))
+                   , (2,  liftM2 Cite arbitrary (arbInlines 1))
+                   , (2,  liftM Note $ resize 3 $ listOf1 $ arbBlock (n-1))
+                   ]
+
+instance Arbitrary Block where
+  arbitrary = resize 3 $ arbBlock 2
+
+arbBlock :: Int -> Gen Block
+arbBlock n = frequency $ [ (10, liftM Plain $ arbInlines (n-1))
+                         , (15, liftM Para $ arbInlines (n-1))
+                         , (5,  liftM2 CodeBlock arbAttr realString)
+                         , (2,  elements [ RawBlock (Format "html")
+                                            "<div>\n*&amp;*\n</div>"
+                                         , RawBlock (Format "latex")
+                                            "\\begin[opt]{env}\nhi\n{\\end{env}"
+                                         ])
+                         , (5,  do x1 <- choose (1 :: Int, 6)
+                                   x2 <- arbInlines (n-1)
+                                   return (Header x1 nullAttr x2))
+                         , (2, return HorizontalRule)
+                         ] ++ [x | x <- nesters, n > 0]
+   where nesters = [ (5,  liftM BlockQuote $ listOf1 $ arbBlock (n-1))
+                   , (5,  do x2 <- arbitrary
+                             x3 <- arbitrary
+                             x1 <- arbitrary `suchThat` (> 0)
+                             x4 <- listOf1 $ listOf1 $ arbBlock (n-1)
+                             return $ OrderedList (x1,x2,x3) x4 )
+                   , (5,  liftM BulletList $ (listOf1 $ listOf1 $ arbBlock (n-1)))
+                   , (5,  do items <- listOf1 $ do
+                                        x1 <- listOf1 $ listOf1 $ arbBlock (n-1)
+                                        x2 <- arbInlines (n-1)
+                                        return (x2,x1)
+                             return $ DefinitionList items)
+                   , (2, do rs <- choose (1 :: Int, 4)
+                            cs <- choose (1 :: Int, 4)
+                            x1 <- arbInlines (n-1)
+                            x2 <- vector cs
+                            x3 <- vectorOf cs $ elements [0, 0.25]
+                            x4 <- vectorOf cs $ listOf $ arbBlock (n-1)
+                            x5 <- vectorOf rs $ vectorOf cs
+                                  $ listOf $ arbBlock (n-1)
+                            return (Table x1 x2 x3 x4 x5))
+                   ]
+
+instance Arbitrary Pandoc where
+        arbitrary = resize 8 $ liftM normalize
+                             $ liftM2 Pandoc arbitrary arbitrary
+
+instance Arbitrary CitationMode where
+        arbitrary
+          = do x <- choose (0 :: Int, 2)
+               case x of
+                   0 -> return AuthorInText
+                   1 -> return SuppressAuthor
+                   2 -> return NormalCitation
+                   _ -> error "FATAL ERROR: Arbitrary instance, logic bug"
+
+instance Arbitrary Citation where
+        arbitrary
+          = do x1 <- listOf $ elements $ ['a'..'z'] ++ ['0'..'9'] ++ ['_']
+               x2 <- arbInlines 1
+               x3 <- arbInlines 1
+               x4 <- arbitrary
+               x5 <- arbitrary
+               x6 <- arbitrary
+               return (Citation x1 x2 x3 x4 x5 x6)
+
+instance Arbitrary MathType where
+        arbitrary
+          = do x <- choose (0 :: Int, 1)
+               case x of
+                   0 -> return DisplayMath
+                   1 -> return InlineMath
+                   _ -> error "FATAL ERROR: Arbitrary instance, logic bug"
+
+instance Arbitrary QuoteType where
+        arbitrary
+          = do x <- choose (0 :: Int, 1)
+               case x of
+                   0 -> return SingleQuote
+                   1 -> return DoubleQuote
+                   _ -> error "FATAL ERROR: Arbitrary instance, logic bug"
+
+instance Arbitrary Meta where
+        arbitrary
+          = do (x1 :: Inlines) <- arbitrary
+               (x2 :: [Inlines]) <- liftM (filter (not . isNull)) arbitrary
+               (x3 :: Inlines) <- arbitrary
+               return $ setMeta "title" x1
+                      $ setMeta "author" x2
+                      $ setMeta "date" x3
+                      $ nullMeta
+
+instance Arbitrary Alignment where
+        arbitrary
+          = do x <- choose (0 :: Int, 3)
+               case x of
+                   0 -> return AlignLeft
+                   1 -> return AlignRight
+                   2 -> return AlignCenter
+                   3 -> return AlignDefault
+                   _ -> error "FATAL ERROR: Arbitrary instance, logic bug"
+
+instance Arbitrary ListNumberStyle where
+        arbitrary
+          = do x <- choose (0 :: Int, 6)
+               case x of
+                   0 -> return DefaultStyle
+                   1 -> return Example
+                   2 -> return Decimal
+                   3 -> return LowerRoman
+                   4 -> return UpperRoman
+                   5 -> return LowerAlpha
+                   6 -> return UpperAlpha
+                   _ -> error "FATAL ERROR: Arbitrary instance, logic bug"
+
+instance Arbitrary ListNumberDelim where
+        arbitrary
+          = do x <- choose (0 :: Int, 3)
+               case x of
+                   0 -> return DefaultDelim
+                   1 -> return Period
+                   2 -> return OneParen
+                   3 -> return TwoParens
+                   _ -> error "FATAL ERROR: Arbitrary instance, logic bug"
+
+ src/Database/Design/Ampersand/Test/Parser/ArbitraryTree.hs view
@@ -0,0 +1,354 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}
+{-# LANGUAGE FlexibleInstances #-}
+module Database.Design.Ampersand.Test.Parser.ArbitraryTree () where
+
+import Test.QuickCheck
+import Data.Char
+import Control.Applicative
+
+import Database.Design.Ampersand.Core.ParseTree
+import Database.Design.Ampersand.Input.ADL1.Lexer (keywords)
+
+-- Useful functions to build on the quick check functions
+
+-- Generates a simple ascii character
+printable :: Gen Char
+printable = suchThat arbitrary isValid
+    where isValid x = isPrint x && x <= 'Ñ' -- printable ASCII characters
+
+-- Generates a simple string of ascii characters
+safeStr :: Gen String
+safeStr = listOf printable
+
+-- Generates a simple non-empty string of ascii characters
+safeStr1 :: Gen String
+safeStr1 = listOf1 printable
+
+-- Genrates a valid ADL identifier
+identifier :: Gen String
+identifier = suchThat str2 noKeyword
+    where noKeyword x = x `notElem` keywords
+          -- The prelude functions accept Unicode characters
+          idChar = elements (['a'..'z']++['A'..'Z']++['0'..'9']++"_")
+          str2   = suchThat (listOf1 idChar) (\s -> length s > 1)
+
+-- Genrates a valid ADL upper-case identifier
+upperId :: Gen String
+upperId = suchThat identifier startUpper
+    where startUpper = isUpper . head
+
+-- Genrates a valid ADL lower-case identifier
+lowerId :: Gen String
+lowerId = suchThat identifier startLower
+    where startLower = isLower . head
+
+-- Generates an object
+objTermPrim :: Int -> Gen (P_ObjDef TermPrim)
+objTermPrim 0 = objTermPrim 1 -- minimum of 1 sub interface
+objTermPrim i =
+  makeObj genPrim ifc genView i
+    where ifc :: Int -> Gen (P_SubIfc TermPrim)
+          ifc n = subIfc objTermPrim (n`div`2)
+          --TODO: The view is never tested like this
+          genView = return Nothing
+          genPrim :: Gen TermPrim
+          genPrim = PNamedR <$> relationRef
+
+--TODO: refactor obj/ifc generators
+genObj :: Arbitrary a => Int -> Gen (P_ObjDef a)
+genObj = makeObj arbitrary genIfc (return Nothing)
+
+makeObj :: Gen a -> (Int -> Gen (P_SubIfc a)) -> Gen (Maybe String) -> Int -> Gen (P_ObjDef a)
+makeObj genPrim ifcGen genView n =
+        P_Obj <$> lowerId  <*> arbitrary <*> term <*> genView <*> ifc <*> args
+              where args = listOf $ listOf1 identifier
+                    term = Prim <$> genPrim
+                    ifc  = if n == 0 then return Nothing
+                           else Just <$> ifcGen (n`div`2)
+
+genIfc :: Arbitrary a => Int -> Gen (P_SubIfc a)
+genIfc = subIfc genObj
+
+subIfc :: (Int -> Gen (P_ObjDef a)) -> Int -> Gen (P_SubIfc a)
+subIfc objGen n =
+    if n == 0 then P_InterfaceRef <$> arbitrary <*> arbitrary <*> safeStr1
+    else P_Box          <$> arbitrary <*> boxKey   <*> vectorOf n (objGen$ n`div`2)
+    where boxKey = elements [Nothing, Just "ROWS", Just "COLS", Just "TABS"]
+
+
+--- Now the arbitrary instances
+instance Arbitrary Origin where
+    arbitrary = return OriginUnknown
+
+instance Arbitrary P_Context where
+    arbitrary = PCtx
+       <$> upperId   -- name
+       <*> listOf arbitrary  -- pos
+       <*> arbitrary  -- lang
+       <*> arbitrary  -- markup
+       <*> listOf upperId -- themes
+       <*> listOf arbitrary -- patterns
+       <*> listOf arbitrary -- rules
+       <*> listOf arbitrary -- relations
+       <*> listOf arbitrary -- concepts
+       <*> listOf arbitrary -- identities
+       <*> listOf arbitrary -- role rules
+       <*> listOf arbitrary -- role relations
+       <*> listOf arbitrary -- representation
+       <*> listOf arbitrary -- views
+       <*> listOf arbitrary -- gen definitions
+       <*> listOf arbitrary -- interfaces
+       <*> listOf arbitrary -- purposes
+       <*> listOf arbitrary -- populations
+       <*> listOf arbitrary -- sqlplugs
+       <*> listOf arbitrary -- phpplugs
+       <*> listOf arbitrary -- generic meta information
+
+instance Arbitrary Meta where
+    arbitrary = Meta <$> arbitrary <*> arbitrary <*>  safeStr  <*> safeStr
+
+instance Arbitrary MetaObj where
+    arbitrary = return ContextMeta
+
+instance Arbitrary P_RoleRelation where
+    arbitrary = P_RR <$> arbitrary <*> listOf1 arbitrary <*> listOf1 relationRef
+
+instance Arbitrary P_RoleRule where
+    arbitrary = Maintain <$> arbitrary <*> listOf1 arbitrary <*> listOf1 safeStr
+
+instance Arbitrary Representation where
+    arbitrary = Repr <$> arbitrary <*> listOf1 upperId <*> arbitrary
+
+instance Arbitrary TType where -- Not allowed are:  [ Object , TypeOfOne] 
+    arbitrary = elements [Alphanumeric, BigAlphanumeric, HugeAlphanumeric, Password
+                         , Binary, BigBinary, HugeBinary 
+                         , Date, DateTime 
+                         , Boolean, Integer, Float
+                         ]
+
+instance Arbitrary Role where
+    arbitrary = 
+      oneof [ Role    <$> safeStr
+            , Service <$> safeStr
+            ]
+
+instance Arbitrary P_Pattern where
+    arbitrary = P_Pat <$> arbitrary <*> safeStr1  <*> arbitrary <*> arbitrary <*> arbitrary
+                      <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary
+                      <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary
+
+instance Arbitrary P_Declaration where
+    arbitrary = P_Sgn <$> lowerId         -- name
+                      <*> arbitrary       -- sign
+                      <*> arbitrary       -- props
+                      <*> listOf safeStr1 -- pragma. Should be three, but the grammar allows more.
+                      <*> arbitrary       -- meaning
+                      <*> arbitrary       -- pairs
+                      <*> arbitrary       -- origin
+                      <*> arbitrary       -- plug
+
+instance Arbitrary a => Arbitrary (Term a) where
+    arbitrary = do lv <- choose (0,6)
+                   sized (genTerm lv)
+
+genTerm :: Arbitrary a => Int -> Int -> Gen (Term a)
+genTerm lv n = if n == 0
+               then Prim <$> arbitrary
+               else oneof options
+    where gen :: Arbitrary a => Int -> Gen (Term a)
+          gen l = genTerm l (n`div`2)
+  
+          options :: Arbitrary a => [Gen (Term a)]
+          options = concat $ drop lv levels
+          
+          levels :: Arbitrary a => [[Gen (Term a)]]
+          levels = [
+            -- level 0: pRule
+            [PEqu <$> arbitrary <*> gen 1 <*> gen 1,
+             PInc <$> arbitrary <*> gen 1 <*> gen 1],
+            -- level 1: pTerm
+            [PIsc <$> arbitrary <*> gen 2 <*> gen 2,
+             PUni <$> arbitrary <*> gen 2 <*> gen 2],
+            -- level 2: pTrm2
+            [PDif <$> arbitrary <*> gen 3 <*> gen 3],
+            -- level 3: pTrm3
+            [PLrs <$> arbitrary <*> gen 4 <*> gen 4,
+             PRrs <$> arbitrary <*> gen 4 <*> gen 4,
+             PDia <$> arbitrary <*> gen 4 <*> gen 4],
+            -- level 4: pTrm4
+            [PCps <$> arbitrary <*> gen 5 <*> gen 5,
+             PRad <$> arbitrary <*> gen 5 <*> gen 5,
+             PPrd <$> arbitrary <*> gen 5 <*> gen 5],
+            -- level 5: pTrm5
+            [PKl0 <$> arbitrary <*> gen 6,
+             PKl1 <$> arbitrary <*> gen 6,
+             PFlp <$> arbitrary <*> gen 6,
+             PCpl <$> arbitrary <*> gen 6],
+            -- level 6: pTrm6
+            [PBrk <$> arbitrary <*> gen 1,
+             Prim <$> arbitrary]]
+
+instance Arbitrary TermPrim where
+    arbitrary =
+        oneof [
+           PI <$> arbitrary,
+           Pid <$> arbitrary <*> genConceptOne,
+           Patm <$> arbitrary <*> arbitrary <*> maybeConceptOne,
+           PVee <$> arbitrary,
+           Pfull <$> arbitrary <*> genConceptOne <*> genConceptOne,
+           PNamedR <$> relationRef
+       ]
+      where maybeConceptOne = oneof [return Nothing, Just <$> genConceptOne]
+
+relationRef :: Gen P_NamedRel
+relationRef = PNamedRel <$> arbitrary <*> lowerId <*> arbitrary
+
+instance Arbitrary a => Arbitrary (PairView (Term a)) where
+    arbitrary = PairView <$> listOf1 arbitrary
+
+instance Arbitrary a => Arbitrary (PairViewSegment (Term a)) where
+    arbitrary = oneof [
+            PairViewText <$> arbitrary <*> safeStr,
+            PairViewExp <$> arbitrary <*> arbitrary <*> sized(genTerm 1) -- only accepts pTerm, no pRule.
+        ]
+
+instance Arbitrary a => Arbitrary (PairViewTerm a) where
+    arbitrary = PairViewTerm <$> arbitrary -- should be only (PairView (Term a))
+
+instance Arbitrary a => Arbitrary (PairViewSegmentTerm a) where
+    arbitrary = PairViewSegmentTerm <$> arbitrary -- should be only PairViewSegment (Term a)
+
+instance Arbitrary SrcOrTgt where
+    arbitrary = elements[Src, Tgt]
+
+instance Arbitrary a => Arbitrary (P_Rule a) where
+    arbitrary = P_Ru <$> arbitrary <*> safeStr <*> ruleTerm  <*> arbitrary <*> arbitrary
+                     <*> arbitrary
+              where ruleTerm = sized $ genTerm 0 -- rule is a term level 0
+
+instance Arbitrary ConceptDef where
+    arbitrary = Cd <$> arbitrary <*> safeStr <*> arbitrary <*> safeStr
+                   <*>  safeStr  <*> safeStr
+
+instance Arbitrary PAtomPair where
+    arbitrary = PPair <$> arbitrary <*> arbitrary <*> arbitrary
+
+instance Arbitrary P_Population where
+    arbitrary =
+        oneof [
+          (P_RelPopu Nothing Nothing) <$> arbitrary <*> arbitrary <*> arbitrary,
+          P_CptPopu <$> arbitrary <*> lowerId <*> arbitrary
+        ]
+
+instance Arbitrary P_NamedRel where
+    arbitrary = PNamedRel <$> arbitrary <*> lowerId <*> arbitrary
+
+instance Arbitrary PAtomValue where
+  -- Arbitrary must produce valid input from an ADL-file, so no Xlsx stuff allowed here,
+  -- otherwise it is likely that Quickcheck will fail because of it.
+    arbitrary = oneof
+       [ScriptString <$> arbitrary <*> safeStr `suchThat`  stringConstraints,
+        ScriptInt <$> arbitrary <*> arbitrary,
+        ScriptFloat <$> arbitrary <*> arbitrary,
+--        ScriptDate <$> arbitrary <*> arbitrary,
+--        ScriptDateTime <$> arbitrary <*> arbitrary,
+        ComnBool <$> arbitrary <*> arbitrary
+       ]
+     where stringConstraints :: String -> Bool
+           stringConstraints str =
+             case str of 
+              [] -> True
+              ('\\':_) -> False -- om van het geneuzel af te zijn. 
+              ('\'':_) -> False -- This string would cause problems as a Singleton in an Expresson
+              ('\\':'\'':cs) -> stringConstraints cs
+              ('\\':'"':cs) -> stringConstraints cs
+              ('"':_) -> False -- This string would cause problems as a Singleton in an Expresson
+              ['\\']  -> False -- If the last character is an escape, the double quote ending the string would not be seen as such. 
+              (_:cs)  -> stringConstraints cs
+instance Arbitrary P_Interface where
+    arbitrary = P_Ifc <$> safeStr1 <*> maybeSafeStr
+                      <*> listOf relationRef <*> args <*> listOf arbitrary
+                      <*> sized objTermPrim <*> arbitrary <*> safeStr
+                   where args = listOf $ listOf1 safeStr
+                         maybeSafeStr = oneof [Just <$> safeStr, return Nothing]
+
+instance Arbitrary a => Arbitrary (P_ObjDef a) where
+    arbitrary = sized genObj
+
+instance Arbitrary a => Arbitrary (P_SubIfc a) where
+    arbitrary = sized genIfc
+
+instance Arbitrary P_IdentDef where
+    arbitrary = P_Id <$> arbitrary <*> safeStr <*> arbitrary <*> listOf1 arbitrary
+
+instance Arbitrary P_IdentSegment where
+    arbitrary = P_IdentExp <$> sized objTermPrim
+
+instance Arbitrary a => Arbitrary (P_ViewD a) where
+    arbitrary =
+        oneof [P_Vd <$> arbitrary <*> safeStr <*> genConceptOne
+                    <*> return True <*> return Nothing <*> listOf1 arbitrary,
+               P_Vd <$> arbitrary <*> safeStr <*> genConceptOne
+                    <*> arbitrary <*> arbitrary <*> listOf1 (P_ViewExp <$> arbitrary <*> arbitrary)]
+
+instance Arbitrary ViewHtmlTemplate where
+    arbitrary = ViewHtmlTemplateFile <$> safeStr
+
+instance Arbitrary a => Arbitrary (P_ViewSegmt a) where
+    arbitrary =
+        oneof [
+            P_ViewExp  <$> arbitrary <*> arbitrary,
+            P_ViewText <$> arbitrary <*> safeStr,
+            P_ViewHtml <$> arbitrary <*> safeStr
+        ]
+
+instance Arbitrary PPurpose where
+    arbitrary = PRef2 <$> arbitrary <*> arbitrary <*> arbitrary <*> listOf safeStr1
+
+instance Arbitrary PRef2Obj where
+    arbitrary =
+        oneof [
+            PRef2ConceptDef <$> safeStr,
+            PRef2Declaration <$> relationRef,
+            PRef2Rule <$> upperId,
+            PRef2IdentityDef <$> upperId,
+            PRef2ViewDef <$> upperId,
+            PRef2Pattern <$> upperId,
+            PRef2Interface <$> upperId,
+            PRef2Context <$> upperId
+        ]
+
+instance Arbitrary PMeaning where
+    arbitrary = PMeaning <$> arbitrary
+
+instance Arbitrary PMessage where
+    arbitrary = PMessage <$> arbitrary
+
+instance Arbitrary P_Concept where
+    arbitrary = PCpt <$> upperId
+
+genConceptOne :: Gen P_Concept
+genConceptOne = oneof [arbitrary, return P_Singleton]
+
+instance Arbitrary P_Sign where
+    arbitrary = P_Sign <$> arbitrary <*> arbitrary
+
+instance Arbitrary P_Gen where
+    arbitrary =
+        oneof [
+            P_Cy <$> arbitrary <*> concept <*> listOf1 arbitrary,
+            PGen <$> arbitrary <*> concept <*> concept
+        ]
+        where concept = PCpt <$> upperId
+
+instance Arbitrary Lang where
+    arbitrary = elements [Dutch, English]
+
+instance Arbitrary P_Markup where
+    arbitrary = P_Markup <$> arbitrary <*> arbitrary <*> safeStr
+
+instance Arbitrary PandocFormat where
+    arbitrary = elements [HTML, ReST, LaTeX, Markdown]
+
+instance Arbitrary Prop where
+    arbitrary = elements [Uni, Inj, Sur, Tot, Sym, Asy, Trn, Rfx, Irf, Aut, Prop]
+ src/Database/Design/Ampersand/Test/Parser/ParserTest.hs view
@@ -0,0 +1,36 @@+{-# LANGUAGE Rank2Types, NoMonomorphismRestriction, ScopedTypeVariables #-}
+module Database.Design.Ampersand.Test.Parser.ParserTest (
+    parseReparse, parseScripts, showErrors
+) where
+
+import Prelude hiding (readFile)
+import Database.Design.Ampersand.ADL1.PrettyPrinters(prettyPrint)
+import Database.Design.Ampersand.Core.ParseTree
+import Database.Design.Ampersand.Input.ADL1.CtxError (Guarded(..),whenChecked,CtxError)
+import Database.Design.Ampersand.Input.ADL1.Parser
+import Database.Design.Ampersand.Input.Parsing
+import Database.Design.Ampersand.Misc.Options(Options)
+import System.IO (hPutStrLn, stderr)
+
+-- Tries to parse all the given files
+parseScripts :: Options -> [FilePath] -> IO Bool
+parseScripts _ [] = return True
+parseScripts opts (f:fs) =
+     do parsed <- parseADL opts (Left f)
+        case parsed of
+            Checked _ -> do { putStrLn ("Parsed: " ++ f); parseScripts opts fs }
+            Errors  e -> do { putStrLn ("Cannot parse: " ++ f); showErrors e; return False }
+
+printErrLn :: Show a => a -> IO ()
+printErrLn a = hPutStrLn stderr (show a)
+
+showErrors :: [CtxError] -> IO ()
+showErrors [] = return ()
+showErrors (e:es) = do { printErrLn e; showErrors es }
+
+parse :: FilePath -> String -> Guarded P_Context
+parse file txt = whenChecked (runParser pContext file txt) (Checked . fst)
+
+parseReparse :: FilePath -> String -> Guarded P_Context
+parseReparse file txt = whenChecked (parse file txt) reparse
+                  where reparse p = parse (file ++ "**pretty") (prettyPrint p)
+ src/Database/Design/Ampersand/Test/Parser/QuickChecks.hs view
@@ -0,0 +1,45 @@+{-# LANGUAGE Rank2Types, NoMonomorphismRestriction, ScopedTypeVariables #-}
+module Database.Design.Ampersand.Test.Parser.QuickChecks (parserQuickChecks) where
+
+import Database.Design.Ampersand.Test.Parser.ParserTest (parseReparse)
+import Database.Design.Ampersand.Test.Parser.ArbitraryTree()
+import Database.Design.Ampersand.ADL1.PrettyPrinters(prettyPrint)
+import Database.Design.Ampersand.Core.ParseTree (P_Context)
+import Database.Design.Ampersand.Input.ADL1.CtxError (Guarded(..))
+
+import Test.QuickCheck(Args(..), quickCheckWithResult, Testable, Result(..))
+import Debug.Trace
+
+-- Tries to parse a string, and if successful, tests the result with the given function
+testParse :: String -> (P_Context -> Bool) -> Bool
+testParse text check = case parseReparse "File generated by QuickCheck. When you see it in an error, there is something wrong with the parser!" text of
+            Checked a -> check a
+            Errors e  -> trace (show e ++ "\n" ++ text) False
+            -- TODO: Errors e  -> do { showErrors e; return False }
+
+-- Tests whether the parsed context is equal to the original one
+prop_pretty :: P_Context -> Bool
+prop_pretty ctx = testParse prettyCtx eq
+        where eq p = ctx == p || trace ("Printed versions are different: " ++ prettyCtx ++ "\n\n---------\n\n" ++ prettyPrint p) False
+              prettyCtx = unlines . map includeLineNr . zip [1..] . lines $ prettyPrint ctx
+              includeLineNr :: (Int,String) -> String
+              includeLineNr (nr,str) = "{-"++take (4 - length (show nr)) (repeat '0')++show nr++"-} "++str
+
+checkArgs :: Args
+checkArgs = Args
+  { replay          = Nothing
+  , maxSuccess      = 64
+  , maxDiscardRatio = 8
+  , maxSize         = 8      -- otherwise there's nothing quick about it.
+  , chatty          = False
+  }
+
+-- TODO: Improve the messages given here, remove all trace's
+test :: Testable prop => prop -> IO (Bool, String)
+test p = do res <- quickCheckWithResult checkArgs p
+            case res of
+                Success {} -> return (True, "")
+                _          -> return (False, show res )
+
+parserQuickChecks :: IO (Bool,String)
+parserQuickChecks = test prop_pretty
+ src/Database/Design/Ampersand/Test/RunAmpersand.hs view
@@ -0,0 +1,20 @@+module Database.Design.Ampersand.Test.RunAmpersand (ampersand) where
+
+import Database.Design.Ampersand.Misc.Options(getOptions,Options(..))
+import Database.Design.Ampersand.FSpec.ToFSpec.CreateFspec(createFSpec)
+import Database.Design.Ampersand.Input.ADL1.CtxError
+
+ampersand :: [FilePath] -> IO [(FilePath,[CtxError])]
+ampersand files = 
+  do opts <- getOptions
+     mapM (runAmpersand opts) files
+
+runAmpersand :: Options -> FilePath -> IO (FilePath,[CtxError])
+runAmpersand opts file = 
+        do gFSpec <- createFSpec opts{ fileName = file }
+           case gFSpec of
+              Errors err    -> return (file,err)
+              --TODO: Do something with the fSpec
+              Checked _     -> do --generateAmpersandOutput fSpec
+                                  --generateProtoStuff      fSpec
+                                  return (file,[])
+ src/Database/Design/Ampersand/Test/TestScripts.hs view
@@ -0,0 +1,132 @@+{-# LANGUAGE Rank2Types, NoMonomorphismRestriction, ScopedTypeVariables #-}
+module Database.Design.Ampersand.Test.TestScripts (getTestScripts,testAmpersandScripts) where
+
+import Data.List
+import Data.Char(toUpper)
+import System.FilePath ((</>),takeExtension)
+import Control.Monad --(filterM, forM_, foldM,when)
+import Control.Exception.Base
+import System.IO.Error (tryIOError)
+import System.Directory (getDirectoryContents, doesFileExist, doesDirectoryExist)
+import Control.Monad.Trans.Class (lift)
+import Data.Conduit
+import Database.Design.Ampersand.Test.RunAmpersand (ampersand)
+import Database.Design.Ampersand.Input.ADL1.CtxError
+
+--endswith :: String -> String -> Bool
+--endswith a b = drop (length a - length b) a == b
+
+-- Returns tuple with files and subdirectories inside the given directory
+--getDirectory :: FilePath -> IO ([FilePath],[FilePath])
+--getDirectory path =
+--    do contents <- getDirectoryContents path
+--       let valid = filter (\x-> x /= "." && x /= "..") contents
+--       let paths = map (path ++) valid
+--       files <- filterM doesFileExist paths
+--       subdirs <- filterM doesDirectoryExist paths
+--       return (sort files, sort subdirs)
+
+--getFiles :: String -> FilePath -> IO [FilePath]
+--getFiles ext dir =
+--    do (fs, ds) <- getDirectory (dir++"/")
+--       let files = filter (`endswith` ext) fs
+--       foldM recursive files ds
+--      where recursive rs d =
+--                do ms <- getFiles ext d
+--                   return $ ms ++ rs
+
+
+getTestScripts :: IO [FilePath]
+getTestScripts = do
+--        fs <- getFiles ".adl" "ArchitectureAndDesign"
+--        ss <- getFiles ".adl" $ ".." </> "ampersand-models" </> "Tests" </> "ShouldSucceed"
+--        ds <- getFiles ".adl" $ "AmpersandData" </> "FormalAmpersand"
+        return $ [] --enabling these test as a single testcase will stop the sentinel from working. Was: fs ++ ss ++ ds -- ++ models
+
+
+
+data DirContent = DirList [FilePath] [FilePath]
+                | DirError IOError
+data DirData = DirData FilePath DirContent
+
+testAmpersandScripts :: IO ()
+testAmpersandScripts
+ = do 
+    walk baseDir $$ myVisitor
+ where
+    baseDir = ".." </> "ampersand-models"
+
+-- Produces directory data
+walk :: FilePath -> Source IO DirData
+walk path = do 
+    result <- lift $ tryIOError listdir
+    case result of
+        Right dl
+            -> case dl of 
+                DirList subdirs _
+                 -> do
+                     yield (DirData path dl)
+                     forM_ subdirs (walk . (path </>))
+                DirError err 
+                 -> yield (DirData path (DirError err))
+        Left err
+            -> yield (DirData path (DirError err))
+
+  where
+    listdir = do
+        entries <- getDirectoryContents path >>= filterHidden
+        subdirs <- filterM isDir entries
+        files <- filterM isFile entries
+        return $ DirList subdirs (filter isRelevant files)
+        where 
+            isFile entry = doesFileExist (path </> entry)
+            isDir entry = doesDirectoryExist (path </> entry)
+            filterHidden paths = return $ filter (not.isHidden) paths
+            isRelevant f = map toUpper (takeExtension f) `elem` [".ADL"]  
+            isHidden dir = head dir == '.'
+            
+-- Consume directories
+myVisitor :: Sink DirData IO ()
+myVisitor = addCleanup (\_ -> putStrLn "Finished.") $ loop 1
+  where
+    loop :: Int -> ConduitM DirData a IO ()
+    loop n = do
+        lift $ putStr $ ">> " ++ show n ++ ". "
+        mr <- await
+        case mr of
+            Nothing     -> return ()
+            Just r      -> lift (process r) >> loop (n + 1)
+    process (DirData path (DirError err)) = do
+        putStrLn $ "I've tried to look in " ++ path ++ "."
+        putStrLn $ "    There was an error: "
+        putStrLn $ "       " ++ show err
+
+    process (DirData path (DirList dirs files)) = do
+        putStrLn $ path ++ ". ("++ show (length dirs) ++ " directorie(s) and " ++ show (length files) ++ " relevant file(s):"
+        forM_ files (runATest path) 
+     
+runATest :: FilePath -> FilePath -> IO()
+runATest path file =
+  catch (runATest' path file) showError
+   where 
+     showError :: SomeException -> IO()
+     showError err
+       = do putStrLn "***** ERROR: Fatal error was thrown: *****"
+            putStrLn $ (path </> file)
+            putStrLn $ show err
+            putStrLn "******************************************"
+        
+runATest' :: FilePath -> FilePath -> IO()
+runATest' path file = do
+       [(_,errs)] <- ampersand [path </> file]
+       putStrLn 
+         ( file ++": "++
+           case (shouldFail,errs) of
+                  (False, []) -> "OK.  => Pass"
+                  (False, _ ) -> "Fail => NOT PASSED:"
+                  (True , []) -> "Ok.  => NOT PASSED"
+                  (True , _ ) -> "Fail => Pass"
+         )
+       when (not shouldFail) $ mapM_ putStrLn (map showErr (take 1 errs))  --for now, only show the first error
+    where shouldFail = "SHOULDFAIL" `isInfixOf` map toUpper (path </> file)
+
src/Main.hs view
@@ -1,20 +1,17 @@ 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.Prototype.ObjBinGen   (generatePhp, writeStaticFiles)
+import Database.Design.Ampersand.Core.AbstractSyntaxTree
 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 =
@@ -31,36 +28,29 @@ 
 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))
-                  }
-         }
+-- HJO: The following has been commented out, because:
+-- 1) it does not seem to be used
+-- 2) It's purpose is unclear
+-- 3) underlying code has been modified. It is unclear what that would mean for this functionality
+--     ==> Hence, we have bitrot.
+--  | 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
@@ -75,9 +65,9 @@ doGenProto :: FSpec -> IO ()
 doGenProto fSpec =
  do { verboseLn (getOpts fSpec) "Checking on rule violations..."
-    ; reportViolations (allViolations fSpec)
+    ; reportViolations violationsOfInvariants
     ; reportSignals (initialConjunctSignals fSpec)
-    ; if (not . null) (allViolations fSpec) && not (development (getOpts fSpec)) && theme (getOpts fSpec)/=StudentTheme
+    ; if (not . null) violationsOfInvariants && 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
               }
@@ -95,27 +85,36 @@                 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 ]
+ where violationsOfInvariants :: [(Rule,[AAtomPair])]
+       violationsOfInvariants 
+         = [(r,vs) |(r,vs) <- allViolations fSpec
+                   , not (isSignal r)
+           ]
+       reportViolations :: [(Rule,[AAtomPair])] -> IO()
+       reportViolations []    = verboseLn (getOpts fSpec) "No violations found."
+       reportViolations viols = 
+         let ruleNamesAndViolStrings = [ (name r, showprs 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
                           ]
                           
+       showprs :: [AAtomPair] -> String
+       showprs aprs = "["++intercalate ", " (map showADL aprs)++"]"
+--       showpr :: AAtomPair -> String
+--       showpr apr = "( "++(showVal.apLeft) apr++", "++(showVal.apRight) apr++" )" 
        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
+         [   "Rule(s): "++(show . map name . rc_orgRules) conj 
+         ++"\n  Conjunct   : " ++ showADL (rc_conjunct conj)
+         ++"\n  Violations : " ++ showprs viols
          | (conj, viols) <- conjViols
          ]
-
 ruleTest :: FSpec -> String -> IO ()
 ruleTest fSpec ruleName =
  case [ rule | rule <- grules fSpec ++ vrules fSpec, name rule == ruleName ] of
@@ -127,6 +126,6 @@                   ; 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]
+ where showContents rule = let pairs = [ "("++(show.showValADL.apLeft) v++"," ++(show.showValADL.apRight) v++")" | (r,vs) <- allViolations fSpec, r == rule, v <- vs]
                            in  "[" ++ intercalate ", " pairs ++ "]"
+ src/Test.hs view
@@ -0,0 +1,36 @@+module Main (main) where
+
+import Database.Design.Ampersand.Misc.Options(getOptions,Options)
+import Database.Design.Ampersand.Test.TestScripts (getTestScripts,testAmpersandScripts)
+import Database.Design.Ampersand.Test.Parser.ParserTest (parseScripts)
+import Database.Design.Ampersand.Test.Parser.QuickChecks (parserQuickChecks)
+import System.Exit (ExitCode, exitFailure, exitSuccess)
+
+testFunctions :: Options -> IO [([String], IO Bool)]
+testFunctions opts =
+    do scr <- getTestScripts
+       (parserCheckResult, msg) <- parserQuickChecks
+       return [ (["Parsing " ++ show (length scr) ++ " scripts."], parseScripts opts scr)
+            --  , ("Executing ampersand chain", ampersand scr)
+              , ( if parserCheckResult  
+                  then ["Parser & prettyprinter test PASSED."]
+                  else (  ["QuickCheck found errors in the roundtrip in parsing/prettyprinting for the following case:"]
+                        ++map ("\n   "++) (lines msg)
+                       )
+                , return parserCheckResult
+                )
+              ]
+
+main :: IO ExitCode
+main = do opts <- getOptions
+          funcs <- testFunctions opts
+          testAmpersandScripts
+          tests funcs
+    where tests :: [([String], IO Bool)] -> IO ExitCode
+          tests [] = exitSuccess
+          tests ((msg,test):xs) =
+            do mapM_ putStrLn msg
+               success <- test
+               if success then tests xs
+               else do putStrLn "*** Something went wrong here***" 
+                       exitFailure